From 774eb668de54d0f151184a7e49d0d1ca87360ffb Mon Sep 17 00:00:00 2001 From: Nathan Braswell Date: Sun, 19 Nov 2023 16:33:19 -0500 Subject: [PATCH] Clean out, start sl JIT project (no jit yet) --- .gitignore | 1 + README.md | 12 +- basic_dyns | 88 - doc/.gitignore | 12 - doc/cited-paper.bib | 11 - doc/make_presentation.sh | 9 - doc/make_writeup.sh | 8 - doc/nix/sources.json | 38 - doc/nix/sources.nix | 174 - doc/presentation.tex | 570 -- doc/psudocode.txt | 306 - doc/shell.nix | 11 - doc/writeup.tex | 263 - fib_test/builtin_fib.kp | 36 - fib_test/clojure_fib/.gitignore | 13 - fib_test/clojure_fib/LICENSE | 280 - fib_test/clojure_fib/project.clj | 10 - fib_test/clojure_fib/src/clojure_fib/core.clj | 14 - fib_test/clojure_hi/.gitignore | 13 - fib_test/clojure_hi/LICENSE | 280 - fib_test/clojure_hi/project.clj | 10 - fib_test/clojure_hi/src/clojure_hi/core.clj | 7 - fib_test/fib.c | 14 - fib_test/fib.kp | 36 - fib_test/fib.py | 9 - fib_test/fib.scm | 4 - fib_test/fib2.kp | 36 - fib_test/fib_let.c | 16 - fib_test/fib_let.kp | 39 - fib_test/fib_let.py | 11 - fib_test/fib_let.scm | 7 - fib_test/fib_tests.sh | 44 - fib_test/rust_fib/Cargo.lock | 7 - fib_test/rust_fib/Cargo.toml | 8 - fib_test/rust_fib/src/main.rs | 18 - fib_test/table.md | 16 - flake.lock | 18 +- kr/.gitignore | 1 - kr/Cargo.lock | 559 -- kr/src/ast.rs | 338 - kr/src/grammar.lalrpop | 31 - kr/src/main.rs | 26 - kr/src/pe_ast.rs | 1493 ---- kr/src/test.rs | 625 -- kv/Cargo.lock | 292 +- kv/src/basic.rs | 2 + misc_tests/basic_match.kp | 175 - misc_tests/fact.kp | 35 - misc_tests/fact_lognoopt.kp | 36 - misc_tests/find.kp | 110 - misc_tests/int2hex.kp | 66 - misc_tests/leftrotate32bit.kp | 36 - misc_tests/palindrome.kp | 49 - misc_tests/t.kp | 15 - misc_tests/to_compile.kp | 917 --- partial_eval.scm | 6946 ----------------- sl/Cargo.lock | 902 +++ {kr => sl}/Cargo.toml | 14 +- {kr => sl}/build.rs | 0 sl/src/grammar.lalrpop | 31 + sl/src/lib.rs | 186 + sl/src/main.rs | 18 + small_demo/demo.sh | 14 - small_demo/enter_debug.kp | 156 - small_demo/small_demo.kp | 1 - small_demo/small_lambda_demo.kp | 1 - small_demo/small_macro_demo.kp | 8 - small_demo/small_test.kp | 154 - small_demo/small_vau_demo.kp | 1 - website/index.html | 7 +- ...sentation.html => quals_presentation.html} | 0 website/slides_to_add | 5 - working_files/bf.kp | 52 - working_files/collections.kp | 27 - working_files/comp_wasm.kp | 92 - working_files/compile_for_web.sh | 4 - working_files/damas_hindley_milner.kp | 141 - working_files/damas_hindley_milner_test.kp | 2 - working_files/dlambda_test.kp | 20 - working_files/even_odd.kp | 51 - working_files/fib-comp.kp | 8 - working_files/fib-interp.kp | 5 - working_files/fib.c | 17 - working_files/fungll.kp | 96 - working_files/fungll_test.kp | 48 - working_files/import_test.kp | 1 - working_files/index.html | 425 - working_files/k_prime_stdlib/method.kp | 100 - working_files/k_prime_stdlib/prelude.kp | 82 - working_files/match.kp | 32 - working_files/match_test.kp | 49 - working_files/method.kp | 103 - working_files/new_kraken.kp | 102 - working_files/new_kraken_test.kp | 49 - working_files/partial_eval.kp | 521 -- working_files/partial_eval_test.csc | 35 - working_files/partial_eval_test.kp | 176 - working_files/partial_eval_test_rec.kp | 40 - working_files/prelude.kp | 297 - working_files/rb.kp | 132 - working_files/rb_profile.txt | 29 - working_files/rb_test.kp | 50 - working_files/sierpinski.kp | 38 - working_files/smaller_new_kraken_test.kp | 15 - working_files/test.csc | 35 - working_files/test_parse_in | 3 - working_files/test_parse_in_large | 1 - working_files/test_ystar_vau.kp | 6 - working_files/types.kp | 141 - working_files/types_test.kp | 2 - working_files/wasm.kp | 384 - 111 files changed, 1337 insertions(+), 17773 deletions(-) delete mode 100644 basic_dyns delete mode 100644 doc/.gitignore delete mode 100644 doc/cited-paper.bib delete mode 100755 doc/make_presentation.sh delete mode 100755 doc/make_writeup.sh delete mode 100644 doc/nix/sources.json delete mode 100644 doc/nix/sources.nix delete mode 100644 doc/presentation.tex delete mode 100644 doc/psudocode.txt delete mode 100644 doc/shell.nix delete mode 100644 doc/writeup.tex delete mode 100644 fib_test/builtin_fib.kp delete mode 100644 fib_test/clojure_fib/.gitignore delete mode 100644 fib_test/clojure_fib/LICENSE delete mode 100644 fib_test/clojure_fib/project.clj delete mode 100644 fib_test/clojure_fib/src/clojure_fib/core.clj delete mode 100644 fib_test/clojure_hi/.gitignore delete mode 100644 fib_test/clojure_hi/LICENSE delete mode 100644 fib_test/clojure_hi/project.clj delete mode 100644 fib_test/clojure_hi/src/clojure_hi/core.clj delete mode 100644 fib_test/fib.c delete mode 100644 fib_test/fib.kp delete mode 100644 fib_test/fib.py delete mode 100644 fib_test/fib.scm delete mode 100644 fib_test/fib2.kp delete mode 100644 fib_test/fib_let.c delete mode 100644 fib_test/fib_let.kp delete mode 100644 fib_test/fib_let.py delete mode 100644 fib_test/fib_let.scm delete mode 100755 fib_test/fib_tests.sh delete mode 100644 fib_test/rust_fib/Cargo.lock delete mode 100644 fib_test/rust_fib/Cargo.toml delete mode 100644 fib_test/rust_fib/src/main.rs delete mode 100644 fib_test/table.md delete mode 100644 kr/.gitignore delete mode 100644 kr/Cargo.lock delete mode 100644 kr/src/ast.rs delete mode 100644 kr/src/grammar.lalrpop delete mode 100644 kr/src/main.rs delete mode 100644 kr/src/pe_ast.rs delete mode 100644 kr/src/test.rs delete mode 100644 misc_tests/basic_match.kp delete mode 100644 misc_tests/fact.kp delete mode 100644 misc_tests/fact_lognoopt.kp delete mode 100644 misc_tests/find.kp delete mode 100644 misc_tests/int2hex.kp delete mode 100644 misc_tests/leftrotate32bit.kp delete mode 100644 misc_tests/palindrome.kp delete mode 100644 misc_tests/t.kp delete mode 100644 misc_tests/to_compile.kp delete mode 100644 partial_eval.scm create mode 100644 sl/Cargo.lock rename {kr => sl}/Cargo.toml (52%) rename {kr => sl}/build.rs (100%) create mode 100644 sl/src/grammar.lalrpop create mode 100644 sl/src/lib.rs create mode 100644 sl/src/main.rs delete mode 100755 small_demo/demo.sh delete mode 100644 small_demo/enter_debug.kp delete mode 100644 small_demo/small_demo.kp delete mode 100644 small_demo/small_lambda_demo.kp delete mode 100644 small_demo/small_macro_demo.kp delete mode 100644 small_demo/small_test.kp delete mode 100644 small_demo/small_vau_demo.kp rename website/{presentation.html => quals_presentation.html} (100%) delete mode 100644 website/slides_to_add delete mode 100644 working_files/bf.kp delete mode 100644 working_files/collections.kp delete mode 100644 working_files/comp_wasm.kp delete mode 100755 working_files/compile_for_web.sh delete mode 100644 working_files/damas_hindley_milner.kp delete mode 100644 working_files/damas_hindley_milner_test.kp delete mode 100644 working_files/dlambda_test.kp delete mode 100644 working_files/even_odd.kp delete mode 100644 working_files/fib-comp.kp delete mode 100644 working_files/fib-interp.kp delete mode 100644 working_files/fib.c delete mode 100644 working_files/fungll.kp delete mode 100644 working_files/fungll_test.kp delete mode 100644 working_files/import_test.kp delete mode 100644 working_files/index.html delete mode 100644 working_files/k_prime_stdlib/method.kp delete mode 100644 working_files/k_prime_stdlib/prelude.kp delete mode 100644 working_files/match.kp delete mode 100644 working_files/match_test.kp delete mode 100644 working_files/method.kp delete mode 100644 working_files/new_kraken.kp delete mode 100644 working_files/new_kraken_test.kp delete mode 100644 working_files/partial_eval.kp delete mode 100644 working_files/partial_eval_test.csc delete mode 100644 working_files/partial_eval_test.kp delete mode 100644 working_files/partial_eval_test_rec.kp delete mode 100644 working_files/prelude.kp delete mode 100644 working_files/rb.kp delete mode 100644 working_files/rb_profile.txt delete mode 100644 working_files/rb_test.kp delete mode 100644 working_files/sierpinski.kp delete mode 100644 working_files/smaller_new_kraken_test.kp delete mode 100644 working_files/test.csc delete mode 100644 working_files/test_parse_in delete mode 100644 working_files/test_parse_in_large delete mode 100644 working_files/test_ystar_vau.kp delete mode 100644 working_files/types.kp delete mode 100644 working_files/types_test.kp delete mode 100644 working_files/wasm.kp diff --git a/.gitignore b/.gitignore index 3993544..ecd696c 100644 --- a/.gitignore +++ b/.gitignore @@ -13,3 +13,4 @@ build-ninja callgrind* .stfolder *.wasm +*/target diff --git a/README.md b/README.md index 84a0763..3ea001f 100644 --- a/README.md +++ b/README.md @@ -5,11 +5,19 @@ The Kraken Programming Language (more information online at http://kraken-lang.org/ which is also under construction / needs to be updated / has a try-it-online feature for an older version without partial evaluation) -Currently developing the third iteration, a Scheme-like based on a functional Vau calculus partially-evaluated for efficency and compiling to WebAssembly. - *Heavily* inspiried by John Shutt's thesis: https://web.wpi.edu/Pubs/ETD/Available/etd-090110-124904/unrestricted/jshutt.pdf with partial evaluation during compilation to make it efficient. +Currently developing the fourth iteration, a Scheme-like based on a functional Vau calculus JIT compiled for speed. + +Working up to a JIT for fexprs by starting with + +- sl - a Simple Lisp JIT (WIP) +- ? +- ? +- ? +- kv - A fexpr interpeter with mutation and delimited continuations - need to add a JIT to this + koka_bench: Licensed under Apache-2.0, as they are derived from the benchmarks of the Koka project, see the readme and license in koka_bench for more, or https://github.com/koka-lang/koka for the source project. diff --git a/basic_dyns b/basic_dyns deleted file mode 100644 index 59a3eb9..0000000 --- a/basic_dyns +++ /dev/null @@ -1,88 +0,0 @@ - - - - - -RB-TREE - - evals all_evals evaled_wrap_1 evaled_wrap_0 compiled_dyn_1 compiled_dyn_0 -non-PE10 114_170 5_032_297 1_291_489 398_104 1 0 - PE10 0 0 0 0 10 0 -nonPE9 97087 4278001 1097965 338383 1 0 - PE9 0 0 0 0 9 0 -nonPE8 80160 3532131 906548 279379 1 0 - PE8 0 0 0 0 8 0 -nonPE7 67050 2952848 757932 233513 1 0 - PE7 0 0 0 0 7 0 -nonPE6 50361 2219792 569723 175593 1 0 - PE6 0 0 0 0 6 0 -nonPE5 37299 1643049 421745 129938 1 0 - PE5 0 0 0 0 5 0 -nonPE4 24393 1074730 275873 85000 1 0 - PE4 0 0 0 0 4 0 -nonPE3 15304 672998 172802 53200 1 0 - PE3 0 0 0 0 3 0 -nonPE2 6453 284080 72939 22484 1 0 - PE2 0 0 0 0 2 0 -nonPE1 1385 59899 15413 4750 1 0 - PE1 0 0 0 0 1 0 - - - - - - -Fib - - evals all_evals evaled_wrap_1 evaled_wrap_0 compiled_dyn_1 compiled_dyn_0 -non-PE35 29860726 1320920726 337695363 119442881 1 0 -non-PE30 2692560 119107888 30450112 10770217 1 0 -non-PE25 242808 10740492 2745825 971209 1 0 -non-PE20 21914 969010 247731 87633 1 0 -non-PE15 1996 87916 22478 7961 1 0 -non-PE10 200 8468 2167 777 1 0 - - PE10 0 0 0 0 0 0 - PE15 0 0 0 0 0 0 - PE20 0 0 0 0 0 0 - PE25 0 0 0 0 0 0 - PE30 0 0 0 0 0 0 - PE35 0 0 0 0 0 0 - - - - - - - - -cfold - evals all_evals evaled_wrap_1 evaled_wrap_0 compiled_dyn_1 compiled_dyn_0 -non-PE5 239660 10897376 2784275 879066 1 0 - PE5 0 0 0 0 0 0 - - -deriv - evals all_evals evaled_wrap_1 evaled_wrap_0 compiled_dyn_1 compiled_dyn_0 -non-PE2 257693 11708558 2990090 946500 1 0 - PE2 0 0 0 0 2 0 - - -nqueens - evals all_evals evaled_wrap_1 evaled_wrap_0 compiled_dyn_1 compiled_dyn_0 -non-PE7 271720 13530241 3429161 1108393 1 0 - PE7 0 0 0 0 0 0 - - - - - - - - - - - scheme --script ../../partial_eval.scm rbtree-opt.kp no_partial_eval && mv csc_out.wasm rbtree-opt.wasm && time wasmtime ./rbtree-opt.wasm 10 - scheme --script ../../partial_eval.scm rbtree-opt.kp && mv csc_out.wasm rbtree-opt.wasm && time wasmtime ./rbtree-opt.wasm 10 - - diff --git a/doc/.gitignore b/doc/.gitignore deleted file mode 100644 index cf001e5..0000000 --- a/doc/.gitignore +++ /dev/null @@ -1,12 +0,0 @@ -*.swp -*.zip -*.aux -*.bbl -*.blg -*.log -*.out -*.pdf -*.nav -*.snm -*.toc -*.vrb diff --git a/doc/cited-paper.bib b/doc/cited-paper.bib deleted file mode 100644 index ed4c8f9..0000000 --- a/doc/cited-paper.bib +++ /dev/null @@ -1,11 +0,0 @@ - -@phdthesis{shutt2010fexprs, - title={Fexprs as the basis of Lisp function application or \$vau: the ultimate abstraction}, - author={Shutt, John N}, - year={2010} -} -@article{kearsleyimplementing, - title={Implementing a Vau-based Language With Multiple Evaluation Strategies}, - author={Kearsley, Logan} -} - diff --git a/doc/make_presentation.sh b/doc/make_presentation.sh deleted file mode 100755 index ba241e4..0000000 --- a/doc/make_presentation.sh +++ /dev/null @@ -1,9 +0,0 @@ -#!/usr/bin/env bash -rm presentation.aux -rm presentation.bbl -rm presentation.blg -rm presentation.log -rm presentation.out -rm presentation.pdf -#pdflatex presentation && bibtex presentation && pdflatex presentation && bibtex presentation && pdflatex presentation && bibtex presentation && evince presentation.pdf -pdflatex presentation && evince presentation.pdf diff --git a/doc/make_writeup.sh b/doc/make_writeup.sh deleted file mode 100755 index f792d2d..0000000 --- a/doc/make_writeup.sh +++ /dev/null @@ -1,8 +0,0 @@ -#!/usr/bin/env bash -rm writeup.aux -rm writeup.bbl -rm writeup.blg -rm writeup.log -rm writeup.out -rm writeup.pdf -pdflatex writeup && bibtex writeup && pdflatex writeup && bibtex writeup && pdflatex writeup && bibtex writeup && evince writeup.pdf diff --git a/doc/nix/sources.json b/doc/nix/sources.json deleted file mode 100644 index 0704cd5..0000000 --- a/doc/nix/sources.json +++ /dev/null @@ -1,38 +0,0 @@ -{ - "niv": { - "branch": "master", - "description": "Easy dependency management for Nix projects", - "homepage": "https://github.com/nmattia/niv", - "owner": "nmattia", - "repo": "niv", - "rev": "65a61b147f307d24bfd0a5cd56ce7d7b7cc61d2e", - "sha256": "17mirpsx5wyw262fpsd6n6m47jcgw8k2bwcp1iwdnrlzy4dhcgqh", - "type": "tarball", - "url": "https://github.com/nmattia/niv/archive/65a61b147f307d24bfd0a5cd56ce7d7b7cc61d2e.tar.gz", - "url_template": "https://github.com///archive/.tar.gz" - }, - "nixpkgs": { - "branch": "master", - "description": "Nix Packages collection", - "homepage": "", - "owner": "NixOS", - "repo": "nixpkgs", - "rev": "2b65a74aba274a06a673dfb6f28b96cbe0b032fb", - "sha256": "0f62z6q00dpxnf4c5ip8362kzzcmnlhx6fbia6dr97a21fzbc8aq", - "type": "tarball", - "url": "https://github.com/NixOS/nixpkgs/archive/2b65a74aba274a06a673dfb6f28b96cbe0b032fb.tar.gz", - "url_template": "https://github.com///archive/.tar.gz" - }, - "nixpkgs-mozilla": { - "branch": "master", - "description": "mozilla related nixpkgs (extends nixos/nixpkgs repo)", - "homepage": "", - "owner": "mozilla", - "repo": "nixpkgs-mozilla", - "rev": "0510159186dd2ef46e5464484fbdf119393afa58", - "sha256": "1c6r5ldkh71v6acsfhni7f9sxvi7xrqzshcwd8w0hl2rrqyzi58w", - "type": "tarball", - "url": "https://github.com/mozilla/nixpkgs-mozilla/archive/0510159186dd2ef46e5464484fbdf119393afa58.tar.gz", - "url_template": "https://github.com///archive/.tar.gz" - } -} diff --git a/doc/nix/sources.nix b/doc/nix/sources.nix deleted file mode 100644 index 1938409..0000000 --- a/doc/nix/sources.nix +++ /dev/null @@ -1,174 +0,0 @@ -# This file has been generated by Niv. - -let - - # - # The fetchers. fetch_ fetches specs of type . - # - - fetch_file = pkgs: name: spec: - let - name' = sanitizeName name + "-src"; - in - if spec.builtin or true then - builtins_fetchurl { inherit (spec) url sha256; name = name'; } - else - pkgs.fetchurl { inherit (spec) url sha256; name = name'; }; - - fetch_tarball = pkgs: name: spec: - let - name' = sanitizeName name + "-src"; - in - if spec.builtin or true then - builtins_fetchTarball { name = name'; inherit (spec) url sha256; } - else - pkgs.fetchzip { name = name'; inherit (spec) url sha256; }; - - fetch_git = name: spec: - let - ref = - if spec ? ref then spec.ref else - if spec ? branch then "refs/heads/${spec.branch}" else - if spec ? tag then "refs/tags/${spec.tag}" else - abort "In git source '${name}': Please specify `ref`, `tag` or `branch`!"; - in - builtins.fetchGit { url = spec.repo; inherit (spec) rev; inherit ref; }; - - fetch_local = spec: spec.path; - - fetch_builtin-tarball = name: throw - ''[${name}] The niv type "builtin-tarball" is deprecated. You should instead use `builtin = true`. - $ niv modify ${name} -a type=tarball -a builtin=true''; - - fetch_builtin-url = name: throw - ''[${name}] The niv type "builtin-url" will soon be deprecated. You should instead use `builtin = true`. - $ niv modify ${name} -a type=file -a builtin=true''; - - # - # Various helpers - # - - # https://github.com/NixOS/nixpkgs/pull/83241/files#diff-c6f540a4f3bfa4b0e8b6bafd4cd54e8bR695 - sanitizeName = name: - ( - concatMapStrings (s: if builtins.isList s then "-" else s) - ( - builtins.split "[^[:alnum:]+._?=-]+" - ((x: builtins.elemAt (builtins.match "\\.*(.*)" x) 0) name) - ) - ); - - # The set of packages used when specs are fetched using non-builtins. - mkPkgs = sources: system: - let - sourcesNixpkgs = - import (builtins_fetchTarball { inherit (sources.nixpkgs) url sha256; }) { inherit system; }; - hasNixpkgsPath = builtins.any (x: x.prefix == "nixpkgs") builtins.nixPath; - hasThisAsNixpkgsPath = == ./.; - in - if builtins.hasAttr "nixpkgs" sources - then sourcesNixpkgs - else if hasNixpkgsPath && ! hasThisAsNixpkgsPath then - import {} - else - abort - '' - Please specify either (through -I or NIX_PATH=nixpkgs=...) or - add a package called "nixpkgs" to your sources.json. - ''; - - # The actual fetching function. - fetch = pkgs: name: spec: - - if ! builtins.hasAttr "type" spec then - abort "ERROR: niv spec ${name} does not have a 'type' attribute" - else if spec.type == "file" then fetch_file pkgs name spec - else if spec.type == "tarball" then fetch_tarball pkgs name spec - else if spec.type == "git" then fetch_git name spec - else if spec.type == "local" then fetch_local spec - else if spec.type == "builtin-tarball" then fetch_builtin-tarball name - else if spec.type == "builtin-url" then fetch_builtin-url name - else - abort "ERROR: niv spec ${name} has unknown type ${builtins.toJSON spec.type}"; - - # If the environment variable NIV_OVERRIDE_${name} is set, then use - # the path directly as opposed to the fetched source. - replace = name: drv: - let - saneName = stringAsChars (c: if isNull (builtins.match "[a-zA-Z0-9]" c) then "_" else c) name; - ersatz = builtins.getEnv "NIV_OVERRIDE_${saneName}"; - in - if ersatz == "" then drv else - # this turns the string into an actual Nix path (for both absolute and - # relative paths) - if builtins.substring 0 1 ersatz == "/" then /. + ersatz else /. + builtins.getEnv "PWD" + "/${ersatz}"; - - # Ports of functions for older nix versions - - # a Nix version of mapAttrs if the built-in doesn't exist - mapAttrs = builtins.mapAttrs or ( - f: set: with builtins; - listToAttrs (map (attr: { name = attr; value = f attr set.${attr}; }) (attrNames set)) - ); - - # https://github.com/NixOS/nixpkgs/blob/0258808f5744ca980b9a1f24fe0b1e6f0fecee9c/lib/lists.nix#L295 - range = first: last: if first > last then [] else builtins.genList (n: first + n) (last - first + 1); - - # https://github.com/NixOS/nixpkgs/blob/0258808f5744ca980b9a1f24fe0b1e6f0fecee9c/lib/strings.nix#L257 - stringToCharacters = s: map (p: builtins.substring p 1 s) (range 0 (builtins.stringLength s - 1)); - - # https://github.com/NixOS/nixpkgs/blob/0258808f5744ca980b9a1f24fe0b1e6f0fecee9c/lib/strings.nix#L269 - stringAsChars = f: s: concatStrings (map f (stringToCharacters s)); - concatMapStrings = f: list: concatStrings (map f list); - concatStrings = builtins.concatStringsSep ""; - - # https://github.com/NixOS/nixpkgs/blob/8a9f58a375c401b96da862d969f66429def1d118/lib/attrsets.nix#L331 - optionalAttrs = cond: as: if cond then as else {}; - - # fetchTarball version that is compatible between all the versions of Nix - builtins_fetchTarball = { url, name ? null, sha256 }@attrs: - let - inherit (builtins) lessThan nixVersion fetchTarball; - in - if lessThan nixVersion "1.12" then - fetchTarball ({ inherit url; } // (optionalAttrs (!isNull name) { inherit name; })) - else - fetchTarball attrs; - - # fetchurl version that is compatible between all the versions of Nix - builtins_fetchurl = { url, name ? null, sha256 }@attrs: - let - inherit (builtins) lessThan nixVersion fetchurl; - in - if lessThan nixVersion "1.12" then - fetchurl ({ inherit url; } // (optionalAttrs (!isNull name) { inherit name; })) - else - fetchurl attrs; - - # Create the final "sources" from the config - mkSources = config: - mapAttrs ( - name: spec: - if builtins.hasAttr "outPath" spec - then abort - "The values in sources.json should not have an 'outPath' attribute" - else - spec // { outPath = replace name (fetch config.pkgs name spec); } - ) config.sources; - - # The "config" used by the fetchers - mkConfig = - { sourcesFile ? if builtins.pathExists ./sources.json then ./sources.json else null - , sources ? if isNull sourcesFile then {} else builtins.fromJSON (builtins.readFile sourcesFile) - , system ? builtins.currentSystem - , pkgs ? mkPkgs sources system - }: rec { - # The sources, i.e. the attribute set of spec name to spec - inherit sources; - - # The "pkgs" (evaluated nixpkgs) to use for e.g. non-builtin fetchers - inherit pkgs; - }; - -in -mkSources (mkConfig {}) // { __functor = _: settings: mkSources (mkConfig settings); } diff --git a/doc/presentation.tex b/doc/presentation.tex deleted file mode 100644 index 5cf4fd1..0000000 --- a/doc/presentation.tex +++ /dev/null @@ -1,570 +0,0 @@ -\documentclass{beamer} -%from https://www.overleaf.com/learn/latex/Beamer -%Information to be included in the title page: -\title{Efficient compilation of a functional Lisp based on Vau calculus} -\author{Nathan Braswell} -\institute{Georgia Tech} -\date{2022} - -\begin{document} - -\frame{\titlepage} - -\begin{frame} -\frametitle{Combiners and Vau Introduction} -Motivation and examples - \begin{enumerate} - \item<1-> Vau/Combiners unify and make first class functions, macros, and built-in forms in a single simple system - \item<2-> They are also much simpler conceptually than macro systems, which often end up quite complex (Racket has positive and negative evaluation levels, etc) - \item<3-> Downside: naively executing a language using combiners instead of macros is exceedingly slow - \begin{enumerate} - \item<4-> The code of the fexpr (analogus to a macro invocation) is re-executed at runtime, every time it is encountered - \item<5-> Additionally, because it is unclear what code will be evaluated as a parameter to a function call and what code must be passed unevaluated to the combiner, little optimization can be done. - \end{enumerate} - \end{enumerate} -\end{frame} - -\begin{frame} -\frametitle{Solution: Partial Eval} - \begin{enumerate} - \item<1-> Partially evaluate a purely functional version of this language in a nearly-single pass over the entire program - \item<2-> Environment chains consisting of both "real" environments with every contained symbol mapped to a value and "fake" environments that only have placeholder values. - \item<3-> Since the language is purely functional, we know that if a symbol evaluates to a value anywhere, it will always evaluate to that value at runtime, and we can perform inlining and continue partial evaluation. - \item<4-> If the resulting partially-evaluated program only contains static references to a subset of built in combiners and functions (combiners that evaluate their parameters exactly once), the program can be compiled just like it was a normal Scheme program - \end{enumerate} -\end{frame} - -\begin{frame}[fragile] -\frametitle{Example time!} - \begin{enumerate} - \item<1-> We will wrap angle brackets $<>$ around values that are not representable in the syntax of the language - i.e. $+$ is a symbol that will be looked up in an environment, $<+>$ is the addition function. - \item<2-> We will use square brackets $[]$ to indiciate array values, and we will use a single quote to indicate symbol values $'$, for instance $'+$ is the symbol $+$ as a value. - \item<3-> Additionally, we will use curly braces ($\{\}$) to indicate the environment (mapping symbols to values). Elipses will be used to omit unnecessary information. - \item<4-> Finally, we will not show the static environment nested in combiners, but know that each combiner carries with it the environment it was created with, which becomes the upper environment when its body is executing (the immediate environment being populated with the parameters). - \end{enumerate} -\end{frame} - -\begin{frame}[fragile] -\frametitle{A few more things..} - \begin{enumerate} - \item<1-> ; is the comment character for the language - \item<2-> We will sometimes make larger evaluation jumps for (some) brevity - \item<3-> wraplevel is how many times a combiner will evaluate its parameters before the body starts executing. 0 makes it work like a macro, 1 is like a function, etc - \item<4-> Wrap takes a combiner and returns the same combiner with an incremented wraplevel, unwrap does the reverese - \item<5-> Typing these examples by hand is too finicky, next time they'll be autogenerated with color by the prototype partial evaluator! - \end{enumerate} -\end{frame} - -\begin{frame}[fragile] -\frametitle{Smallest Example} -\footnotesize -\begin{verbatim} -{ ...root environment...} -(wrap (vau (n) (* n 2))) -\end{verbatim} -\end{frame} - -\begin{frame}[fragile] -\footnotesize -\begin{verbatim} -{...} -( (vau (n) (* n 2))) -\end{verbatim} -\end{frame} - -\begin{frame}[fragile] -\footnotesize -\begin{verbatim} -{...} -( ( (n) (* n 2))) -\end{verbatim} -\end{frame} - -\begin{frame}[fragile] -\footnotesize -\begin{verbatim} -{...} -( ) -\end{verbatim} -\end{frame} - -\begin{frame}[fragile] -\footnotesize -\begin{verbatim} -{...} - -\end{verbatim} -\end{frame} - -\begin{frame}[fragile] -\frametitle{Small Example} -\footnotesize -\begin{verbatim} -{ ...root environment...} -((wrap (vau (n) (* n 2))) (+ 2 2)) -\end{verbatim} -\end{frame} - -\begin{frame}[fragile] -\footnotesize -\begin{verbatim} -{...} -(( (vau (n) (* n 2))) (+ 2 2)) -\end{verbatim} -\end{frame} - -\begin{frame}[fragile] -\footnotesize -\begin{verbatim} -{...} -(( ( (n) (* n 2))) (+ 2 2)) -\end{verbatim} -\end{frame} - -\begin{frame}[fragile] -\footnotesize -\begin{verbatim} -{...} -(( ) (+ 2 2)) -\end{verbatim} -\end{frame} - -\begin{frame}[fragile] -\footnotesize -\begin{verbatim} -{...} -( (+ 2 2)) -\end{verbatim} -\end{frame} - -\begin{frame}[fragile] -\footnotesize -\begin{verbatim} -{...} -( (<+> 2 2)) -\end{verbatim} -\end{frame} - -\begin{frame}[fragile] -\footnotesize -\begin{verbatim} -{...} -( 4) -\end{verbatim} -\end{frame} - -\begin{frame}[fragile] -\footnotesize -\begin{verbatim} -{n: 4 | upper: {...root environment...}} -(* n 2) -\end{verbatim} -\end{frame} - -\begin{frame}[fragile] -\footnotesize -\begin{verbatim} -{n: 4 | upper: {...root environment...}} -(<*> n 2) -\end{verbatim} -\end{frame} - -\begin{frame}[fragile] -\footnotesize -\begin{verbatim} -{n: 4 | upper: {...root environment...}} -(<*> 4 2) -\end{verbatim} -\end{frame} - -\begin{frame}[fragile] -\footnotesize -\begin{verbatim} -8 -\end{verbatim} -\end{frame} - -\begin{frame}[fragile] -\frametitle{Small Vau-specific Example (implementing quote)} -\footnotesize -\begin{verbatim} -{ ...root environment...} -((vau (x) x) hello) -\end{verbatim} -\end{frame} - -\begin{frame}[fragile] -\footnotesize -\begin{verbatim} -{ ...root environment...} -(( (x) x) hello) -\end{verbatim} -\end{frame} - -\begin{frame}[fragile] -\footnotesize -\begin{verbatim} -{ ...root environment...} -( hello) -\end{verbatim} -\end{frame} - -\begin{frame}[fragile] -\footnotesize -\begin{verbatim} -{ x: 'hello | upper: {...root env....}} -x -\end{verbatim} -\end{frame} - -\begin{frame}[fragile] -\footnotesize -\begin{verbatim} -'hello -\end{verbatim} -\end{frame} - -\begin{frame}[fragile] -\frametitle{Larger Example} -\footnotesize -\begin{verbatim} -{...root environment...} -((wrap (vau (let1) - -(let1 lambda (vau se (p b1) (wrap (eval (array vau p b1) se))) - (lambda (n) (* n 2)) -) - -; impl of let1 -)) (vau de (s v b) (eval (array (array vau (array s) b) (eval v de)) - de))) -\end{verbatim} -\end{frame} - -\begin{frame}[fragile] -\footnotesize -\begin{verbatim} -{...} -(( (vau (let1) - -(let1 lambda (vau se (p b1) (wrap (eval (array vau p b1) se))) - (lambda (n) (* n 2)) -) - -; impl of let1 -)) (vau de (s v b) (eval (array (array vau (array s) b) (eval v de)) - de))) -\end{verbatim} -\end{frame} - -\begin{frame}[fragile] -\footnotesize -\begin{verbatim} -{...} -(( ( (let1) - -(let1 lambda (vau se (p b1) (wrap (eval (array vau p b1) se))) - (lambda (n) (* n 2)) -) - -; impl of let1 -)) (vau de (s v b) (eval (array (array vau (array s) b) (eval v de)) - de))) -\end{verbatim} -\end{frame} - -\begin{frame}[fragile] -\footnotesize -\begin{verbatim} -{...} -(( ) (vau de (s v b) (eval (array (array vau (array s) b) (eval v de)) - de))) -\end{verbatim} -\end{frame} - -\begin{frame}[fragile] -\footnotesize -\begin{verbatim} -{...} -( (vau de (s v b) (eval (array (array vau (array s) b) (eval v de)) - de))) -\end{verbatim} -\end{frame} - -\begin{frame}[fragile] -\footnotesize -\begin{verbatim} -{...} -( ) -\end{verbatim} -\end{frame} - -\begin{frame}[fragile] -\footnotesize -\begin{verbatim} -{let1: | upper: {...}} -(let1 lambda (vau se (p b1) (wrap (eval (array vau p b1) se))) - (lambda (n) (* n 2))) -\end{verbatim} -\end{frame} - -\begin{frame}[fragile] -\footnotesize -\begin{verbatim} -{let1: ... | upper: {...}} -( - lambda - (vau se (p b1) (wrap (eval (array vau p b1) se))) - (lambda (n) (* n 2)) -) -\end{verbatim} -\end{frame} - -\begin{frame}[fragile] -Note the de in the environment being the environment the combiner was called in, -as well as the current environment's upper being not the environment with let, but - the root environment (the static environment from the function's creation). -\footnotesize -\begin{verbatim} -{s: 'lambda, - v: ['vau 'se ['p 'b1] ['wrap ['eval ['array 'vau 'p 'b1] 'se]]], - b: ['lambda ['n] ['* 'n 2]] - de: {let1: ... | upper: {root...}} | upper: {root...}} -(eval (array (array vau (array s) b) (eval v de)) de) -\end{verbatim} -\end{frame} - -\begin{frame}[fragile] -\footnotesize -\begin{verbatim} -{s: 'lambda, - v: ['vau 'se ['p 'b1] ['wrap ['eval ['array 'vau 'p 'b1] 'se]]], - b: ['lambda ['n] ['* 'n 2]] - de: {let1: ... | upper: {root...}} | upper: {root...}} -( (array (array vau (array s) b) (eval v de)) de) -\end{verbatim} -\end{frame} - -\begin{frame}[fragile] -\footnotesize -\begin{verbatim} -{s: 'lambda, - v: ['vau 'se ['p 'b1] ['wrap ['eval ['array 'vau 'p 'b1] 'se]]], - b: ['lambda ['n] ['* 'n 2]] - de: {let1: ... | upper: {root...}} | upper: {root...}} -( ( (array vau (array s) b) (eval v de)) de) -\end{verbatim} -\end{frame} - -\begin{frame}[fragile] -\footnotesize -\begin{verbatim} -{s: 'lambda, - v: ['vau 'se ['p 'b1] ['wrap ['eval ['array 'vau 'p 'b1] 'se]]], - b: ['lambda ['n] ['* 'n 2]] - de: {let1: ... | upper: {root...}} | upper: {root...}} -( ( ( vau (array s) b) (eval v de)) de) -\end{verbatim} -\end{frame} - -\begin{frame}[fragile] -Ok, evaluating all parameters of the array at the same time to be (slightly) consise. - Note the replacement of de with the de environment, and that (eval v de) was fully executed to it's value. We'll see what the execution inside of eval looks like in a minute. -\footnotesize -\begin{verbatim} -{s: 'lambda, - v: ['vau 'se ['p 'b1] ['wrap ['eval ['array 'vau 'p 'b1] 'se]]], - b: ['lambda ['n] ['* 'n 2]] - de: {let1: ... | upper: {root...}} | upper: {root...}} -( ( ( ['lambda] ['lambda ['n] ['* 'n 2]]) - ) {let1: ... - | upper: {root...}}) -\end{verbatim} -\end{frame} - -\begin{frame}[fragile] -Again, let's take a few steps til we get the arrays as values -\footnotesize -\begin{verbatim} -( [ [ ['lambda] ['lambda ['n] ['* 'n 2]]] - ] {let1: ... - | upper: {root...}}) -\end{verbatim} -\end{frame} - -\begin{frame}[fragile] -Note that now that we are inside the eval call, our environment has swapped -to that specified in the call. -\footnotesize -\begin{verbatim} -{let1: ... | upper: {root...}} -( ( (lambda) (lambda (n) (* n 2))) - ) -\end{verbatim} -\end{frame} - -\begin{frame}[fragile] -\footnotesize -\begin{verbatim} -{let1: ... | upper: {root...}} -( - ) -\end{verbatim} -Ok, finally the let1 has reduced to a function application -\end{frame} - -\begin{frame}[fragile] -\footnotesize -\begin{verbatim} -{lambda: - | upper: {let1: ... }} -(lambda (n) (* n 2)) -\end{verbatim} -\end{frame} - -\begin{frame}[fragile] -\footnotesize -\begin{verbatim} -{lambda: ...} -( - (n) (* n 2)) -\end{verbatim} -\end{frame} - -\begin{frame}[fragile] -\footnotesize -\begin{verbatim} -{p: ['n], - b1: ['* 'n 2], - se:{lambda: ...} | upper: {let1: ...}} -(wrap (eval (array vau p b1) se)) -\end{verbatim} -\end{frame} - -\begin{frame}[fragile] -\footnotesize -\begin{verbatim} -{p: ['n], - b1: ['* 'n 2], - se:{lambda: ...} | upper: {let1: ...}} -( (eval (array vau p b1) se)) -\end{verbatim} -\end{frame} - -\begin{frame}[fragile] -We'll evaluate a few parameters at a time again -\footnotesize -\begin{verbatim} -{p: ['n], - b1: ['* 'n 2], - se:{lambda: ...} | upper: {let1: ...}} -( ( ( ['n] ['* 'n 2]) {lambda: ...})) -\end{verbatim} -\end{frame} - -\begin{frame}[fragile] -\footnotesize -\begin{verbatim} -{p: ['n], - b1: ['* 'n 2], - se:{lambda: ...} | upper: {let1: ...}} -( ( [ ['n] ['* 'n 2]] {lambda: ...})) -\end{verbatim} -\end{frame} - -\begin{frame}[fragile] -\footnotesize -\begin{verbatim} -{p: ['n], - b1: ['* 'n 2], - se:{lambda: ...} | upper: {let1: ...}} -( ) -\end{verbatim} -\end{frame} - -\begin{frame}[fragile] -\footnotesize -\begin{verbatim} - -\end{verbatim} -\end{frame} - -\begin{frame} -\frametitle{Conclusion: slow} - \begin{enumerate} - \item<1-> Look at all of the steps it took to simply get a function value that multiplies by 2! - \item<2-> This would make our program much slower if this happened at runtime, for every function in the program. - \item<3-> What's the solution? Partial Evaluation! - \end{enumerate} -\end{frame} - -\begin{frame} -\frametitle{Partial Eval: How it works} - \begin{enumerate} - \item<1-> Evaluate as much as possible ahead of time, at compile time. - \item<2-> If some call sites are indeterminate, they can still be compiled, but there will have to be a runtime check inserted that splits evaluation based on if the combiner evaluates its parameters or not, and eval and all builtins will have to be compiled into the resulting executable. - \item<3-> When compiling in the wraplevel=1 side of conditional, further partial evaluate the parameter value - \end{enumerate} -\end{frame} - -\begin{frame}[fragile] -Partial evaluation could have done all the work from that last big example at compile time, leaving only the final value to be compiled: -\footnotesize -\begin{verbatim} - -\end{verbatim} - Additionally, if this was a more complex function that used other functions, those functions would also generally be fully partially evaluated at compile time. - It's the full power of Vau/Combiners/Fexprs with the expected runtime performance of Scheme! -\end{frame} - -\begin{frame} -\frametitle{Partial Eval: Current Status} - \begin{enumerate} - \item<1-> No longer *super* slow - \item<2-> Fixed most BigO algo problems (any naive traversal is exponential) - \item<3-> Otherwise, the implementation is slow (pure function, Chicken Scheme not built for it, mostly un-profiled and optimized, etc) - \item<4-> Compiles wraplevel=0 combs to a assert(false), but simple to implement. - \item<5-> Working through bugs - right now figuring out why some things don't partially evaluate as far as they should - \end{enumerate} -\end{frame} - -\begin{frame} -\frametitle{Partial Eval: Future: Type System Hints} -Allow type systems to be built using Vaus, like the type-systems-as-macros paper (\url{https://www.ccs.neu.edu/home/stchang/pubs/ckg-popl2017.pdf}). -This type system could pass down type hints to the partial evaluator, enabling: - \begin{enumerate} - \item<2-> Compiletime: Drop optimizing compiled version if wraplevel=0 - \item<3-> Compiletime: Drop emitting constant code for if wraplevel=1 - \item<4-> Runtime: Eliminate branch on wrap level - \item<5-> Runtime: Eliminate other typechecks for builtin functions - \end{enumerate} -\end{frame} - -\end{document} diff --git a/doc/psudocode.txt b/doc/psudocode.txt deleted file mode 100644 index 864493b..0000000 --- a/doc/psudocode.txt +++ /dev/null @@ -1,306 +0,0 @@ - -Key Contributions to look out for that make this work in practical time: - 1. First class environments that: - a. Have IDs - b. Can either be "real", in which case it maps symbols to values, - or "fake", in which case it maps symbols to themselves, but with the env ID as it's for-progress - c. Chain up to an upper environment that may be fake or real - 2. AST nodes that maintain on-node: - a. The IDs of environments that, if "real", can be used to make progress in this subtree - b. The hashes of infinite recursive calls that were detected and stopped - if this hash isn't in the current call chain, this subtree can make progress - c. Extra IDs of environments that are "real" but have "fake" environments in their chain - this is used to make return value checking fast O(1 or log n, depending) - 3. Combiners, both user-defined and built in (including that maintain a "wrap level" that: - a. Is a property of this function value, *not* the function itself - * meaning that if wrap_level > 1, you can evaluate each parameter and decrement wrap_level, even if you can't execute the call - 4. The return value of a combiner is checked for: - a. If it is a value, in which case it is good to be returned if it doesn't contain a reference to the envID of the function it is being returned from - b. If it is (veval something env) where env doesn't contain a reference to the envID of the function it is being returned from - c. If it is a call to a function (func params...) and func doesn't take in a dynamic environment and params... are all good to be returned - This makes it so that combiner calls can return partially-evaluated code - any macro-like combiner would calculate the new code and return - (eval dynamic_env), which would do what partial evaluation it could and either become a value or a call like case "b" above. - Case "b" allows this code essentially "tagged" with the environment it should be evaluated in to be returned out of "macro-like" combiners, - and this dovetails with the next point - 5. The (veval something env) form essentially "tags" a piece of code with the environment it should be evaluated in. At each stage where - it is possible, the system checks for redundent constructions like these, where the env in (veval something env) is the currently active env. - In this case, it unwraps it to just "something" and continues on - this completes the second half of the macro-like combiner evaluation where - after being returned to the calling function the code is essentially spliced in. - 6. The compiler can emit if/else branches on the wrap_level of combiners and in each branch further compile/partial eval if appropriate, allowing - dynamic calls to either functions or combiners with the overhead of a single branch - -Note that points 4&5 make it so that any macro written as a combiner in "macro-style" will be expanded just like a macro would and cause no runtime overhead! -Additionally, point 6 makes it so that functions (wrap level 1 combiners) and non-parameter-evaluating (wrap level 0) combiners can be dynamically passed around and called with very minimal overhead. -Combine them together and you get a simpler but more flexiable semantics than macro based (pure functional) languages with little-to-no overhead. - -Additional tricky spots to look out for: - 1. If you don't do the needed-for-progress tracking, you have exponential runtime - 2. If you aren't careful about storing analysis information on the AST node itself or memoize, a naive tree traversal of the DAG has exponential runtime - 3. Infinite recursion can hide in sneaky places, including the interply between the partial evaluator and the compiler, and careful use of multiple recursion blockers / memoization is needed to prevent all cases - 4. The invarients needed to prevent mis-evaluation are non-trivial to get right. Our invarients: - a. All calls to user-combiners have the parameters as total values, thus not moving something that needs a particular environment underneath a different environment - b. All return values from functions must not depend on the function's environment (there are a couple of interesting cases here, see combiner_return_ok(func_result, env_id)) - c. All array values are made up of total values - d. Some primitive combiners don't obey "a", but they must be written with extreme care, and often partially evaluate only some of their parameters and have to keep track of which. - - - -Everything operates on AST nodes, an ADT: - * val - integers, strings, booleans - * marked_array - * marked_symbol - * comb - * prim_comb - * marked_env - -Each AST node contains a hash representing it&it's subtree. - -fun needed_for_progress(ast_node) -> (progress_IDs, rec_stopping_hashes, extra_IDs): - returns - - environment IDs (stored in each AST node for it and it's children) - that must have real values if the partial evaluation of the subtree rooted at - this node is going to make progress partial evaluating. - - progress_IDs is either true (meaning it will make progress no matter what), an - intset of env IDs (the ones that will cause it to make progress), or an empty - set, meaning it can't make forward progress no matter what - - hashes that if you're not inside the evaluation of, it could make progress - - extra IDs for envs it contains that don't count as forward progress IDs because the - env does have values, but envs in it's parent chain doesn't have values. - -The calculation for needed_for_progress is straightforward-ish, with some tricky bits at comb and array. - -Under these definitions, we call an AST subtree a "total val" if it is either a val or it's needed-for-progress IDs is nil. - -fun mark(x, eval_pos): - x is env -> error - x is combiner -> error - x is symbol -> if x == true than MarkedVal(true) - else if x == false than MarkedVal(false) - else MarkedSymbol(x, needed_IDs=if eval_pos true else nil) - x is array -> - MarkedArray(is_val=!eval_pos, attempted=false, resume_hashes=nil, - values = [mark(x[0], eval_pos)] + [mark(xi, false) for xi in x[1:]]) - true -> MarkedVal(x) - -fun strip(x) -> value: - if X is an AST node representing a value, it returns the value. - May strip recursively in the case of an array value, etc. - Errors on env, comb (but not prim_comb!) non value symbols or arrays - -fun try_unval(x) -> Result: - //Removes one level of "value-ness". - x is Array -> if !x.array_is_val Error() - else Ok(MarkedArray(is_value=false, - values = [try_unval(x.values[0])] + x.values[1:])) - x is Symbol -> if !x.symbol_is_val Error() - else Ok(MarkedSymbol(symbol=x.symbol, is_value=false)) - true -> Ok(x) - -fun check_for_env_id_in_result(env_id, x): - return env_id in - if either progress_IDs or extra_IDs is true, then we have a fallback, but - that doesn't get called even on large testcases so it's either rare or impossible. - Fallback is slow though, whereas this is just a check for set membership - -// We only allow returning a value out of a combiner if the return value -// doesn't reference the environment of the combiner -fun combiner_return_ok(func_result, env_id): - func_result isn't later -> !check_for_env_id_in_result(env_id, func_result) - // special cases now - (veval body {env}) => (combiner_return_ok {env}) - // The reason we don't have to check body is that this form is only creatable in ways that body was origionally a value and only need {env} - // Either it's created by eval, in which case it's fine, or it's created by something like (eval (array veval x de) de2) and the array has checked it, - // or it's created via literal vau invocation, in which case the body is a value. - (func ...params) => func doesn't take dynamic env && all params are combiner_return_ok - otherwise -> false - -// We may end up in situations where the value/code we care about is wrapped up in -// a redundent call to veval, namely after sucessfully returning based on combiner_return_ok above. -// This call may prevent other optimizations though, so we should unwrap the redundent call if possible, -// and if it causes a change we should re-partially-evaluate to make further progress if we can -fun drop_redundent_veval(x, dynamic_env, env_stack, memostuff): - (veval node env) if env.id == dynamic_env.id -> drop_redundent_veval(node, dynamic_env, env_stack, memostuff) - (comb params...) if comb.wrap_level != -1 -> map drop_redundent_veval over params and if any change: partial_eval( (comb new_params...), dynamic_env, env_stack, memostuff) - else: x - else -> x - -fun make_tmp_inner_env(params, de?, ue, env_id): - ... - - -fun partial_eval_helper(x, only_head, env, env_stack, memostuff, force): - needed, hashes, _extra = needed_for_partial_eval(x) - if force || one of hashes is not in memostuff || needed == true || set_intersection(needed, env_stack.set_of_ids_that_are_vals) != empty_set: - x is MarkedVal -> x - x is MarkedEnv -> find(x.env_id == it.env_id, env_stack) ?: x - x is MarkedComb -> if !env.is_real && !x.se.is_real // both aren't real, re-evaluation of closure creation site - || env.is_real && !x.se.is_real // new env real, but se isn't - the creation of the closure! - then let inner_env = make_tmp_inner_env(x.params, x.de?, env, x.env_id) - in MarkedComb(se=env, body=partial_eval_helper(body, false, inner_env, , memostuff, false)) - x is MarkedPrimComb -> x - x is MarkedSymbol -> if x.is_val then x - else env_lookup_helper(x, env) - x is MarkedArray -> if x.is_val then x - else let - comb = partial_eval_helper(x.values[0], only_head=true, env, env_stack, memostuff, false) - params = x.values[1:] - if later_head?(comb) return MarkedArray(values=[comb]+params) - if comb.needed_for_progress == true: - comb = partial_eval_helper(comb, only_head=false, ...) - - // If not -1, we always partial eval, if >0 we also unval/partial eval to do one full round of eval - wrap_level = comb.wrap_level - while wrap_level >= 0: - if wrap_level >= 1: - params = map(unval, map(\x. partial_eval_helper(x, ...), params)) - params = map(\x. partial_eval_helper(x, ...), params) - wrap_level -= 1 - if : - return MarkedArray(values=[comb.with_wrap_level(wrap_level)] + ) - - if comb is MarkedPrimComb: - result = comb.impl(params) - if result == 'LATER: - return MarkedArray(values=[comb.with_wrap_level(wrap_level)] + params) - else: - return result - - if comb.is_varadic: - params = params[:comb.params.len-1] + [ params[comb.params.len-1:] ] - - inner_env = MarkedEnv(id=comb.env_id, possible_de_symbol=comb.de?, possible_de=env, symbols=comb.params, values=params, upper=comb.se) - - rec_stop_hash = combine_hash(inner_env.hash, comb.body.hash) - if rec_stop_hash in memostuff: - return MarkedArray(values=[comb] + params, transient_needed_env_id=true, rec_stopping_hash=rec_stop_hash) - - memostuff.add(rec_stop_hash) - result = partial_eval_helper(body, false, inner_env, , memostuff, false) - memostuff.remove(rec_stop_hash) - - if !combiner_return_ok(result, comb.env_id): - transiently_needed = if comb.de? != nil then env.id else nil - return MarkedArray(values=[comb] + params, transient_needed_env_id=transiently_needed, rec_stopping_hash=rec_stop_hash) - - return drop_redundent_veval(result, env, env_stack, memostuff) - -And then we define a root_env with PrimComb versions of all of the standard functions. -The ones that are most interesting and interact the most with partial evaluation are - vau eval cond -The other key is that array only takes in values, that is an array value never hides something that isn't a total value and needs more partial-evaluation - (this makes a lot of things simpler in other places since we can treat array values as values no matter what and know things aren't hiding in sneaky places) - -fun needs_params_prim(...): - ... -fun give_up_params_prim(...): - ... - -fun veval_inner(only_head, de, env_stack, memostuff, params): - body = params[0] - implicent_env = len(params) != 2 - eval_env = if implicit_env { de } else { partial_eval_helper(params[1], only_head, de, env_stack, memostuff, false) } - evaled_body = partial_eval_helper(body, only_head, eval_env, env_stack, memostuff, false) - if implicit_env or combiner_return_ok(evaled_body, eval_env.idx): - return drop_redundent_veval(evaled_body, de, env_stack, memostuff) - else: - return drop_redundent_veval(MarkedArray(values=[MarkedPrimComb('veval, wrap_level=-1, val_head_ok=true, handler=veval_inner), evaled_body, eval_env], de, env_stack, memostuff) - -root_env = { - eval: MarkedPrimComb('eval, wrap_level=1, val_head_ok=true, handler=lambda(only_head, de, env_stack, memostuff, params): - let - body = params[0] - implicit_env = len(params) != 2 - return veval_inner(only_head, de, env_stack, memostuff, if implicit_env { [try_unval(body)] } else { [try_unval(body), params[1]] }) - ) - vapply: MarkedPrimComb('vapply, wrap_level=1, val_head_ok=true, handler=lambda(only_head, de, env_stack, memostuff, [func params env]): - return veval_inner(only_head, de, env_stack, memostuff, [MarkedArray(values=[func]+params), env) - ) - lapply: MarkedPrimComb('lapply, wrap_level=1, val_head_ok=true, handler=lambda(only_head, de, env_stack, memostuff, [func params env]): - return veval_inner(only_head, de, env_stack, memostuff, [MarkedArray(values=[func.offset_wrap_level(-1)]+params), env) - ) - vau: MarkedPrimComb('vau, wrap_level=0, val_head_ok=true, handler=lambda(only_head, de, env_stack, memostuff, params): - let - de? = if len(params) == 3 { params[0].symbol_value } else { nil } - params = map(lambda(x): s.symbol_value, if de? { params[1] } else { params[0] }) - varadic = '& in params - params.remove('&) - implicit_env = len(params) != 2 - body = try_unval(if de? { params[2] } else { params[1] }) - env_id = - if !only_head: - inner_env = make_tmp_inner_env(params, de?, upper=de, id=env_id) - body = partial_eval_helper(body, false, inner_env, , memostuff, false) - return MarkedComb(wrap_level=0, id=new_id, de?=de?, static_env=de, variadic=varadic, params=params, body=body) - ) - wrap: ...... - unwrap: ...... - cond: ... - ...Oddly tricky - is wrap_level 0, but... - ... 1. unvals & partially evaluates starting from the first condition - ... 2. if this condition is true, return the unvald & partially evaluated corresponding arm - ... 3. if this condition is false, drop the arm and return to 1 - ... 4. In this case, we have an unknown between true & false - ... 5. check to see if combine_hash(x.hash, env.hash) is in memostuff (prevent infinite recursion blocked on a cond guard!) - ... 6. if the hash was in memostuff, return MarkedArray(later_hash=the_hash, - ... values=[MarkedPrimComb('vcond,wraplevel=-1,...)] + map(unval, )) - ... 7. else new_preds_arms = map(partial_eval..., map(unval, )) - ... - ... 9. return MarkedArray(values=[MarkedPrimComb('vcond,wraplevel=-1,...)] + new_preds) - ... - ...The vcond is like cond but doesn't do any unvaling (as it's already been done) (and wrap_level is set to -1 so the function call machinery doesn't touch the params either) - ... - symbol?: needs_params_prim(symbol?) - int?: needs_params_prim(int?) - string?: needs_params_prim(string?) - combiner?: ... - env?: ... - nil?: needs_params_prim(nil?) - bool?: needs_params_prim(bool?) - str-to-symbol: needs_params_prim(str-to-symbol) - get-text: needs_params_prim(get-text) - array?: ... - array: ... - len: ... - idx: ... - slice: ... - concat: ... - +: needs_params_prim(+) - -: needs_params_prim(-) - *: needs_params_prim(*) - /: needs_params_prim(/) - %: needs_params_prim(%) - band: needs_params_prim(band) - bor: needs_params_prim(bor) - bnot: needs_params_prim(bnot) - bxor: needs_params_prim(bxor) - <<: needs_params_prim(<<) - >>: needs_params_prim(>>) - =: needs_params_prim(=) - !=: needs_params_prim(!=) - <: needs_params_prim(<) - <=: needs_params_prim(<=) - >: needs_params_prim(>) - >=: needs_params_prim(>=) - str: needs_params_prim(true_str) - log: give_up_params_prim(log) - error: give_up_params_prim(error) - read-string: needs_params_prim(read-string) - empty_env: MarkedEnv() -} - -fun compile(...): - ... - ... tagged words, etc - ... eval - ... vau / vau helper closure - ... - Note that when it's compiling a call, it compiles an if/else chain on the wrap level of the combiner being called. - in the 0 branch, it emits the parameters as constant data - in the 1 branch, it unval's and partial evals all of the parameters before compiling them. - - note that this must be robust to partial-eval errors, as this branch might not ever happen at runtime and be nonsense code! - - if the partial evaluation errors, it emits a value that will cause an error at runtime into the compiled code - in the > 1 branch, it errors - ... - ... - Must be careful about infiniate recursion, including tricky cases that infinitly ping back and forth between - partial eval and compile even though both have individual internal recursion checks - ... diff --git a/doc/shell.nix b/doc/shell.nix deleted file mode 100644 index d5b0c69..0000000 --- a/doc/shell.nix +++ /dev/null @@ -1,11 +0,0 @@ -let - sources = import ./nix/sources.nix; - pkgs = import sources.nixpkgs { }; -in -pkgs.mkShell { - buildInputs = with pkgs; [ - texlive.combined.scheme-full - evince - ]; -} - diff --git a/doc/writeup.tex b/doc/writeup.tex deleted file mode 100644 index 773fc96..0000000 --- a/doc/writeup.tex +++ /dev/null @@ -1,263 +0,0 @@ -%% -%% This is file `sample-acmsmall.tex', -%% generated with the docstrip utility. -%% -%% The original source files were: -%% -%% samples.dtx (with options: `acmsmall') -%% -%% IMPORTANT NOTICE: -%% -%% For the copyright see the source file. -%% -%% Any modified versions of this file must be renamed -%% with new filenames distinct from sample-acmsmall.tex. -%% -%% For distribution of the original source see the terms -%% for copying and modification in the file samples.dtx. -%% -%% This generated file may be distributed as long as the -%% original source files, as listed above, are part of the -%% same distribution. (The sources need not necessarily be -%% in the same archive or directory.) -%% -%% -%% Commands for TeXCount -%TC:macro \cite [option:text,text] -%TC:macro \citep [option:text,text] -%TC:macro \citet [option:text,text] -%TC:envir table 0 1 -%TC:envir table* 0 1 -%TC:envir tabular [ignore] word -%TC:envir displaymath 0 word -%TC:envir math 0 word -%TC:envir comment 0 0 -%% -%% -%% The first command in your LaTeX source must be the \documentclass command. -\documentclass[acmsmall]{acmart} - -%% -%% \BibTeX command to typeset BibTeX logo in the docs -\AtBeginDocument{% - \providecommand\BibTeX{{% - \normalfont B\kern-0.5em{\scshape i\kern-0.25em b}\kern-0.8em\TeX}}} - -%% Rights management information. This information is sent to you -%% when you complete the rights form. These commands have SAMPLE -%% values in them; it is your responsibility as an author to replace -%% the commands and values with those provided to you when you -%% complete the rights form. -\setcopyright{acmcopyright} -\copyrightyear{2022} -\acmYear{2022} -\acmDOI{10.1145/1122445.1122456} - - -%% -%% These commands are for a JOURNAL article. -\acmJournal{JACM} -\acmVolume{37} -\acmNumber{4} -\acmArticle{111} -\acmMonth{8} - -%% -%% Submission ID. -%% Use this when submitting an article to a sponsored event. You'll -%% receive a unique submission ID from the organizers -%% of the event, and this ID should be used as the parameter to this command. -\acmSubmissionID{123-A56-BU3} - -%% -%% The majority of ACM publications use numbered citations and -%% references. The command \citestyle{authoryear} switches to the -%% "author year" style. -%% -%% If you are preparing content for an event -%% sponsored by ACM SIGGRAPH, you must use the "author year" style of -%% citations and references. -%% Uncommenting -%% the next command will enable that style. -%%\citestyle{acmauthoryear} - -%% -%% end of the preamble, start of the body of the document source. -\begin{document} - -%% -%% The "title" command has an optional parameter, -%% allowing the author to define a "short title" to be used in page headers. -\title{Efficient compilation of a functional Lisp based on Vau calculus} - -%% -%% The "author" command and its associated commands are used to define -%% the authors and their affiliations. -%% Of note is the shared affiliation of the first two authors, and the -%% "authornote" and "authornotemark" commands -%% used to denote shared contribution to the research. -\author{Nathan Braswell} -\email{nathan.braswell@gtri.@gatech.edu} -%%\orcid{1234-5678-9012} -%%\author{G.K.M. Tobin} -%%\authornotemark[1] -%%\email{webmaster@marysville-ohio.com} -\affiliation{% - \institution{Georgia Tech} - %%\streetaddress{P.O. Box 1212} - \city{Atlanta} - \state{GA} - \country{USA} - %%\postcode{43017-6221} -} - -%% -%% By default, the full list of authors will be used in the page -%% headers. Often, this list is too long, and will overlap -%% other information printed in the page headers. This command allows -%% the author to define a more concise list -%% of authors' names for this purpose. -%%\renewcommand{\shortauthors}{Trovato and Tobin, et al.} - -%% -%% The abstract is a short summary of the work to be presented in the -%% article. -\begin{abstract} - Vau and Fexprs, as formulated by John Shutt \cite{shutt2010fexprs}, provide a first class and more powerful alternative to - macros. On the other hand, naively executing a language using Vau and Fexprs instead of macros is exceedingly slow, - as the code of the fexpr (analogus to a macro invocation) is re-executed at runtime, every time it is encountered. - Additionally, because it is unclear what code will be evaluated as a parameter to a function call and what code - must be passed unevaluated to a combiner, little optimization can be done. We address this problem with, to our knowledge, - the first partial evaluation system that can completely optimize away fexprs that are used and written in the style of macros, - as well as some other more naturally written combiners. -\end{abstract} - -%% -%% The code below is generated by the tool at http://dl.acm.org/ccs.cfm. -%% Please copy and paste the code instead of the example below. -%% -%%\begin{CCSXML} -%% -%% -%% 10010520.10010553.10010562 -%% Computer systems organization~Embedded systems -%% 500 -%% -%% -%% 10010520.10010575.10010755 -%% Computer systems organization~Redundancy -%% 300 -%% -%% -%% 10010520.10010553.10010554 -%% Computer systems organization~Robotics -%% 100 -%% -%% -%% 10003033.10003083.10003095 -%% Networks~Network reliability -%% 100 -%% -%% -%%\end{CCSXML} - -%%\ccsdesc[500]{Computer systems organization~Embedded systems} -%%\ccsdesc[300]{Computer systems organization~Redundancy} -%%\ccsdesc{Computer systems organization~Robotics} -%%\ccsdesc[100]{Networks~Network reliability} - -%% -%% Keywords. The author(s) should pick words that accurately describe -%% the work being presented. Separate the keywords with commas. -\keywords{partial evaluation, vau, fexprs, WebAssembly} - - -%% -%% This command processes the author and affiliation and title -%% information and builds the first part of the formatted document. -\maketitle - -\section{Introduction and Motivation} - - Lisps generally have two different abstraction methods, functions and macros. Functions operate at runtime and always - evaluate their parameters, while macros operate at compiletime and do not evaluate their parameters. This generally - splits the language to a degree, and macros are not able to be used at runtime, though generally functions are - able to be used in macros, with various restrictions. The macro systems generally attempt to be hygenic, either preventing - or making it difficult to manipulate the environment of the code that the macro invocation will expand to. This is often - needed, however, and various escape hatches can be implemented. - - Creating a powerful, safe, and easy to use macro system is quite difficult, and the resulting systems are often quite complex, - generally more complex than the base language in which the reside. Macros are also not first class, and cannot be passed - around as values and do not exist at all at runtime. - - Vau and Fexprs, as formulated by John Shutt \cite{shutt2010fexprs}, (at \url{https://web.wpi.edu/Pubs/ETD/Available/etd-090110-124904/unrestricted/jshutt.pdf}), - provide a first class and more powerful alternative to macros, unifying functions, macros, and built-in language forms - into a single concept called a combiner. A combiner may evaluate its arguments 0 or more times, - and recieves the calling environment as an additional parameter. There is also an eval function which takes in an expression to evaluate - and an environment in which to do the evaluation. Note that functions, macros, and even built-in language constructs like if, cond, let can be implemented - as either user-defined or built-in combiners, making both macros and what were previously Lisp special forms first class! They can be named, - passed to higher-order combiners, put into datastructures, etc. - - On the other hand, naively executing a language using combiners instead of macros is exceedingly slow, - as the code of the fexpr (analogus to a macro invocation) is re-executed at runtime, every time it is encountered. - Additionally, because it is unclear what code will be evaluated as a parameter to a function call and what code - must be passed unevaluated to the combiner, little optimization can be done. We address this problem with, to our knowledge, - the first partial evaluation system that can completely optimize away fexprs that are used and written in the style of macros, - as well as some other more naturally written combiners. Our language is more restricted than Shutt's Kernel language, being - purely functional and allowing no mutation, making the tracking of environments and optimization of access tractable. - - All code available at \url{https://github.com/limvot/kraken} - -\section{Prior Work} -\begin{itemize} - \item{} Axis of Eval list of 22 attempted implmentations - \url{https://axisofeval.blogspot.com/2011/09/kernel-underground.html} \\ - None doing partial evaluation, to my knowledge. I belive all abandond or linkrotted with the seeming exception of \url{https://github.com/rocketnia/fexpress}, - which is taking a very different approach (Lisp-2, explicit apply form, etc) in Racket. - \item{} Lambda The Ultimate small discussion of partial eval for Vau/Kernel - \url{http://lambda-the-ultimate.org/node/4346} - \item{} Implementing a Vau-based Language With Multiple Evaluation Strategies - \cite{kearsleyimplementing} \\ - Talks about how partial evaluation could make efficient, doesn't do it. - \item{} Google Groups email thread by Andres Navarro - \url{https://groups.google.com/g/klisp/c/Dva-Le8Hr-g/m/pyl1Ufu-vksJ} \\ - Andres Navarro talks about his experimental fklisp which is a "very simple functional dialect of Kernel" with no mutation or first class continuations. - It doesn't compile anything, but prints out the partially evalauted expression. Was a work in progress, ran into performance problems, seems abandond. -\end{itemize} - -\subsection{Issues} - As described in the introduction, the main issue with basing a langauge off of Vau and combiners is slowness. - This comes from two main problems: one, the combiners taking the place of macros are re-executed every time - they are encountered instead of being expanded into intermediate code like in a macro system, and two, because - the compiler in general cannot tell if the combiner being called takes in its parameters by value or not, it cannot - do practically any optimization. - -\section{Solution} - We partially evaluate a purely function version of this language in a nearly-single pass over the entire program. - We allow environment chains consisting of both "real" environments with every contained symbol mapped to a value and "fake" environments - that only have placeholder values. Since the language is purely functional, we know that if a symbol evaluates to a value anywhere, it - will always evaluate to that value at runtime. With this, we can notice most calls to combiners that don't evaluate their parameters - (since if we can resolve the combiner to a value, we know that will always be the combiner called at that location) and we can perform - inlining and continue partial evaluation. - - If the resulting partially-evaluated program only contains static references to a subset of built in combiners and function (combiners that - evaluate their parameters exactly once), the program can be compiled just like it was a normal Scheme program. - If some call sites are indeterminate, they can still be compiled, but there will have to be a runtime check inserted that splits - evaluation based on if the combiner evaluates its parameters or not, and eval and all builtins will have to be compiled into the resulting executable. - - A Vau/combiner based language allows most of the language to be built up in the language itself, as combiners. For instance, even lambda and let - are derived instead of primitive. See below, where we define both let1 (a simple version of let binding only one variable) and lambda. -\begin{verbatim} -((wrap (vau (let1) - -(let1 lambda (vau se (p b1) (wrap (eval (array vau p b1) se))) - (lambda (n) (* n 2)) -) - -; impl of let1 -)) (vau de (s v b) (eval (array (array vau (array s) b) (eval v de)) de))) -\end{verbatim} - -\bibliographystyle{ACM-Reference-Format} -\bibliography{cited-paper} - -\end{document} -\endinput -%% -%% End of file `sample-acmsmall.tex'. diff --git a/fib_test/builtin_fib.kp b/fib_test/builtin_fib.kp deleted file mode 100644 index ec67f07..0000000 --- a/fib_test/builtin_fib.kp +++ /dev/null @@ -1,36 +0,0 @@ - -((wrap (vau root_env (quote) -((wrap (vau (let1) -(let1 lambda (vau se (p b1) (wrap (eval (array vau p b1) se))) -(let1 current-env (vau de () de) -(let1 cons (lambda (h t) (concat (array h) t)) -(let1 Y (lambda (f3) - ((lambda (x1) (x1 x1)) - (lambda (x2) (f3 (wrap (vau app_env (& y) (lapply (x2 x2) y app_env))))))) -(let1 vY (lambda (f) - ((lambda (x3) (x3 x3)) - (lambda (x4) (f (vau de1 (& y) (vapply (x4 x4) y de1)))))) -(let1 let (vY (lambda (recurse) (vau de2 (vs b) (cond (= (len vs) 0) (eval b de2) - true (vapply let1 (array (idx vs 0) (idx vs 1) (array recurse (slice vs 2 -1) b)) de2))))) - (let ( - lcompose (lambda (g f) (lambda (& args) (lapply g (array (lapply f args))))) - rec-lambda (vau se (n p b) (eval (array Y (array lambda (array n) (array lambda p b))) se)) - - fib (rec-lambda fib (n) (cond (= 0 n) 1 - (= 1 n) 1 - true (+ (fib (- n 1)) (fib (- n 2))))) - - monad (array 'write 1 "enter number to fact: " (vau (written code) - (array 'read 0 60 (vau (data code) - (array 'exit (builtin_fib (read-string data))) - )) - - )) - - ) monad) -; end of all lets -)))))) -; impl of let1 -)) (vau de (s v b) (eval (array (array wrap (array vau (array s) b)) v) de))) -; impl of quote -)) (vau (x5) x5)) diff --git a/fib_test/clojure_fib/.gitignore b/fib_test/clojure_fib/.gitignore deleted file mode 100644 index d956ab0..0000000 --- a/fib_test/clojure_fib/.gitignore +++ /dev/null @@ -1,13 +0,0 @@ -/target -/classes -/checkouts -profiles.clj -pom.xml -pom.xml.asc -*.jar -*.class -/.lein-* -/.nrepl-port -/.prepl-port -.hgignore -.hg/ diff --git a/fib_test/clojure_fib/LICENSE b/fib_test/clojure_fib/LICENSE deleted file mode 100644 index 2315126..0000000 --- a/fib_test/clojure_fib/LICENSE +++ /dev/null @@ -1,280 +0,0 @@ -Eclipse Public License - v 2.0 - - THE ACCOMPANYING PROGRAM IS PROVIDED UNDER THE TERMS OF THIS ECLIPSE - PUBLIC LICENSE ("AGREEMENT"). ANY USE, REPRODUCTION OR DISTRIBUTION - OF THE PROGRAM CONSTITUTES RECIPIENT'S ACCEPTANCE OF THIS AGREEMENT. - -1. DEFINITIONS - -"Contribution" means: - - a) in the case of the initial Contributor, the initial content - Distributed under this Agreement, and - - b) in the case of each subsequent Contributor: - i) changes to the Program, and - ii) additions to the Program; - where such changes and/or additions to the Program originate from - and are Distributed by that particular Contributor. A Contribution - "originates" from a Contributor if it was added to the Program by - such Contributor itself or anyone acting on such Contributor's behalf. - Contributions do not include changes or additions to the Program that - are not Modified Works. - -"Contributor" means any person or entity that Distributes the Program. - -"Licensed Patents" mean patent claims licensable by a Contributor which -are necessarily infringed by the use or sale of its Contribution alone -or when combined with the Program. - -"Program" means the Contributions Distributed in accordance with this -Agreement. - -"Recipient" means anyone who receives the Program under this Agreement -or any Secondary License (as applicable), including Contributors. - -"Derivative Works" shall mean any work, whether in Source Code or other -form, that is based on (or derived from) the Program and for which the -editorial revisions, annotations, elaborations, or other modifications -represent, as a whole, an original work of authorship. - -"Modified Works" shall mean any work in Source Code or other form that -results from an addition to, deletion from, or modification of the -contents of the Program, including, for purposes of clarity any new file -in Source Code form that contains any contents of the Program. Modified -Works shall not include works that contain only declarations, -interfaces, types, classes, structures, or files of the Program solely -in each case in order to link to, bind by name, or subclass the Program -or Modified Works thereof. - -"Distribute" means the acts of a) distributing or b) making available -in any manner that enables the transfer of a copy. - -"Source Code" means the form of a Program preferred for making -modifications, including but not limited to software source code, -documentation source, and configuration files. - -"Secondary License" means either the GNU General Public License, -Version 2.0, or any later versions of that license, including any -exceptions or additional permissions as identified by the initial -Contributor. - -2. GRANT OF RIGHTS - - a) Subject to the terms of this Agreement, each Contributor hereby - grants Recipient a non-exclusive, worldwide, royalty-free copyright - license to reproduce, prepare Derivative Works of, publicly display, - publicly perform, Distribute and sublicense the Contribution of such - Contributor, if any, and such Derivative Works. - - b) Subject to the terms of this Agreement, each Contributor hereby - grants Recipient a non-exclusive, worldwide, royalty-free patent - license under Licensed Patents to make, use, sell, offer to sell, - import and otherwise transfer the Contribution of such Contributor, - if any, in Source Code or other form. This patent license shall - apply to the combination of the Contribution and the Program if, at - the time the Contribution is added by the Contributor, such addition - of the Contribution causes such combination to be covered by the - Licensed Patents. The patent license shall not apply to any other - combinations which include the Contribution. No hardware per se is - licensed hereunder. - - c) Recipient understands that although each Contributor grants the - licenses to its Contributions set forth herein, no assurances are - provided by any Contributor that the Program does not infringe the - patent or other intellectual property rights of any other entity. - Each Contributor disclaims any liability to Recipient for claims - brought by any other entity based on infringement of intellectual - property rights or otherwise. As a condition to exercising the - rights and licenses granted hereunder, each Recipient hereby - assumes sole responsibility to secure any other intellectual - property rights needed, if any. For example, if a third party - patent license is required to allow Recipient to Distribute the - Program, it is Recipient's responsibility to acquire that license - before distributing the Program. - - d) Each Contributor represents that to its knowledge it has - sufficient copyright rights in its Contribution, if any, to grant - the copyright license set forth in this Agreement. - - e) Notwithstanding the terms of any Secondary License, no - Contributor makes additional grants to any Recipient (other than - those set forth in this Agreement) as a result of such Recipient's - receipt of the Program under the terms of a Secondary License - (if permitted under the terms of Section 3). - -3. REQUIREMENTS - -3.1 If a Contributor Distributes the Program in any form, then: - - a) the Program must also be made available as Source Code, in - accordance with section 3.2, and the Contributor must accompany - the Program with a statement that the Source Code for the Program - is available under this Agreement, and informs Recipients how to - obtain it in a reasonable manner on or through a medium customarily - used for software exchange; and - - b) the Contributor may Distribute the Program under a license - different than this Agreement, provided that such license: - i) effectively disclaims on behalf of all other Contributors all - warranties and conditions, express and implied, including - warranties or conditions of title and non-infringement, and - implied warranties or conditions of merchantability and fitness - for a particular purpose; - - ii) effectively excludes on behalf of all other Contributors all - liability for damages, including direct, indirect, special, - incidental and consequential damages, such as lost profits; - - iii) does not attempt to limit or alter the recipients' rights - in the Source Code under section 3.2; and - - iv) requires any subsequent distribution of the Program by any - party to be under a license that satisfies the requirements - of this section 3. - -3.2 When the Program is Distributed as Source Code: - - a) it must be made available under this Agreement, or if the - Program (i) is combined with other material in a separate file or - files made available under a Secondary License, and (ii) the initial - Contributor attached to the Source Code the notice described in - Exhibit A of this Agreement, then the Program may be made available - under the terms of such Secondary Licenses, and - - b) a copy of this Agreement must be included with each copy of - the Program. - -3.3 Contributors may not remove or alter any copyright, patent, -trademark, attribution notices, disclaimers of warranty, or limitations -of liability ("notices") contained within the Program from any copy of -the Program which they Distribute, provided that Contributors may add -their own appropriate notices. - -4. COMMERCIAL DISTRIBUTION - -Commercial distributors of software may accept certain responsibilities -with respect to end users, business partners and the like. While this -license is intended to facilitate the commercial use of the Program, -the Contributor who includes the Program in a commercial product -offering should do so in a manner which does not create potential -liability for other Contributors. Therefore, if a Contributor includes -the Program in a commercial product offering, such Contributor -("Commercial Contributor") hereby agrees to defend and indemnify every -other Contributor ("Indemnified Contributor") against any losses, -damages and costs (collectively "Losses") arising from claims, lawsuits -and other legal actions brought by a third party against the Indemnified -Contributor to the extent caused by the acts or omissions of such -Commercial Contributor in connection with its distribution of the Program -in a commercial product offering. The obligations in this section do not -apply to any claims or Losses relating to any actual or alleged -intellectual property infringement. In order to qualify, an Indemnified -Contributor must: a) promptly notify the Commercial Contributor in -writing of such claim, and b) allow the Commercial Contributor to control, -and cooperate with the Commercial Contributor in, the defense and any -related settlement negotiations. The Indemnified Contributor may -participate in any such claim at its own expense. - -For example, a Contributor might include the Program in a commercial -product offering, Product X. That Contributor is then a Commercial -Contributor. If that Commercial Contributor then makes performance -claims, or offers warranties related to Product X, those performance -claims and warranties are such Commercial Contributor's responsibility -alone. Under this section, the Commercial Contributor would have to -defend claims against the other Contributors related to those performance -claims and warranties, and if a court requires any other Contributor to -pay any damages as a result, the Commercial Contributor must pay -those damages. - -5. NO WARRANTY - -EXCEPT AS EXPRESSLY SET FORTH IN THIS AGREEMENT, AND TO THE EXTENT -PERMITTED BY APPLICABLE LAW, THE PROGRAM IS PROVIDED ON AN "AS IS" -BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, EITHER EXPRESS OR -IMPLIED INCLUDING, WITHOUT LIMITATION, ANY WARRANTIES OR CONDITIONS OF -TITLE, NON-INFRINGEMENT, MERCHANTABILITY OR FITNESS FOR A PARTICULAR -PURPOSE. Each Recipient is solely responsible for determining the -appropriateness of using and distributing the Program and assumes all -risks associated with its exercise of rights under this Agreement, -including but not limited to the risks and costs of program errors, -compliance with applicable laws, damage to or loss of data, programs -or equipment, and unavailability or interruption of operations. - -6. DISCLAIMER OF LIABILITY - -EXCEPT AS EXPRESSLY SET FORTH IN THIS AGREEMENT, AND TO THE EXTENT -PERMITTED BY APPLICABLE LAW, NEITHER RECIPIENT NOR ANY CONTRIBUTORS -SHALL HAVE ANY LIABILITY FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, -EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING WITHOUT LIMITATION LOST -PROFITS), 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 OR DISTRIBUTION OF THE PROGRAM OR THE -EXERCISE OF ANY RIGHTS GRANTED HEREUNDER, EVEN IF ADVISED OF THE -POSSIBILITY OF SUCH DAMAGES. - -7. GENERAL - -If any provision of this Agreement is invalid or unenforceable under -applicable law, it shall not affect the validity or enforceability of -the remainder of the terms of this Agreement, and without further -action by the parties hereto, such provision shall be reformed to the -minimum extent necessary to make such provision valid and enforceable. - -If Recipient institutes patent litigation against any entity -(including a cross-claim or counterclaim in a lawsuit) alleging that the -Program itself (excluding combinations of the Program with other software -or hardware) infringes such Recipient's patent(s), then such Recipient's -rights granted under Section 2(b) shall terminate as of the date such -litigation is filed. - -All Recipient's rights under this Agreement shall terminate if it -fails to comply with any of the material terms or conditions of this -Agreement and does not cure such failure in a reasonable period of -time after becoming aware of such noncompliance. If all Recipient's -rights under this Agreement terminate, Recipient agrees to cease use -and distribution of the Program as soon as reasonably practicable. -However, Recipient's obligations under this Agreement and any licenses -granted by Recipient relating to the Program shall continue and survive. - -Everyone is permitted to copy and distribute copies of this Agreement, -but in order to avoid inconsistency the Agreement is copyrighted and -may only be modified in the following manner. The Agreement Steward -reserves the right to publish new versions (including revisions) of -this Agreement from time to time. No one other than the Agreement -Steward has the right to modify this Agreement. The Eclipse Foundation -is the initial Agreement Steward. The Eclipse Foundation may assign the -responsibility to serve as the Agreement Steward to a suitable separate -entity. Each new version of the Agreement will be given a distinguishing -version number. The Program (including Contributions) may always be -Distributed subject to the version of the Agreement under which it was -received. In addition, after a new version of the Agreement is published, -Contributor may elect to Distribute the Program (including its -Contributions) under the new version. - -Except as expressly stated in Sections 2(a) and 2(b) above, Recipient -receives no rights or licenses to the intellectual property of any -Contributor under this Agreement, whether expressly, by implication, -estoppel or otherwise. All rights in the Program not expressly granted -under this Agreement are reserved. Nothing in this Agreement is intended -to be enforceable by any entity that is not a Contributor or Recipient. -No third-party beneficiary rights are created under this Agreement. - -Exhibit A - Form of Secondary Licenses Notice - -"This Source Code may also be made available under the following -Secondary Licenses when the conditions for such availability set forth -in the Eclipse Public License, v. 2.0 are satisfied: GNU General Public -License as published by the Free Software Foundation, either version 2 -of the License, or (at your option) any later version, with the GNU -Classpath Exception which is available at -https://www.gnu.org/software/classpath/license.html." - - Simply including a copy of this Agreement, including this Exhibit A - is not sufficient to license the Source Code under Secondary Licenses. - - 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. diff --git a/fib_test/clojure_fib/project.clj b/fib_test/clojure_fib/project.clj deleted file mode 100644 index 0033ae6..0000000 --- a/fib_test/clojure_fib/project.clj +++ /dev/null @@ -1,10 +0,0 @@ -(defproject clojure_fib "0.1.0-SNAPSHOT" - :description "FIXME: write description" - :url "http://example.com/FIXME" - :license {:name "EPL-2.0 OR GPL-2.0-or-later WITH Classpath-exception-2.0" - :url "https://www.eclipse.org/legal/epl-2.0/"} - :dependencies [[org.clojure/clojure "1.10.3"]] - :main ^:skip-aot clojure-fib.core - :target-path "target/%s" - :profiles {:uberjar {:aot :all - :jvm-opts ["-Dclojure.compiler.direct-linking=true"]}}) diff --git a/fib_test/clojure_fib/src/clojure_fib/core.clj b/fib_test/clojure_fib/src/clojure_fib/core.clj deleted file mode 100644 index 8a60aae..0000000 --- a/fib_test/clojure_fib/src/clojure_fib/core.clj +++ /dev/null @@ -1,14 +0,0 @@ -(ns clojure-fib.core - (:gen-class)) - -(defn fib - [n] - (cond (= n 0) 1 - (= n 1) 1 - :else (+ (fib (- n 1)) (fib (- n 2))))) - -(defn -main - "I don't do a whole lot ... yet." - [& args] - (println "Enter to fib: ") - (println "was " (fib (Integer/parseInt (read-line))))) diff --git a/fib_test/clojure_hi/.gitignore b/fib_test/clojure_hi/.gitignore deleted file mode 100644 index d956ab0..0000000 --- a/fib_test/clojure_hi/.gitignore +++ /dev/null @@ -1,13 +0,0 @@ -/target -/classes -/checkouts -profiles.clj -pom.xml -pom.xml.asc -*.jar -*.class -/.lein-* -/.nrepl-port -/.prepl-port -.hgignore -.hg/ diff --git a/fib_test/clojure_hi/LICENSE b/fib_test/clojure_hi/LICENSE deleted file mode 100644 index 2315126..0000000 --- a/fib_test/clojure_hi/LICENSE +++ /dev/null @@ -1,280 +0,0 @@ -Eclipse Public License - v 2.0 - - THE ACCOMPANYING PROGRAM IS PROVIDED UNDER THE TERMS OF THIS ECLIPSE - PUBLIC LICENSE ("AGREEMENT"). ANY USE, REPRODUCTION OR DISTRIBUTION - OF THE PROGRAM CONSTITUTES RECIPIENT'S ACCEPTANCE OF THIS AGREEMENT. - -1. DEFINITIONS - -"Contribution" means: - - a) in the case of the initial Contributor, the initial content - Distributed under this Agreement, and - - b) in the case of each subsequent Contributor: - i) changes to the Program, and - ii) additions to the Program; - where such changes and/or additions to the Program originate from - and are Distributed by that particular Contributor. A Contribution - "originates" from a Contributor if it was added to the Program by - such Contributor itself or anyone acting on such Contributor's behalf. - Contributions do not include changes or additions to the Program that - are not Modified Works. - -"Contributor" means any person or entity that Distributes the Program. - -"Licensed Patents" mean patent claims licensable by a Contributor which -are necessarily infringed by the use or sale of its Contribution alone -or when combined with the Program. - -"Program" means the Contributions Distributed in accordance with this -Agreement. - -"Recipient" means anyone who receives the Program under this Agreement -or any Secondary License (as applicable), including Contributors. - -"Derivative Works" shall mean any work, whether in Source Code or other -form, that is based on (or derived from) the Program and for which the -editorial revisions, annotations, elaborations, or other modifications -represent, as a whole, an original work of authorship. - -"Modified Works" shall mean any work in Source Code or other form that -results from an addition to, deletion from, or modification of the -contents of the Program, including, for purposes of clarity any new file -in Source Code form that contains any contents of the Program. Modified -Works shall not include works that contain only declarations, -interfaces, types, classes, structures, or files of the Program solely -in each case in order to link to, bind by name, or subclass the Program -or Modified Works thereof. - -"Distribute" means the acts of a) distributing or b) making available -in any manner that enables the transfer of a copy. - -"Source Code" means the form of a Program preferred for making -modifications, including but not limited to software source code, -documentation source, and configuration files. - -"Secondary License" means either the GNU General Public License, -Version 2.0, or any later versions of that license, including any -exceptions or additional permissions as identified by the initial -Contributor. - -2. GRANT OF RIGHTS - - a) Subject to the terms of this Agreement, each Contributor hereby - grants Recipient a non-exclusive, worldwide, royalty-free copyright - license to reproduce, prepare Derivative Works of, publicly display, - publicly perform, Distribute and sublicense the Contribution of such - Contributor, if any, and such Derivative Works. - - b) Subject to the terms of this Agreement, each Contributor hereby - grants Recipient a non-exclusive, worldwide, royalty-free patent - license under Licensed Patents to make, use, sell, offer to sell, - import and otherwise transfer the Contribution of such Contributor, - if any, in Source Code or other form. This patent license shall - apply to the combination of the Contribution and the Program if, at - the time the Contribution is added by the Contributor, such addition - of the Contribution causes such combination to be covered by the - Licensed Patents. The patent license shall not apply to any other - combinations which include the Contribution. No hardware per se is - licensed hereunder. - - c) Recipient understands that although each Contributor grants the - licenses to its Contributions set forth herein, no assurances are - provided by any Contributor that the Program does not infringe the - patent or other intellectual property rights of any other entity. - Each Contributor disclaims any liability to Recipient for claims - brought by any other entity based on infringement of intellectual - property rights or otherwise. As a condition to exercising the - rights and licenses granted hereunder, each Recipient hereby - assumes sole responsibility to secure any other intellectual - property rights needed, if any. For example, if a third party - patent license is required to allow Recipient to Distribute the - Program, it is Recipient's responsibility to acquire that license - before distributing the Program. - - d) Each Contributor represents that to its knowledge it has - sufficient copyright rights in its Contribution, if any, to grant - the copyright license set forth in this Agreement. - - e) Notwithstanding the terms of any Secondary License, no - Contributor makes additional grants to any Recipient (other than - those set forth in this Agreement) as a result of such Recipient's - receipt of the Program under the terms of a Secondary License - (if permitted under the terms of Section 3). - -3. REQUIREMENTS - -3.1 If a Contributor Distributes the Program in any form, then: - - a) the Program must also be made available as Source Code, in - accordance with section 3.2, and the Contributor must accompany - the Program with a statement that the Source Code for the Program - is available under this Agreement, and informs Recipients how to - obtain it in a reasonable manner on or through a medium customarily - used for software exchange; and - - b) the Contributor may Distribute the Program under a license - different than this Agreement, provided that such license: - i) effectively disclaims on behalf of all other Contributors all - warranties and conditions, express and implied, including - warranties or conditions of title and non-infringement, and - implied warranties or conditions of merchantability and fitness - for a particular purpose; - - ii) effectively excludes on behalf of all other Contributors all - liability for damages, including direct, indirect, special, - incidental and consequential damages, such as lost profits; - - iii) does not attempt to limit or alter the recipients' rights - in the Source Code under section 3.2; and - - iv) requires any subsequent distribution of the Program by any - party to be under a license that satisfies the requirements - of this section 3. - -3.2 When the Program is Distributed as Source Code: - - a) it must be made available under this Agreement, or if the - Program (i) is combined with other material in a separate file or - files made available under a Secondary License, and (ii) the initial - Contributor attached to the Source Code the notice described in - Exhibit A of this Agreement, then the Program may be made available - under the terms of such Secondary Licenses, and - - b) a copy of this Agreement must be included with each copy of - the Program. - -3.3 Contributors may not remove or alter any copyright, patent, -trademark, attribution notices, disclaimers of warranty, or limitations -of liability ("notices") contained within the Program from any copy of -the Program which they Distribute, provided that Contributors may add -their own appropriate notices. - -4. COMMERCIAL DISTRIBUTION - -Commercial distributors of software may accept certain responsibilities -with respect to end users, business partners and the like. While this -license is intended to facilitate the commercial use of the Program, -the Contributor who includes the Program in a commercial product -offering should do so in a manner which does not create potential -liability for other Contributors. Therefore, if a Contributor includes -the Program in a commercial product offering, such Contributor -("Commercial Contributor") hereby agrees to defend and indemnify every -other Contributor ("Indemnified Contributor") against any losses, -damages and costs (collectively "Losses") arising from claims, lawsuits -and other legal actions brought by a third party against the Indemnified -Contributor to the extent caused by the acts or omissions of such -Commercial Contributor in connection with its distribution of the Program -in a commercial product offering. The obligations in this section do not -apply to any claims or Losses relating to any actual or alleged -intellectual property infringement. In order to qualify, an Indemnified -Contributor must: a) promptly notify the Commercial Contributor in -writing of such claim, and b) allow the Commercial Contributor to control, -and cooperate with the Commercial Contributor in, the defense and any -related settlement negotiations. The Indemnified Contributor may -participate in any such claim at its own expense. - -For example, a Contributor might include the Program in a commercial -product offering, Product X. That Contributor is then a Commercial -Contributor. If that Commercial Contributor then makes performance -claims, or offers warranties related to Product X, those performance -claims and warranties are such Commercial Contributor's responsibility -alone. Under this section, the Commercial Contributor would have to -defend claims against the other Contributors related to those performance -claims and warranties, and if a court requires any other Contributor to -pay any damages as a result, the Commercial Contributor must pay -those damages. - -5. NO WARRANTY - -EXCEPT AS EXPRESSLY SET FORTH IN THIS AGREEMENT, AND TO THE EXTENT -PERMITTED BY APPLICABLE LAW, THE PROGRAM IS PROVIDED ON AN "AS IS" -BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, EITHER EXPRESS OR -IMPLIED INCLUDING, WITHOUT LIMITATION, ANY WARRANTIES OR CONDITIONS OF -TITLE, NON-INFRINGEMENT, MERCHANTABILITY OR FITNESS FOR A PARTICULAR -PURPOSE. Each Recipient is solely responsible for determining the -appropriateness of using and distributing the Program and assumes all -risks associated with its exercise of rights under this Agreement, -including but not limited to the risks and costs of program errors, -compliance with applicable laws, damage to or loss of data, programs -or equipment, and unavailability or interruption of operations. - -6. DISCLAIMER OF LIABILITY - -EXCEPT AS EXPRESSLY SET FORTH IN THIS AGREEMENT, AND TO THE EXTENT -PERMITTED BY APPLICABLE LAW, NEITHER RECIPIENT NOR ANY CONTRIBUTORS -SHALL HAVE ANY LIABILITY FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, -EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING WITHOUT LIMITATION LOST -PROFITS), 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 OR DISTRIBUTION OF THE PROGRAM OR THE -EXERCISE OF ANY RIGHTS GRANTED HEREUNDER, EVEN IF ADVISED OF THE -POSSIBILITY OF SUCH DAMAGES. - -7. GENERAL - -If any provision of this Agreement is invalid or unenforceable under -applicable law, it shall not affect the validity or enforceability of -the remainder of the terms of this Agreement, and without further -action by the parties hereto, such provision shall be reformed to the -minimum extent necessary to make such provision valid and enforceable. - -If Recipient institutes patent litigation against any entity -(including a cross-claim or counterclaim in a lawsuit) alleging that the -Program itself (excluding combinations of the Program with other software -or hardware) infringes such Recipient's patent(s), then such Recipient's -rights granted under Section 2(b) shall terminate as of the date such -litigation is filed. - -All Recipient's rights under this Agreement shall terminate if it -fails to comply with any of the material terms or conditions of this -Agreement and does not cure such failure in a reasonable period of -time after becoming aware of such noncompliance. If all Recipient's -rights under this Agreement terminate, Recipient agrees to cease use -and distribution of the Program as soon as reasonably practicable. -However, Recipient's obligations under this Agreement and any licenses -granted by Recipient relating to the Program shall continue and survive. - -Everyone is permitted to copy and distribute copies of this Agreement, -but in order to avoid inconsistency the Agreement is copyrighted and -may only be modified in the following manner. The Agreement Steward -reserves the right to publish new versions (including revisions) of -this Agreement from time to time. No one other than the Agreement -Steward has the right to modify this Agreement. The Eclipse Foundation -is the initial Agreement Steward. The Eclipse Foundation may assign the -responsibility to serve as the Agreement Steward to a suitable separate -entity. Each new version of the Agreement will be given a distinguishing -version number. The Program (including Contributions) may always be -Distributed subject to the version of the Agreement under which it was -received. In addition, after a new version of the Agreement is published, -Contributor may elect to Distribute the Program (including its -Contributions) under the new version. - -Except as expressly stated in Sections 2(a) and 2(b) above, Recipient -receives no rights or licenses to the intellectual property of any -Contributor under this Agreement, whether expressly, by implication, -estoppel or otherwise. All rights in the Program not expressly granted -under this Agreement are reserved. Nothing in this Agreement is intended -to be enforceable by any entity that is not a Contributor or Recipient. -No third-party beneficiary rights are created under this Agreement. - -Exhibit A - Form of Secondary Licenses Notice - -"This Source Code may also be made available under the following -Secondary Licenses when the conditions for such availability set forth -in the Eclipse Public License, v. 2.0 are satisfied: GNU General Public -License as published by the Free Software Foundation, either version 2 -of the License, or (at your option) any later version, with the GNU -Classpath Exception which is available at -https://www.gnu.org/software/classpath/license.html." - - Simply including a copy of this Agreement, including this Exhibit A - is not sufficient to license the Source Code under Secondary Licenses. - - 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. diff --git a/fib_test/clojure_hi/project.clj b/fib_test/clojure_hi/project.clj deleted file mode 100644 index f8839d5..0000000 --- a/fib_test/clojure_hi/project.clj +++ /dev/null @@ -1,10 +0,0 @@ -(defproject clojure_hi "0.1.0-SNAPSHOT" - :description "FIXME: write description" - :url "http://example.com/FIXME" - :license {:name "EPL-2.0 OR GPL-2.0-or-later WITH Classpath-exception-2.0" - :url "https://www.eclipse.org/legal/epl-2.0/"} - :dependencies [[org.clojure/clojure "1.10.3"]] - :main ^:skip-aot clojure-hi.core - :target-path "target/%s" - :profiles {:uberjar {:aot :all - :jvm-opts ["-Dclojure.compiler.direct-linking=true"]}}) diff --git a/fib_test/clojure_hi/src/clojure_hi/core.clj b/fib_test/clojure_hi/src/clojure_hi/core.clj deleted file mode 100644 index 7f1b1b4..0000000 --- a/fib_test/clojure_hi/src/clojure_hi/core.clj +++ /dev/null @@ -1,7 +0,0 @@ -(ns clojure-hi.core - (:gen-class)) - -(defn -main - "I don't do a whole lot ... yet." - [& args] - (println "Hello, World!")) diff --git a/fib_test/fib.c b/fib_test/fib.c deleted file mode 100644 index 7dd927b..0000000 --- a/fib_test/fib.c +++ /dev/null @@ -1,14 +0,0 @@ - -int fib(n) { - if (n == 0) { - return 1; - } else if (n == 1) { - return 1; - } else { - return fib(n-1) + fib(n-2); - } -} -int main(int argc, char **argv) { - printf("%d\n", fib(atoi(argv[1]))); - return 0; -} diff --git a/fib_test/fib.kp b/fib_test/fib.kp deleted file mode 100644 index a18de17..0000000 --- a/fib_test/fib.kp +++ /dev/null @@ -1,36 +0,0 @@ - -((wrap (vau root_env (quote) -((wrap (vau (let1) -(let1 lambda (vau se (p b1) (wrap (eval (array vau p b1) se))) -(let1 current-env (vau de () de) -(let1 cons (lambda (h t) (concat (array h) t)) -(let1 Y (lambda (f3) - ((lambda (x1) (x1 x1)) - (lambda (x2) (f3 (wrap (vau app_env (& y) (lapply (x2 x2) y app_env))))))) -(let1 vY (lambda (f) - ((lambda (x3) (x3 x3)) - (lambda (x4) (f (vau de1 (& y) (vapply (x4 x4) y de1)))))) -(let1 let (vY (lambda (recurse) (vau de2 (vs b) (cond (= (len vs) 0) (eval b de2) - true (vapply let1 (array (idx vs 0) (idx vs 1) (array recurse (slice vs 2 -1) b)) de2))))) - (let ( - lcompose (lambda (g f) (lambda (& args) (lapply g (array (lapply f args))))) - rec-lambda (vau se (n p b) (eval (array Y (array lambda (array n) (array lambda p b))) se)) - - fib (rec-lambda fib (n) (cond (= 0 n) 1 - (= 1 n) 1 - true (+ (fib (- n 1)) (fib (- n 2))))) - - monad (array 'write 1 "enter number to fact: " (vau (written code) - (array 'read 0 60 (vau (data code) - (array 'exit (fib (read-string data))) - )) - - )) - - ) monad) -; end of all lets -)))))) -; impl of let1 -)) (vau de (s v b) (eval (array (array wrap (array vau (array s) b)) v) de))) -; impl of quote -)) (vau (x5) x5)) diff --git a/fib_test/fib.py b/fib_test/fib.py deleted file mode 100644 index 430650e..0000000 --- a/fib_test/fib.py +++ /dev/null @@ -1,9 +0,0 @@ -import sys -def fib(n): - if n == 0: - return 1 - elif n == 1: - return 1 - else: - return fib(n-1) + fib(n-2) -print(fib(int(sys.argv[1]))) diff --git a/fib_test/fib.scm b/fib_test/fib.scm deleted file mode 100644 index 7b559a4..0000000 --- a/fib_test/fib.scm +++ /dev/null @@ -1,4 +0,0 @@ -(pretty-print ((letrec ((fib (lambda (n) (cond ((equal? n 0) 1) - ((equal? n 1) 1) - (#t (+ (fib (- n 1)) (fib (- n 2)))))))) - fib) (read (open-input-string (list-ref (command-line) 1))))) diff --git a/fib_test/fib2.kp b/fib_test/fib2.kp deleted file mode 100644 index 63c32f9..0000000 --- a/fib_test/fib2.kp +++ /dev/null @@ -1,36 +0,0 @@ - -((wrap (vau root_env (quote) -((wrap (vau (let1) -(let1 lambda (vau se (p b1) (wrap (eval (array vau p b1) se))) -(let1 current-env (vau de () de) -(let1 cons (lambda (h t) (concat (array h) t)) -(let1 Y (lambda (f3) - ((lambda (x1) (x1 x1)) - (lambda (x2) (f3 (wrap (vau app_env (& y) (lapply (x2 x2) y app_env))))))) -(let1 vY (lambda (f) - ((lambda (x3) (x3 x3)) - (lambda (x4) (f (vau de1 (& y) (vapply (x4 x4) y de1)))))) -(let1 let (vY (lambda (recurse) (vau de2 (vs b) (cond (= (len vs) 0) (eval b de2) - true (vapply let1 (array (idx vs 0) (idx vs 1) (array recurse (slice vs 2 -1) b)) de2))))) - (let ( - lcompose (lambda (g f) (lambda (& args) (lapply g (array (lapply f args))))) - rec-lambda (vau se (n p b) (eval (array Y (array lambda (array n) (array lambda p b))) se)) - - fib (lambda (n) ((lambda (fib) (fib fib n)) (lambda (fib n) (cond (= 0 n) 1 - (= 1 n) 1 - true (+ (fib fib (- n 1)) (fib fib (- n 2))))))) - - monad (array 'write 1 "enter number to fact: " (vau (written code) - (array 'read 0 60 (vau (data code) - (array 'exit (fib (read-string data))) - )) - - )) - - ) monad) -; end of all lets -)))))) -; impl of let1 -)) (vau de (s v b) (eval (array (array wrap (array vau (array s) b)) v) de))) -; impl of quote -)) (vau (x5) x5)) diff --git a/fib_test/fib_let.c b/fib_test/fib_let.c deleted file mode 100644 index 85ef649..0000000 --- a/fib_test/fib_let.c +++ /dev/null @@ -1,16 +0,0 @@ - -int fib(n) { - if (n == 0) { - return 1; - } else if (n == 1) { - return 1; - } else { - int r1 = fib(n-1); - int r2 = fib(n-2); - return r1 + r2; - } -} -int main(int argc, char **argv) { - printf("%d\n", fib(atoi(argv[1]))); - return 0; -} diff --git a/fib_test/fib_let.kp b/fib_test/fib_let.kp deleted file mode 100644 index 54b601d..0000000 --- a/fib_test/fib_let.kp +++ /dev/null @@ -1,39 +0,0 @@ - -((wrap (vau root_env (quote) -((wrap (vau (let1) -(let1 lambda (vau se (p b1) (wrap (eval (array vau p b1) se))) -(let1 current-env (vau de () de) -(let1 cons (lambda (h t) (concat (array h) t)) -(let1 Y (lambda (f3) - ((lambda (x1) (x1 x1)) - (lambda (x2) (f3 (wrap (vau app_env (& y) (lapply (x2 x2) y app_env))))))) -(let1 vY (lambda (f) - ((lambda (x3) (x3 x3)) - (lambda (x4) (f (vau de1 (& y) (vapply (x4 x4) y de1)))))) -(let1 let (vY (lambda (recurse) (vau de2 (vs b) (cond (= (len vs) 0) (eval b de2) - true (vapply let1 (array (idx vs 0) (idx vs 1) (array recurse (slice vs 2 -1) b)) de2))))) - (let ( - lcompose (lambda (g f) (lambda (& args) (lapply g (array (lapply f args))))) - rec-lambda (vau se (n p b) (eval (array Y (array lambda (array n) (array lambda p b))) se)) - - fib (rec-lambda fib (n) (cond (= 0 n) 1 - (= 1 n) 1 - true (let ( - fib_minus_1 (fib (- n 1)) - fib_minus_2 (fib (- n 2)) - ) (+ fib_minus_1 fib_minus_2)))) - - monad (array 'write 1 "enter number to fact: " (vau (written code) - (array 'read 0 60 (vau (data code) - (array 'exit (fib (read-string data))) - )) - - )) - - ) monad) -; end of all lets -)))))) -; impl of let1 -)) (vau de (s v b) (eval (array (array wrap (array vau (array s) b)) v) de))) -; impl of quote -)) (vau (x5) x5)) diff --git a/fib_test/fib_let.py b/fib_test/fib_let.py deleted file mode 100644 index f99f6f0..0000000 --- a/fib_test/fib_let.py +++ /dev/null @@ -1,11 +0,0 @@ -import sys -def fib(n): - if n == 0: - return 1 - elif n == 1: - return 1 - else: - r1 = fib(n-1) - r2 = fib(n-2) - return r1 + r2 -print(fib(int(sys.argv[1]))) diff --git a/fib_test/fib_let.scm b/fib_test/fib_let.scm deleted file mode 100644 index a7dabb1..0000000 --- a/fib_test/fib_let.scm +++ /dev/null @@ -1,7 +0,0 @@ -(pretty-print ((letrec ((fib (lambda (n) (cond ((equal? n 0) 1) - ((equal? n 1) 1) - (#t (let ( - (r1 (fib (- n 1))) - (r2 (fib (- n 2))) - ) (+ r1 r2))))))) - fib) (read (open-input-string (list-ref (command-line) 1))))) diff --git a/fib_test/fib_tests.sh b/fib_test/fib_tests.sh deleted file mode 100755 index 467ef5f..0000000 --- a/fib_test/fib_tests.sh +++ /dev/null @@ -1,44 +0,0 @@ -#!/usr/bin/env bash - -NUMBER=30 -#NUMBER=27 - -touch csc_out.wasm && rm csc_out.wasm && scheme --script ../partial_eval.scm fib.kp -mv csc_out.wasm fib_compiled.wasm -touch csc_out.wasm && rm csc_out.wasm && scheme --script ../partial_eval.scm fib_let.kp -mv csc_out.wasm fib_compiled_let.wasm - -touch csc_out.wasm && rm csc_out.wasm && scheme --script ../partial_eval.scm fib.kp no_compile -mv csc_out.wasm fib_interpreted.wasm -touch csc_out.wasm && rm csc_out.wasm && scheme --script ../partial_eval.scm fib_let.kp no_compile -mv csc_out.wasm fib_interpreted_let.wasm - -touch csc_out.wasm && rm csc_out.wasm && scheme --script ../partial_eval.scm fib2.kp -mv csc_out.wasm fib_compiled_manual.wasm -touch csc_out.wasm && rm csc_out.wasm && scheme --script ../partial_eval.scm builtin_fib.kp -mv csc_out.wasm builtin_fib.wasm - -pushd rust_fib -cargo build --target=wasm32-wasi -cargo build --release --target=wasm32-wasi -cargo build -cargo build --release -popd - -pushd clojure_fib -lein uberjar -popd - -pushd clojure_hi -lein uberjar -popd - -hyperfine --warmup 2 --export-markdown table.md \ - 'echo '$NUMBER' | wasmtime ./fib_compiled.wasm' 'echo '$NUMBER' | wasmtime ./fib_compiled_let.wasm' \ - 'echo '$NUMBER' | wasmtime ./builtin_fib.wasm' 'echo '$NUMBER' | wasmtime ./fib_compiled_manual.wasm' \ - "scheme --script ./fib.scm $NUMBER" "scheme --script ./fib_let.scm $NUMBER" \ - "python3 ./fib.py $NUMBER" "python3 ./fib_let.py $NUMBER" \ - 'echo '$NUMBER' | wasmtime ./rust_fib/target/wasm32-wasi/debug/rust_let.wasm' 'echo '$NUMBER' | wasmtime ./rust_fib/target/wasm32-wasi/release/rust_let.wasm' \ - "echo $NUMBER | java -jar ./clojure_fib/target/uberjar/clojure_fib-0.1.0-SNAPSHOT-standalone.jar" "echo $NUMBER | java -jar ./clojure_hi/target/uberjar/clojure_hi-0.1.0-SNAPSHOT-standalone.jar" \ - 'echo '$NUMBER' | wasmtime ./fib_interpreted.wasm' 'echo '$NUMBER' | wasmtime ./fib_interpreted_let.wasm' \ - #end diff --git a/fib_test/rust_fib/Cargo.lock b/fib_test/rust_fib/Cargo.lock deleted file mode 100644 index b108dd7..0000000 --- a/fib_test/rust_fib/Cargo.lock +++ /dev/null @@ -1,7 +0,0 @@ -# This file is automatically @generated by Cargo. -# It is not intended for manual editing. -version = 3 - -[[package]] -name = "rust_let" -version = "0.1.0" diff --git a/fib_test/rust_fib/Cargo.toml b/fib_test/rust_fib/Cargo.toml deleted file mode 100644 index faed3ac..0000000 --- a/fib_test/rust_fib/Cargo.toml +++ /dev/null @@ -1,8 +0,0 @@ -[package] -name = "rust_let" -version = "0.1.0" -edition = "2021" - -# See more keys and their definitions at https://doc.rust-lang.org/cargo/reference/manifest.html - -[dependencies] diff --git a/fib_test/rust_fib/src/main.rs b/fib_test/rust_fib/src/main.rs deleted file mode 100644 index f55fc9c..0000000 --- a/fib_test/rust_fib/src/main.rs +++ /dev/null @@ -1,18 +0,0 @@ - -use std::io; - -fn fib(n: i64) -> i64 { - match n { - 0 => 1, - 1 => 1, - o => fib(o-1) + fib(o-2), - } -} - -fn main() { - println!("enter number to fib:"); - let mut buffer = String::new(); - let stdin = io::stdin(); - stdin.read_line(&mut buffer).unwrap(); - println!("{}", fib(buffer.trim().parse::().unwrap())); -} diff --git a/fib_test/table.md b/fib_test/table.md deleted file mode 100644 index 0865c06..0000000 --- a/fib_test/table.md +++ /dev/null @@ -1,16 +0,0 @@ -| Command | Mean [ms] | Min [ms] | Max [ms] | Relative | -|:---|---:|---:|---:|---:| -| `echo 30 \| wasmtime ./fib_compiled.wasm` | 93.1 ± 0.7 | 91.6 | 94.7 | 7.28 ± 0.34 | -| `echo 30 \| wasmtime ./fib_compiled_let.wasm` | 119.1 ± 0.7 | 118.2 | 120.4 | 9.31 ± 0.43 | -| `echo 30 \| wasmtime ./builtin_fib.wasm` | 12.8 ± 0.6 | 11.4 | 14.7 | 1.00 | -| `echo 30 \| wasmtime ./fib_compiled_manual.wasm` | 257.4 ± 5.8 | 245.4 | 262.8 | 20.12 ± 1.03 | -| `scheme --script ./fib.scm 30` | 54.7 ± 1.2 | 52.7 | 57.9 | 4.27 ± 0.22 | -| `scheme --script ./fib_let.scm 30` | 54.5 ± 0.9 | 52.7 | 56.1 | 4.26 ± 0.21 | -| `python3 ./fib.py 30` | 283.5 ± 4.1 | 280.7 | 294.8 | 22.16 ± 1.07 | -| `python3 ./fib_let.py 30` | 299.4 ± 2.1 | 296.9 | 304.7 | 23.41 ± 1.09 | -| `echo 30 \| wasmtime ./rust_fib/target/wasm32-wasi/debug/rust_let.wasm` | 29.6 ± 0.6 | 28.5 | 31.4 | 2.31 ± 0.12 | -| `echo 30 \| wasmtime ./rust_fib/target/wasm32-wasi/release/rust_let.wasm` | 18.7 ± 0.6 | 17.2 | 20.2 | 1.47 ± 0.08 | -| `echo 30 \| java -jar ./clojure_fib/target/uberjar/clojure_fib-0.1.0-SNAPSHOT-standalone.jar` | 572.6 ± 17.4 | 546.0 | 599.5 | 44.76 ± 2.47 | -| `echo 30 \| java -jar ./clojure_hi/target/uberjar/clojure_hi-0.1.0-SNAPSHOT-standalone.jar` | 555.2 ± 12.0 | 536.6 | 571.4 | 43.40 ± 2.21 | -| `echo 30 \| wasmtime ./fib_interpreted.wasm` | 7716.7 ± 27.4 | 7679.8 | 7761.5 | 603.19 ± 27.93 | -| `echo 30 \| wasmtime ./fib_interpreted_let.wasm` | 21414.3 ± 307.9 | 21122.2 | 22246.7 | 1673.87 ± 80.94 | diff --git a/flake.lock b/flake.lock index 6aec6cb..20ecea7 100644 --- a/flake.lock +++ b/flake.lock @@ -5,11 +5,11 @@ "systems": "systems" }, "locked": { - "lastModified": 1687709756, - "narHash": "sha256-Y5wKlQSkgEK2weWdOu4J3riRd+kV/VCgHsqLNTTWQ/0=", + "lastModified": 1694529238, + "narHash": "sha256-zsNZZGTGnMOf9YpHKJqMSsa0dXbfmxeoJ7xHlrt+xmY=", "owner": "numtide", "repo": "flake-utils", - "rev": "dbabf0ca0c0c4bce6ea5eaf65af5cb694d2082c7", + "rev": "ff7b65b44d01cf9ba6a71320833626af21126384", "type": "github" }, "original": { @@ -42,11 +42,11 @@ "nixpkgs": "nixpkgs" }, "locked": { - "lastModified": 1688265347, - "narHash": "sha256-oe3kLnNvw2VWbG4Rp6IWUO5Uu5gF8J2oq8DbqbCsdZ4=", + "lastModified": 1700360261, + "narHash": "sha256-8fRSHx5osjDELHSL7OHEfj/cOh8q+B7M9EF/yPR3bw8=", "owner": "oxalica", "repo": "rust-overlay", - "rev": "b8f3db465405014039985f1c5cea92cc29e1b3b5", + "rev": "45066cb0b2505d8da581be8432a16238c867f199", "type": "github" }, "original": { @@ -73,11 +73,11 @@ }, "nixpkgs_unstable": { "locked": { - "lastModified": 1688334313, - "narHash": "sha256-FHDgNHqyc4lzL+5Xifm5H0c3EZ06O2N1qoccjQisqb0=", + "lastModified": 1700412808, + "narHash": "sha256-1yU5WT0sfRJ2DOVZ+6oDdpUZ6j0hz0JBPpbqj8/VCJQ=", "owner": "NixOS", "repo": "nixpkgs", - "rev": "5a193fb4ddbc0df84c96d213d36d27e60f14d7ae", + "rev": "38b1656c2d775b6abc6d08cfc8f38b8847a73ec4", "type": "github" }, "original": { diff --git a/kr/.gitignore b/kr/.gitignore deleted file mode 100644 index eb5a316..0000000 --- a/kr/.gitignore +++ /dev/null @@ -1 +0,0 @@ -target diff --git a/kr/Cargo.lock b/kr/Cargo.lock deleted file mode 100644 index e76dd04..0000000 --- a/kr/Cargo.lock +++ /dev/null @@ -1,559 +0,0 @@ -# This file is automatically @generated by Cargo. -# It is not intended for manual editing. -version = 3 - -[[package]] -name = "aho-corasick" -version = "0.7.20" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "cc936419f96fa211c1b9166887b38e5e40b19958e5b895be7c1f93adec7071ac" -dependencies = [ - "memchr", -] - -[[package]] -name = "anyhow" -version = "1.0.70" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "7de8ce5e0f9f8d88245311066a578d72b7af3e7088f32783804676302df237e4" - -[[package]] -name = "ascii-canvas" -version = "3.0.0" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "8824ecca2e851cec16968d54a01dd372ef8f95b244fb84b84e70128be347c3c6" -dependencies = [ - "term", -] - -[[package]] -name = "atty" -version = "0.2.14" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "d9b39be18770d11421cdb1b9947a45dd3f37e93092cbf377614828a319d5fee8" -dependencies = [ - "hermit-abi", - "libc", - "winapi", -] - -[[package]] -name = "autocfg" -version = "1.1.0" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "d468802bab17cbc0cc575e9b053f41e72aa36bfa6b7f55e3529ffa43161b97fa" - -[[package]] -name = "bit-set" -version = "0.5.3" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "0700ddab506f33b20a03b13996eccd309a48e5ff77d0d95926aa0210fb4e95f1" -dependencies = [ - "bit-vec", -] - -[[package]] -name = "bit-vec" -version = "0.6.3" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "349f9b6a179ed607305526ca489b34ad0a41aed5f7980fa90eb03160b69598fb" - -[[package]] -name = "bitflags" -version = "1.3.2" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "bef38d45163c2f1dde094a7dfd33ccf595c92905c8f8f4fdc18d06fb1037718a" - -[[package]] -name = "cfg-if" -version = "1.0.0" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "baf1de4339761588bc0619e3cbc0120ee582ebb74b53b4efbf79117bd2da40fd" - -[[package]] -name = "crunchy" -version = "0.2.2" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "7a81dae078cea95a014a339291cec439d2f232ebe854a9d672b796c6afafa9b7" - -[[package]] -name = "diff" -version = "0.1.13" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "56254986775e3233ffa9c4d7d3faaf6d36a2c09d30b20687e9f88bc8bafc16c8" - -[[package]] -name = "dirs-next" -version = "2.0.0" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "b98cf8ebf19c3d1b223e151f99a4f9f0690dca41414773390fc824184ac833e1" -dependencies = [ - "cfg-if", - "dirs-sys-next", -] - -[[package]] -name = "dirs-sys-next" -version = "0.1.2" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "4ebda144c4fe02d1f7ea1a7d9641b6fc6b580adcfa024ae48797ecdeb6825b4d" -dependencies = [ - "libc", - "redox_users", - "winapi", -] - -[[package]] -name = "either" -version = "1.8.1" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "7fcaabb2fef8c910e7f4c7ce9f67a1283a1715879a7c230ca9d6d1ae31f16d91" - -[[package]] -name = "ena" -version = "0.14.0" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "d7402b94a93c24e742487327a7cd839dc9d36fec9de9fb25b09f2dae459f36c3" -dependencies = [ - "log", -] - -[[package]] -name = "fixedbitset" -version = "0.4.2" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "0ce7134b9999ecaf8bcd65542e436736ef32ddca1b3e06094cb6ec5755203b80" - -[[package]] -name = "getrandom" -version = "0.2.8" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "c05aeb6a22b8f62540c194aac980f2115af067bfe15a0734d7277a768d396b31" -dependencies = [ - "cfg-if", - "libc", - "wasi", -] - -[[package]] -name = "hashbrown" -version = "0.12.3" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "8a9ee70c43aaf417c914396645a0fa852624801b24ebb7ae78fe8272889ac888" - -[[package]] -name = "hermit-abi" -version = "0.1.19" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "62b467343b94ba476dcb2500d242dadbb39557df889310ac77c5d99100aaac33" -dependencies = [ - "libc", -] - -[[package]] -name = "indexmap" -version = "1.9.2" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "1885e79c1fc4b10f0e172c475f458b7f7b93061064d98c3293e98c5ba0c8b399" -dependencies = [ - "autocfg", - "hashbrown", -] - -[[package]] -name = "itertools" -version = "0.10.5" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "b0fd2260e829bddf4cb6ea802289de2f86d6a7a690192fbe91b3f46e0f2c8473" -dependencies = [ - "either", -] - -[[package]] -name = "kr" -version = "0.1.0" -dependencies = [ - "anyhow", - "lalrpop", - "lalrpop-util", - "once_cell", - "regex", -] - -[[package]] -name = "lalrpop" -version = "0.19.8" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "b30455341b0e18f276fa64540aff54deafb54c589de6aca68659c63dd2d5d823" -dependencies = [ - "ascii-canvas", - "atty", - "bit-set", - "diff", - "ena", - "itertools", - "lalrpop-util", - "petgraph", - "pico-args", - "regex", - "regex-syntax", - "string_cache", - "term", - "tiny-keccak", - "unicode-xid", -] - -[[package]] -name = "lalrpop-util" -version = "0.19.8" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "bcf796c978e9b4d983414f4caedc9273aa33ee214c5b887bd55fde84c85d2dc4" -dependencies = [ - "regex", -] - -[[package]] -name = "libc" -version = "0.2.139" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "201de327520df007757c1f0adce6e827fe8562fbc28bfd9c15571c66ca1f5f79" - -[[package]] -name = "lock_api" -version = "0.4.9" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "435011366fe56583b16cf956f9df0095b405b82d76425bc8981c0e22e60ec4df" -dependencies = [ - "autocfg", - "scopeguard", -] - -[[package]] -name = "log" -version = "0.4.17" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "abb12e687cfb44aa40f41fc3978ef76448f9b6038cad6aef4259d3c095a2382e" -dependencies = [ - "cfg-if", -] - -[[package]] -name = "memchr" -version = "2.5.0" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "2dffe52ecf27772e601905b7522cb4ef790d2cc203488bbd0e2fe85fcb74566d" - -[[package]] -name = "new_debug_unreachable" -version = "1.0.4" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "e4a24736216ec316047a1fc4252e27dabb04218aa4a3f37c6e7ddbf1f9782b54" - -[[package]] -name = "once_cell" -version = "1.17.0" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "6f61fba1741ea2b3d6a1e3178721804bb716a68a6aeba1149b5d52e3d464ea66" - -[[package]] -name = "parking_lot" -version = "0.12.1" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "3742b2c103b9f06bc9fff0a37ff4912935851bee6d36f3c02bcc755bcfec228f" -dependencies = [ - "lock_api", - "parking_lot_core", -] - -[[package]] -name = "parking_lot_core" -version = "0.9.7" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "9069cbb9f99e3a5083476ccb29ceb1de18b9118cafa53e90c9551235de2b9521" -dependencies = [ - "cfg-if", - "libc", - "redox_syscall", - "smallvec", - "windows-sys", -] - -[[package]] -name = "petgraph" -version = "0.6.3" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "4dd7d28ee937e54fe3080c91faa1c3a46c06de6252988a7f4592ba2310ef22a4" -dependencies = [ - "fixedbitset", - "indexmap", -] - -[[package]] -name = "phf_shared" -version = "0.10.0" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "b6796ad771acdc0123d2a88dc428b5e38ef24456743ddb1744ed628f9815c096" -dependencies = [ - "siphasher", -] - -[[package]] -name = "pico-args" -version = "0.4.2" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "db8bcd96cb740d03149cbad5518db9fd87126a10ab519c011893b1754134c468" - -[[package]] -name = "precomputed-hash" -version = "0.1.1" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "925383efa346730478fb4838dbe9137d2a47675ad789c546d150a6e1dd4ab31c" - -[[package]] -name = "proc-macro2" -version = "1.0.51" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "5d727cae5b39d21da60fa540906919ad737832fe0b1c165da3a34d6548c849d6" -dependencies = [ - "unicode-ident", -] - -[[package]] -name = "quote" -version = "1.0.23" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "8856d8364d252a14d474036ea1358d63c9e6965c8e5c1885c18f73d70bff9c7b" -dependencies = [ - "proc-macro2", -] - -[[package]] -name = "redox_syscall" -version = "0.2.16" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "fb5a58c1855b4b6819d59012155603f0b22ad30cad752600aadfcb695265519a" -dependencies = [ - "bitflags", -] - -[[package]] -name = "redox_users" -version = "0.4.3" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "b033d837a7cf162d7993aded9304e30a83213c648b6e389db233191f891e5c2b" -dependencies = [ - "getrandom", - "redox_syscall", - "thiserror", -] - -[[package]] -name = "regex" -version = "1.7.1" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "48aaa5748ba571fb95cd2c85c09f629215d3a6ece942baa100950af03a34f733" -dependencies = [ - "aho-corasick", - "memchr", - "regex-syntax", -] - -[[package]] -name = "regex-syntax" -version = "0.6.28" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "456c603be3e8d448b072f410900c09faf164fbce2d480456f50eea6e25f9c848" - -[[package]] -name = "rustversion" -version = "1.0.11" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "5583e89e108996506031660fe09baa5011b9dd0341b89029313006d1fb508d70" - -[[package]] -name = "scopeguard" -version = "1.1.0" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "d29ab0c6d3fc0ee92fe66e2d99f700eab17a8d57d1c1d3b748380fb20baa78cd" - -[[package]] -name = "siphasher" -version = "0.3.10" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "7bd3e3206899af3f8b12af284fafc038cc1dc2b41d1b89dd17297221c5d225de" - -[[package]] -name = "smallvec" -version = "1.10.0" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "a507befe795404456341dfab10cef66ead4c041f62b8b11bbb92bffe5d0953e0" - -[[package]] -name = "string_cache" -version = "0.8.4" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "213494b7a2b503146286049378ce02b482200519accc31872ee8be91fa820a08" -dependencies = [ - "new_debug_unreachable", - "once_cell", - "parking_lot", - "phf_shared", - "precomputed-hash", -] - -[[package]] -name = "syn" -version = "1.0.107" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "1f4064b5b16e03ae50984a5a8ed5d4f8803e6bc1fd170a3cda91a1be4b18e3f5" -dependencies = [ - "proc-macro2", - "quote", - "unicode-ident", -] - -[[package]] -name = "term" -version = "0.7.0" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "c59df8ac95d96ff9bede18eb7300b0fda5e5d8d90960e76f8e14ae765eedbf1f" -dependencies = [ - "dirs-next", - "rustversion", - "winapi", -] - -[[package]] -name = "thiserror" -version = "1.0.38" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "6a9cd18aa97d5c45c6603caea1da6628790b37f7a34b6ca89522331c5180fed0" -dependencies = [ - "thiserror-impl", -] - -[[package]] -name = "thiserror-impl" -version = "1.0.38" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "1fb327af4685e4d03fa8cbcf1716380da910eeb2bb8be417e7f9fd3fb164f36f" -dependencies = [ - "proc-macro2", - "quote", - "syn", -] - -[[package]] -name = "tiny-keccak" -version = "2.0.2" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "2c9d3793400a45f954c52e73d068316d76b6f4e36977e3fcebb13a2721e80237" -dependencies = [ - "crunchy", -] - -[[package]] -name = "unicode-ident" -version = "1.0.6" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "84a22b9f218b40614adcb3f4ff08b703773ad44fa9423e4e0d346d5db86e4ebc" - -[[package]] -name = "unicode-xid" -version = "0.2.4" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "f962df74c8c05a667b5ee8bcf162993134c104e96440b663c8daa176dc772d8c" - -[[package]] -name = "wasi" -version = "0.11.0+wasi-snapshot-preview1" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "9c8d87e72b64a3b4db28d11ce29237c246188f4f51057d65a7eab63b7987e423" - -[[package]] -name = "winapi" -version = "0.3.9" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "5c839a674fcd7a98952e593242ea400abe93992746761e38641405d28b00f419" -dependencies = [ - "winapi-i686-pc-windows-gnu", - "winapi-x86_64-pc-windows-gnu", -] - -[[package]] -name = "winapi-i686-pc-windows-gnu" -version = "0.4.0" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "ac3b87c63620426dd9b991e5ce0329eff545bccbbb34f3be09ff6fb6ab51b7b6" - -[[package]] -name = "winapi-x86_64-pc-windows-gnu" -version = "0.4.0" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "712e227841d057c1ee1cd2fb22fa7e5a5461ae8e48fa2ca79ec42cfc1931183f" - -[[package]] -name = "windows-sys" -version = "0.45.0" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "75283be5efb2831d37ea142365f009c02ec203cd29a3ebecbc093d52315b66d0" -dependencies = [ - "windows-targets", -] - -[[package]] -name = "windows-targets" -version = "0.42.1" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "8e2522491fbfcd58cc84d47aeb2958948c4b8982e9a2d8a2a35bbaed431390e7" -dependencies = [ - "windows_aarch64_gnullvm", - "windows_aarch64_msvc", - "windows_i686_gnu", - "windows_i686_msvc", - "windows_x86_64_gnu", - "windows_x86_64_gnullvm", - "windows_x86_64_msvc", -] - -[[package]] -name = "windows_aarch64_gnullvm" -version = "0.42.1" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "8c9864e83243fdec7fc9c5444389dcbbfd258f745e7853198f365e3c4968a608" - -[[package]] -name = "windows_aarch64_msvc" -version = "0.42.1" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "4c8b1b673ffc16c47a9ff48570a9d85e25d265735c503681332589af6253c6c7" - -[[package]] -name = "windows_i686_gnu" -version = "0.42.1" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "de3887528ad530ba7bdbb1faa8275ec7a1155a45ffa57c37993960277145d640" - -[[package]] -name = "windows_i686_msvc" -version = "0.42.1" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "bf4d1122317eddd6ff351aa852118a2418ad4214e6613a50e0191f7004372605" - -[[package]] -name = "windows_x86_64_gnu" -version = "0.42.1" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "c1040f221285e17ebccbc2591ffdc2d44ee1f9186324dd3e84e99ac68d699c45" - -[[package]] -name = "windows_x86_64_gnullvm" -version = "0.42.1" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "628bfdf232daa22b0d64fdb62b09fcc36bb01f05a3939e20ab73aaf9470d0463" - -[[package]] -name = "windows_x86_64_msvc" -version = "0.42.1" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "447660ad36a13288b1db4d4248e857b510e8c3a225c822ba4fb748c0aafecffd" diff --git a/kr/src/ast.rs b/kr/src/ast.rs deleted file mode 100644 index d68c6e2..0000000 --- a/kr/src/ast.rs +++ /dev/null @@ -1,338 +0,0 @@ -use std::fmt; -use std::rc::Rc; -use std::convert::From; - -// TODO: -// -extend vau & env logic and SuspendedPair PE with sequence_params & wrap_level -// -add current-hashes to if -// -expand combiner_Return_ok with (func ...params) | func doesn't take de and func+params are return ok -// -add recursive drop redundent veval -// -mark rec-hash on DeriComb -// -add compiler -// -// -use current fake comb ids instead of hashes -// -do they have to be added to not-under thing like hashes -// -make cons work only for SuspendedParam/Env - -impl From for Form { fn from(item: i32) -> Self { Form::Int(item) } } -impl From for Form { fn from(item: bool) -> Self { Form::Bool(item) } } -// todo, strings not symbols? -impl From for Form { fn from(item: String) -> Self { Form::Symbol(item) } } -impl From<&str> for Form { fn from(item: &str) -> Self { Form::Symbol(item.to_owned()) } } - -impl, B: Into
> From<(A, B)> for Form { - fn from(item: (A, B)) -> Self { - Form::Pair(Rc::new(item.0.into()), Rc::new(item.1.into())) - } -} - -pub enum PossibleTailCall { - Result(Rc), - TailCall(Rc, Rc), -} -#[derive(Debug, Eq, PartialEq)] -pub enum Form { - Nil, - Int(i32), - Bool(bool), - Symbol(String), - Pair(Rc,Rc), - PrimComb(String, fn(Rc, Rc) -> PossibleTailCall), - DeriComb { se: Rc, de: Option, params: String, body: Rc }, -} -impl Form { - pub fn truthy(&self) -> bool { - match self { - Form::Bool(b) => *b, - Form::Nil => false, - _ => true, - } - } - pub fn int(&self) -> Option { - match self { - Form::Int(i) => Some(*i), - _ => None, - } - } - pub fn sym(&self) -> Option<&str> { - match self { - Form::Symbol(s) => Some(s), - _ => None, - } - } - pub fn car(&self) -> Option> { - match self { - Form::Pair(car, _cdr) => Some(Rc::clone(car)), - _ => None, - } - } - pub fn cdr(&self) -> Option> { - match self { - Form::Pair(_car, cdr) => Some(Rc::clone(cdr)), - _ => None, - } - } - pub fn append(&self, x: Rc) -> Option { - match self { - Form::Pair(car, cdr) => cdr.append(x).map(|x| Form::Pair(Rc::clone(car), Rc::new(x))), - Form::Nil => Some(Form::Pair(x, Rc::new(Form::Nil))), - _ => None, - } - } -} -impl fmt::Display for Form { - fn fmt(&self, f: &mut fmt::Formatter<'_>) -> fmt::Result { - match self { - Form::Nil => write!(f, "nil"), - Form::Int(i) => write!(f, "{}", i), - Form::Bool(b) => write!(f, "{}", b), - Form::Symbol(s) => write!(f, "{}", s), - Form::Pair(car, cdr) => { - write!(f, "({}", car)?; - let mut traverse: Rc = Rc::clone(cdr); - loop { - match &*traverse { - Form::Pair(ref carp, ref cdrp) => { - write!(f, " {}", carp)?; - traverse = Rc::clone(cdrp); - }, - Form::Nil => { - write!(f, ")")?; - return Ok(()); - }, - x => { - write!(f, ". {})", x)?; - return Ok(()); - }, - } - } - }, - Form::PrimComb(name, _f) => write!(f, "<{}>", name), - Form::DeriComb { se, de, params, body } => { - write!(f, "<{} {} {}>", de.as_ref().unwrap_or(&"".to_string()), params, body) - }, - } - } -} - -pub fn eval(e: Rc, f: Rc) -> Rc { - let mut e = e; - let mut x = Option::Some(f); - loop { - let cur = x.take().unwrap(); - //println!("Evaluating {:?} in {:?}", cur, e); - match *cur { - Form::Symbol(ref s) => { - let mut t = e; - //println!("Looking up {} in {:?}", s, t); - //println!("Looking up {}", s); - while s != t.car().unwrap().car().unwrap().sym().unwrap() { - t = t.cdr().unwrap(); - } - return t.car().unwrap().cdr().unwrap(); - }, - Form::Pair(ref c, ref p) => { - let comb = eval(Rc::clone(&e), Rc::clone(c)); - match *comb { - Form::PrimComb(ref _n, ref f) => match f(e, Rc::clone(p)) { - PossibleTailCall::Result(r) => return r, - PossibleTailCall::TailCall(ne, nx) => { - e = ne; - x = Some(nx); - }, - }, - Form::DeriComb{ref se, ref de, ref params, ref body } => { - let mut new_e = Rc::clone(se); - if let Some(de) = de { - new_e = assoc(de, Rc::clone(&e), new_e); - } - new_e = assoc(params, Rc::clone(p), new_e); - // always a tail call - e = new_e; - x = Some(Rc::clone(body)); - }, - _ => panic!("Tried to call not a Prim/DeriComb {:?}", comb), - } - }, - _ => return cur, - } - } -} -fn assoc(k: &str, v: Rc, l: Rc) -> Rc { - Rc::new(Form::Pair( - Rc::new(Form::Pair( - Rc::new(Form::Symbol(k.to_owned())), - v)), - l)) -} -fn assoc_vec(kvs: Vec<(&str, Rc)>) -> Rc { - let mut to_ret = Rc::new(Form::Nil); - for (k, v) in kvs { - to_ret = assoc(k, v, to_ret); - } - to_ret -} - -pub fn root_env() -> Rc { - assoc_vec(vec![ - ("eval", Rc::new(Form::PrimComb("eval".to_owned(), |e, p| { - let b = eval(Rc::clone(&e), p.car().unwrap()); - let e = eval(e, p.cdr().unwrap().car().unwrap()); - PossibleTailCall::TailCall(e, b) - }))), - // (vau de params body) - ("vau", Rc::new(Form::PrimComb("vau".to_owned(), |e, p| { - let de = p.car().unwrap().sym().map(|s| s.to_owned()); - let params = p.cdr().unwrap().car().unwrap().sym().unwrap().to_owned(); - let body = p.cdr().unwrap().cdr().unwrap().car().unwrap(); - - PossibleTailCall::Result(Rc::new(Form::DeriComb { se: e, de, params, body })) - }))), - ("=", Rc::new(Form::PrimComb("=".to_owned(), |e, p| { - let a = eval(Rc::clone(&e), p.car().unwrap()); - let b = eval(e, p.cdr().unwrap().car().unwrap()); - PossibleTailCall::Result(Rc::new(Form::Bool(a == b))) - }))), - ("<", Rc::new(Form::PrimComb("<".to_owned(), |e, p| { - let a = eval(Rc::clone(&e), p.car().unwrap()); - let b = eval(e, p.cdr().unwrap().car().unwrap()); - PossibleTailCall::Result(Rc::new(Form::Bool(a.int().unwrap() < b.int().unwrap()))) - }))), - (">", Rc::new(Form::PrimComb(">".to_owned(), |e, p| { - let a = eval(Rc::clone(&e), p.car().unwrap()); - let b = eval(e, p.cdr().unwrap().car().unwrap()); - PossibleTailCall::Result(Rc::new(Form::Bool(a.int().unwrap() > b.int().unwrap()))) - }))), - ("<=", Rc::new(Form::PrimComb("<=".to_owned(), |e, p| { - let a = eval(Rc::clone(&e), p.car().unwrap()); - let b = eval(e, p.cdr().unwrap().car().unwrap()); - PossibleTailCall::Result(Rc::new(Form::Bool(a.int().unwrap() <= b.int().unwrap()))) - }))), - (">=", Rc::new(Form::PrimComb(">=".to_owned(), |e, p| { - let a = eval(Rc::clone(&e), p.car().unwrap()); - let b = eval(e, p.cdr().unwrap().car().unwrap()); - PossibleTailCall::Result(Rc::new(Form::Bool(a.int().unwrap() >= b.int().unwrap()))) - }))), - ("if", Rc::new(Form::PrimComb("if".to_owned(), |e, p| { - if eval(Rc::clone(&e), p.car().unwrap()).truthy() { - PossibleTailCall::TailCall(e, p.cdr().unwrap().car().unwrap()) - } else { - PossibleTailCall::TailCall(e, p.cdr().unwrap().cdr().unwrap().car().unwrap()) - } - }))), - ("cons", Rc::new(Form::PrimComb("cons".to_owned(), |e, p| { - let h = eval(Rc::clone(&e), p.car().unwrap()); - let t = eval(e, p.cdr().unwrap().car().unwrap()); - PossibleTailCall::Result(Rc::new(Form::Pair(h, t))) - }))), - ("car", Rc::new(Form::PrimComb("car".to_owned(), |e, p| { - PossibleTailCall::Result(eval(Rc::clone(&e), p.car().unwrap()).car().unwrap()) - }))), - ("cdr", Rc::new(Form::PrimComb("cdr".to_owned(), |e, p| { - PossibleTailCall::Result(eval(Rc::clone(&e), p.car().unwrap()).cdr().unwrap()) - }))), - ("quote", Rc::new(Form::PrimComb("quote".to_owned(), |_e, p| { - PossibleTailCall::Result(p.car().unwrap()) - }))), - - ("debug", Rc::new(Form::PrimComb("debug".to_owned(), |e, p| { - //println!("Debug: {:?}", eval(Rc::clone(&e), p.car().unwrap())); - println!("Debug: {}", eval(Rc::clone(&e), p.car().unwrap())); - PossibleTailCall::TailCall(e, p.cdr().unwrap().car().unwrap()) - }))), - ("assert", Rc::new(Form::PrimComb("assert".to_owned(), |e, p| { - let thing = eval(Rc::clone(&e), p.car().unwrap()); - if !thing.truthy() { - println!("Assert failed: {:?}", thing); - } - assert!(thing.truthy()); - PossibleTailCall::TailCall(e, p.cdr().unwrap().car().unwrap()) - }))), - - ("+", Rc::new(Form::PrimComb("+".to_owned(), |e, p| { - let a = eval(Rc::clone(&e), p.car().unwrap()).int().unwrap(); - let b = eval(e, p.cdr().unwrap().car().unwrap()).int().unwrap(); - PossibleTailCall::Result(Rc::new(Form::Int(a + b))) - }))), - ("-", Rc::new(Form::PrimComb("-".to_owned(), |e, p| { - let a = eval(Rc::clone(&e), p.car().unwrap()).int().unwrap(); - let b = eval(e, p.cdr().unwrap().car().unwrap()).int().unwrap(); - PossibleTailCall::Result(Rc::new(Form::Int(a - b))) - }))), - ("*", Rc::new(Form::PrimComb("*".to_owned(), |e, p| { - let a = eval(Rc::clone(&e), p.car().unwrap()).int().unwrap(); - let b = eval(e, p.cdr().unwrap().car().unwrap()).int().unwrap(); - PossibleTailCall::Result(Rc::new(Form::Int(a * b))) - }))), - ("/", Rc::new(Form::PrimComb("/".to_owned(), |e, p| { - let a = eval(Rc::clone(&e), p.car().unwrap()).int().unwrap(); - let b = eval(e, p.cdr().unwrap().car().unwrap()).int().unwrap(); - PossibleTailCall::Result(Rc::new(Form::Int(a / b))) - }))), - ("%", Rc::new(Form::PrimComb("%".to_owned(), |e, p| { - let a = eval(Rc::clone(&e), p.car().unwrap()).int().unwrap(); - let b = eval(e, p.cdr().unwrap().car().unwrap()).int().unwrap(); - PossibleTailCall::Result(Rc::new(Form::Int(a % b))) - }))), - ("&", Rc::new(Form::PrimComb("&".to_owned(), |e, p| { - let a = eval(Rc::clone(&e), p.car().unwrap()).int().unwrap(); - let b = eval(e, p.cdr().unwrap().car().unwrap()).int().unwrap(); - PossibleTailCall::Result(Rc::new(Form::Int(a & b))) - }))), - ("|", Rc::new(Form::PrimComb("|".to_owned(), |e, p| { - let a = eval(Rc::clone(&e), p.car().unwrap()).int().unwrap(); - let b = eval(e, p.cdr().unwrap().car().unwrap()).int().unwrap(); - PossibleTailCall::Result(Rc::new(Form::Int(a | b))) - }))), - ("^", Rc::new(Form::PrimComb("^".to_owned(), |e, p| { - let a = eval(Rc::clone(&e), p.car().unwrap()).int().unwrap(); - let b = eval(e, p.cdr().unwrap().car().unwrap()).int().unwrap(); - PossibleTailCall::Result(Rc::new(Form::Int(a ^ b))) - }))), - - ("comb?", Rc::new(Form::PrimComb("comb?".to_owned(), |e, p| { - PossibleTailCall::Result(Rc::new(Form::Bool(match &*eval(e, p.car().unwrap()) { - Form::PrimComb(_n, _f) => true, - Form::DeriComb { .. } => true, - _ => false, - }))) - }))), - ("pair?", Rc::new(Form::PrimComb("pair?".to_owned(), |e, p| { - PossibleTailCall::Result(Rc::new(Form::Bool(match &*eval(e, p.car().unwrap()) { - Form::Pair(_a,_b) => true, - _ => false, - }))) - }))), - ("symbol?", Rc::new(Form::PrimComb("symbol?".to_owned(), |e, p| { - PossibleTailCall::Result(Rc::new(Form::Bool(match &*eval(e, p.car().unwrap()) { - Form::Symbol(_) => true, - _ => false, - }))) - }))), - ("int?", Rc::new(Form::PrimComb("int?".to_owned(), |e, p| { - PossibleTailCall::Result(Rc::new(Form::Bool(match &*eval(e, p.car().unwrap()) { - Form::Int(_) => true, - _ => false, - }))) - }))), - // maybe bool? but also could be derived. Nil def - ("bool?", Rc::new(Form::PrimComb("bool?".to_owned(), |e, p| { - PossibleTailCall::Result(Rc::new(Form::Bool(match &*eval(e, p.car().unwrap()) { - Form::Bool(_) => true, - _ => false, - }))) - }))), - ("nil?", Rc::new(Form::PrimComb("nil?".to_owned(), |e, p| { - PossibleTailCall::Result(Rc::new(Form::Bool(match &*eval(e, p.car().unwrap()) { - Form::Nil => true, - _ => false, - }))) - }))), - - // consts - ("true", Rc::new(Form::Bool(true))), - ("false", Rc::new(Form::Bool(false))), - ("nil", Rc::new(Form::Nil)), - ]) -} - diff --git a/kr/src/grammar.lalrpop b/kr/src/grammar.lalrpop deleted file mode 100644 index 949ee1d..0000000 --- a/kr/src/grammar.lalrpop +++ /dev/null @@ -1,31 +0,0 @@ -use std::str::FromStr; -use std::rc::Rc; -use crate::ast::Form; - -grammar; - -pub Term: Form = { - NUM => Form::Int(i32::from_str(<>).unwrap()), - SYM => Form::Symbol(<>.to_owned()), - "(" ")" => <>.unwrap_or(Form::Nil), - "'" => Form::Pair(Rc::new(Form::Symbol("quote".to_owned())), Rc::new(Form::Pair(Rc::new(<>), Rc::new(Form::Nil)))), - "!" => { - h.append(Rc::new(t)).unwrap() - }, -}; -ListInside: Form = { - => Form::Pair(Rc::new(<>), Rc::new(Form::Nil)), - => Form::Pair(Rc::new(h), Rc::new(t)), - "." => Form::Pair(Rc::new(a), Rc::new(d)), -} -match { - "(", - ")", - ".", - "'", - "!", - r"[0-9]+" => NUM, - r"[a-zA-Z+*/_=?%&|^<>-][\w+*/=_?%&|^<>-]*" => SYM, - r"(;[^\n]*\n)|\s+" => { } -} - diff --git a/kr/src/main.rs b/kr/src/main.rs deleted file mode 100644 index 9271d5f..0000000 --- a/kr/src/main.rs +++ /dev/null @@ -1,26 +0,0 @@ -#[macro_use] extern crate lalrpop_util; -lalrpop_mod!(pub grammar); - -use std::rc::Rc; - -mod ast; -use crate::ast::{eval,root_env}; -mod pe_ast; -use crate::pe_ast::{mark,partial_eval,new_base_ctxs}; - -mod test; - - -fn main() { - let input = "(= 17 ((vau d p (+ (eval (car p) d) 13)) (+ 1 3)))"; - let parsed_input = Rc::new(grammar::TermParser::new().parse(input).unwrap()); - println!("Parsed input is {} - {:?}", parsed_input, parsed_input); - let (bctx, dctx) = new_base_ctxs(); - let (bctx, marked) = mark(Rc::clone(&parsed_input),bctx); - let unvaled = marked.unval().unwrap(); - println!("Parsed unvaled that is {}", unvaled); - let (bctx, ped) = partial_eval(bctx, dctx, unvaled, true).unwrap(); - let result = eval(root_env(), parsed_input); - println!("Result is {} - {:?}", result, result); -} - diff --git a/kr/src/pe_ast.rs b/kr/src/pe_ast.rs deleted file mode 100644 index 3ed2426..0000000 --- a/kr/src/pe_ast.rs +++ /dev/null @@ -1,1493 +0,0 @@ -use std::fmt; -use std::rc::Rc; -use std::convert::From; -use std::collections::{BTreeSet,BTreeMap,HashMap,hash_map::DefaultHasher}; -use std::hash::{Hash,Hasher}; -use std::result; -use std::iter; - -use crate::ast::{root_env,Form}; - -use anyhow::{anyhow, bail, Result, Context}; - - -fn massoc(k: &str, v: Rc, l: Rc) -> Rc { - MarkedForm::new_pair( - MarkedForm::new_pair( - Rc::new(MarkedForm::Symbol(k.to_owned())), - v), - l) -} - -/** - * Now, split into head | tails - * where things from head are guarenteed to progress, and tails are later possibly needed values - * for calculation of ok_to_return etc - * - * also, under_fake_if_in_body | under_fake_body - * the DEnv under_fake_body prevents additional fake calls - * the DEnv under_fake_if_in_body prevents normal calls in addition to fake calls - * - * These mark if that stopped it, and thus progress can proceede if it's not a subset of the current ones - * They are stripped by the inciting fake body / if (what if there are more than one?) - * HOW TO KNOW WHICH INCITING IF? Oh duh it's a recursive partial-eval call just keep track at the callsite - * - * True represented as an id? 0? - * Runtime represented as an id? -1? - * - * Attempted Calls are marked with what was needed by their final body, no need for attempted - * (though if the calls were to generate it live, I suppose it could be, but I don't think there's - * any need - maybe for when p-eing params even though you know the call can't progress. I think - * this should just be an option) - * - * Errors - 2 types - * actual error - propegate up with context - * can't progress - MoreNeeded error with ID. Caught by the wrapper for re-creation? - * wait can it even be re-created? - * maybe we just legit need all that error handling - * - * for prim calls it can be recreated, it's just the prim call. - * that's a common enough case (well, actually, is it just eval and debug anyway? - ALSO the parameter-unval-peval mapping in calling) - * everything else normally has enough given their wrap level to - * either be a real error or return progress - * *maybe* assert needs special handling? Maybe just for error propagation (stopping there for post?)? - * - * combiner_return_ok can be cast entirely as an ID check - * - * the curent basic drop_redundent_eval is also just checking combiner_return_ok(x,None) to make - * sure isn't a suspended_symbol which doesn't have it's ID yet, but that doesn't matter? - * also it could be done with an ID=True check? (which would be broader, I guess, but about as legit anyway which is none at all) - * WAIT the current one is checking return_ok(x, None) OR e == e - * that can't be right, surely it'd be return_ok(x, e.id) - * oh e.id doesn't exist? I think I've gotten it backwards. - * It can removed anyway, as values would eval away - * non values that would be looked up in the upper env are itneresting, as I don't think we can tell... - * wait no it's always ok to unwrap suspended_eval unless there is a True remaining - * the Env or the subvalue would have been captured via partial eval - * ALSO UNLESS BELOW - * - * Also, I think it can only have a true if it hasn't been evaluated yet - * technically, the env could end in a suspended-param or suspended-env - * make sure the lookup accounts for that, that's a *WEIRD* one - * can't unwrap if it ends in a lookup, & that lookup ID is contained in the body - * - * ALL THE ENV reasoning only holds if ENVs are just cons chains with supsended params or suspended env params - * - * suspended if needs special gating head|tail attention - * mainly if rec-stopped, cond & rec takes head, relegating rest - * - * for suspended calls, the rec_mapping function needs to differentiate between a parameter - * failing because of an error and failing because of a needed ID - * it will also note if map_error hits a non-cons/nil, which means the entire leve of eval needs to be abandoned - * since it won't be able to recurse in - * BUT it should allow car ID errors and continue - * OH should it? wait where would an ID error even come from? - * that's not a generally allowed error - * true Errors should propegate up - * - * it's a bit trickey! - * The result of a DeriCall's IDs, if not a value, needs to become (part of, depending on if non-val parameters are allowed) the SuspendedCall's head IDs - * ditto for rec-stop, but the call-under bit - * - * -* -* -* THE NEW INVARIENT -* it's in heads if it can possibly be put forwards -* it only can't if it's been blocked by a call or if rec stopper -* and in those cases, ENV is saved on the node -* SO True should never really be left after evaluation -* and any node is always evaluated as far as it can be before being returned - */ - -// 0 is equiv of true, -1 is equiv to runtime -#[derive(Debug, Clone, Hash, Eq, PartialEq, Ord, PartialOrd)] -pub struct EnvID(i32); -const runtime_id: EnvID = EnvID(-1); -const true_id: EnvID = EnvID(0); - -#[derive(Debug, Clone, Hash, Eq, PartialEq)] -pub struct NeededIds { - heads: BTreeSet, - tails: BTreeSet, - - body_stopped: BTreeSet, - if_stopped: BTreeSet, -} -impl fmt::Display for NeededIds { - fn fmt(&self, f: &mut fmt::Formatter<'_>) -> fmt::Result { - if self.heads.is_empty() && self.tails.is_empty() && self.body_stopped.is_empty() && self.if_stopped.is_empty() { - write!(f, "NeedsNone"); - } else { - write!(f, "Needs"); - if !self.heads.is_empty() { - write!(f, "H{:?}", self.heads); - } - if !self.tails.is_empty() { - write!(f, "T{:?}", self.tails); - } - if !self.body_stopped.is_empty() { - write!(f, "B{:?}", self.body_stopped); - } - if !self.if_stopped.is_empty() { - write!(f, "I{:?}", self.if_stopped); - } - } - Ok(()) - } -} - -impl NeededIds { - fn new_true() -> Self { NeededIds { heads: iter::once(true_id).collect(), tails: BTreeSet::new(), body_stopped: BTreeSet::new(), if_stopped: BTreeSet::new() } } - fn new_none() -> Self { NeededIds { heads: BTreeSet::new(), tails: BTreeSet::new(), body_stopped: BTreeSet::new(), if_stopped: BTreeSet::new() } } - fn new_single(i: EnvID) -> Self { NeededIds { heads: iter::once(i).collect(), tails: BTreeSet::new(), body_stopped: BTreeSet::new(), if_stopped: BTreeSet::new() } } - fn union(&self, other: &NeededIds) -> Self { - NeededIds { - heads: self.heads.union(&other.heads).cloned().collect(), - tails: self.tails.union(&other.tails).cloned().collect(), - body_stopped: self.body_stopped.union(&other.body_stopped).cloned().collect(), - if_stopped: self.if_stopped.union(&other.if_stopped).cloned().collect(), - } - } - //fn union_without(&self, other: &NeededIds, without: &EnvID) -> Self { - //NeededIds { - //heads: self.heads.union(&other.heads) .filter(|x| *x != without).cloned().collect(), - //tails: self.tails.union(&other.tails) .filter(|x| *x != without).cloned().collect(), - //body_stopped: self.body_stopped.union(&other.body_stopped).filter(|x| *x != without).cloned().collect(), - //if_stopped: self.if_stopped.union(&other.if_stopped) .filter(|x| *x != without).cloned().collect(), - //} - //} - fn without(&self, without: &EnvID) -> Self { - NeededIds { - heads: self.heads.iter() .filter(|x| *x != without).cloned().collect(), - tails: self.tails.iter() .filter(|x| *x != without).cloned().collect(), - body_stopped: self.body_stopped.iter().filter(|x| *x != without).cloned().collect(), - if_stopped: self.if_stopped.iter() .filter(|x| *x != without).cloned().collect(), - } - } - fn union_into_tail(&self, other: &NeededIds, without_tail: Option<&EnvID>) -> Self { - let new_tails = other.heads.union(&other.tails).filter(|x| without_tail.is_none() || *x != without_tail.unwrap()); - let tails: BTreeSet = self.tails.iter().chain(new_tails).cloned().collect(); - assert!(!tails.contains(&true_id)); - NeededIds { - heads: self.heads.clone(), - tails: tails, - body_stopped: self.body_stopped.clone(), - if_stopped: self.if_stopped.clone(), - } - } - fn add_body_under(&self, u: EnvID) -> Self { - let body_with_id = self.body_stopped.iter().cloned().chain(iter::once(u)).collect(); - if self.heads.contains(&true_id) { - NeededIds { - heads: self.heads.iter().filter(|x| **x != true_id).cloned().collect(), - tails: self.tails.clone(), - body_stopped: body_with_id, - if_stopped: self.if_stopped.clone(), - } - } else { - NeededIds { - heads: self.heads.clone(), - tails: self.tails.clone(), - body_stopped: body_with_id, - if_stopped: self.if_stopped.clone(), - } - } - } - fn add_if_under(&self, u: EnvID) -> Self { - let if_with_id = self.if_stopped.iter().cloned().chain(iter::once(u)).collect(); - if self.heads.contains(&true_id) { - NeededIds { - heads: self.heads.iter().filter(|x| **x != true_id).cloned().collect(), - tails: self.tails.clone(), - body_stopped: self.body_stopped.clone(), - if_stopped: if_with_id, - } - } else { - NeededIds { - heads: self.heads.clone(), - tails: self.tails.clone(), - body_stopped: self.body_stopped.clone(), - if_stopped: if_with_id, - } - } - } - fn may_contain_id(&self, i: &EnvID) -> bool { - self.heads.contains(i) || self.tails.contains(i) - } - fn contains_if_stop(&self, i: &EnvID) -> bool { - self.if_stopped.contains(i) - } -} - -// 0 is equiv of true, -1 is equiv to runtime -#[derive(Clone)] -pub struct BCtx { - id_counter: i32, - memo: HashMap, (BTreeSet<(u64,u64,EnvID)>, Option, Rc)>, - used_ids: Vec<(bool,BTreeSet)>, -} -impl BCtx { - pub fn new_id(mut self) -> (Self, EnvID) { - let new_id = EnvID(self.id_counter); - self.id_counter += 1; - (self, new_id) - } - pub fn set_uses_env(mut self, x: bool) -> Self { - self.used_ids.last_mut().unwrap().0 = x; - self - } - pub fn get_uses_env(&self) -> bool { - self.used_ids.last().unwrap().0 - } - pub fn pop_uses_env(mut self) -> Self { - if let Some(last) = self.used_ids.last_mut() { - last.0 = false; - } - self - } - pub fn add_id(mut self, x: EnvID) -> Self { - self.used_ids.last_mut().unwrap().1.insert(x); - self - } - pub fn pop_id_frame(mut self, x: &EnvID) -> Self { - if let Some(last) = self.used_ids.last_mut() { - last.1.remove(x); - } - self - } - pub fn push_used_ids(mut self) -> Self { - self.used_ids.push((false, BTreeSet::new())); - self - } - pub fn pop_used_ids(mut self) -> (Self, (bool,BTreeSet)) { - let to_ret = self.used_ids.pop().unwrap(); - if let Some(last) = self.used_ids.last_mut() { - last.0 = last.0 || to_ret.0; - last.1.extend(to_ret.1.iter().cloned()); - } - (self, to_ret) - } -} - -enum PushFrameResult { - Ok(DCtx), - UnderBody(EnvID), - UnderIf(EnvID), -} - -fn calculate_hash(t: &T) -> u64 { - let mut s = DefaultHasher::new(); - t.hash(&mut s); - s.finish() -} -// memo is only for recording currently executing hashes (calls and if's, current for us) -// only_head is not currently used -#[derive(Clone)] -pub struct DCtx { - e : Rc, - current_id: Option, - sus_env_stack: Rc>>, - sus_prm_stack: Rc>>, - real_set: Rc>, - fake_set: Rc>, - fake_if_set: Rc>, - ident: usize, -} -impl DCtx { - pub fn real_hash_set(&self, relevant: Option>) -> BTreeSet<(u64,u64,EnvID)> { - self.real_set.iter().filter(|x| relevant.as_ref().map_or(true, |s| s.contains(x))) - .map(|id| (calculate_hash(&self.sus_env_stack.get(id)), - calculate_hash(&self.sus_prm_stack.get(id)), - id.clone())).collect() - } - pub fn copy_set_env(&self, e: &Rc) -> Self { - DCtx { e: Rc::clone(e), current_id: self.current_id.clone(), - sus_env_stack: Rc::clone(&self.sus_env_stack), sus_prm_stack: Rc::clone(&self.sus_prm_stack), - real_set: Rc::clone(&self.real_set), fake_set: Rc::clone(&self.fake_set), fake_if_set: Rc::clone(&self.fake_if_set), ident: self.ident+1 } - } - fn copy_push_frame(&self, id: EnvID, se: &Rc, de: &Option, e: Option>, - rest_params: &Option, prms: Option>, body: &Rc) -> PushFrameResult { - let mut sus_env_stack = Rc::clone(&self.sus_env_stack); - let mut sus_prm_stack = Rc::clone(&self.sus_prm_stack); - let mut real_set = (*self.real_set).clone(); - let mut fake_set = (*self.fake_set).clone(); - if self.fake_if_set.contains(&id) { - //println!("Fake if real rec stopper"); - return PushFrameResult::UnderIf(id); - } - if (e.is_some() && prms.is_some()) { - real_set.insert(id.clone()); - // We're not actually not under fake still! - //fake_set.remove(&id); - } else { - if fake_set.contains(&id) { - //println!("Fake body rec stopper"); - return PushFrameResult::UnderBody(id.clone()); - } - fake_set.insert(id.clone()); - real_set.remove(&id); - } - let inner_env = if let Some(de) = de { - let de_val = if let Some(e) = e { - Rc::make_mut(&mut sus_env_stack).insert(id.clone(), Rc::clone(&e)); - e - } else { - Rc::make_mut(&mut sus_env_stack).remove(&id); - MarkedForm::new_suspended_env_lookup(Some(de.clone()), id.clone()) - }; - massoc(de, de_val, Rc::clone(se)) - } else { Rc::clone(se) }; - // not yet supporting sequence params - let inner_env = if let Some(p) = rest_params { - let p_val = if let Some(prms) = prms { - Rc::make_mut(&mut sus_prm_stack).insert(id.clone(), Rc::clone(&prms)); - prms - } else { - Rc::make_mut(&mut sus_prm_stack).remove(&id); - MarkedForm::new_suspended_param_lookup(Some(p.clone()), id.clone(), 0, false, false) - }; - massoc(p, p_val, inner_env) - } else { inner_env }; - PushFrameResult::Ok(DCtx { e: inner_env, current_id: Some(id), sus_env_stack, sus_prm_stack, - real_set: Rc::new(real_set), fake_set: Rc::new(fake_set), fake_if_set: Rc::clone(&self.fake_if_set), ident: self.ident+1 }) - } - pub fn copy_push_fake_if(&self) -> (Option, Self) { - let (could_stop, new_fake_if_set) = if let Some(current_id) = self.current_id.as_ref() { - let mut x = (*self.fake_if_set).clone(); - let could_stop = if !x.contains(current_id) { Some(current_id.clone()) } else { None }; - x.insert(current_id.clone()); - (could_stop, Rc::new(x)) - } else { (None, Rc::clone(&self.fake_if_set)) }; - (could_stop, DCtx { e: Rc::clone(&self.e), current_id: self.current_id.clone(), sus_env_stack: Rc::clone(&self.sus_env_stack), sus_prm_stack: Rc::clone(&self.sus_prm_stack), - real_set: Rc::clone(&self.real_set), fake_set: Rc::clone(&self.fake_set), fake_if_set: new_fake_if_set, ident: self.ident+1 }) - } - - //pub fn can_progress(&self, ids: NeededIds) -> bool { - pub fn can_progress(&self, x: &Rc) -> bool { - let ids = x.ids(); - // check if ids is true || ids intersection EnvIDs in our stacks is non empty || ids.hashes - current is non empty - let all_needed: BTreeSet = ids.heads.union(&ids.tails).filter(|x| **x != true_id).cloned().collect(); - let all_possible: BTreeSet = self.real_set.union(&self.fake_set).cloned().collect(); - let ok = all_possible.is_superset(&all_needed); - if !ok { - println!("Gah - needed {:?}", all_needed); - println!("Gah - have total (fake and real) {:?}", all_possible); - println!("it: {}", x); - } - assert!(ok); - ids.heads.contains(&true_id) || !self.real_set.is_disjoint(&ids.heads) || !self.fake_set.is_superset(&ids.body_stopped) || !self.fake_if_set.is_superset(&ids.if_stopped) - } -} - -pub fn new_base_ctxs() -> (BCtx,DCtx) { - let bctx = BCtx { id_counter: true_id.0 + 1, memo: HashMap::new(), used_ids: vec![] }; - let (bctx, root_env) = mark(root_env(), bctx); - (bctx, DCtx { e: root_env, current_id: None, sus_env_stack: Rc::new(BTreeMap::new()), sus_prm_stack: Rc::new(BTreeMap::new()), - real_set: Rc::new(BTreeSet::new()), fake_set: Rc::new(BTreeSet::new()), fake_if_set: Rc::new(BTreeSet::new()), ident: 0 } ) -} -impl Hash for MarkedForm { - fn hash(&self, state: &mut H) { - match self { - MarkedForm::Nil => { "Nil".hash(state); }, - MarkedForm::Int(i) => { "Int".hash(state); i.hash(state); }, - MarkedForm::Bool(b) => { "Bool".hash(state); b.hash(state); }, - MarkedForm::Symbol(s) => { "Symbol".hash(state); s.hash(state); }, - - MarkedForm::Pair(hash, ids, car, cdr) => { hash.hash(state); }, - MarkedForm::SuspendedSymbol(hash, env, name) => { hash.hash(state); }, - MarkedForm::SuspendedParamLookup { hash, .. } => { hash.hash(state); }, - MarkedForm::SuspendedEnvLookup { hash, .. } => { hash.hash(state); }, - MarkedForm::SuspendedPair { hash, .. } => { hash.hash(state); }, - MarkedForm::SuspendedEnvEval { hash, .. } => { hash.hash(state); }, - MarkedForm::SuspendedIf { hash, .. } => { hash.hash(state); }, - MarkedForm::DeriComb { hash, .. } => { hash.hash(state); }, - MarkedForm::PrimComb { name, .. } => { "PrimComb".hash(state); name.hash(state); }, - } - } -} -#[derive(Debug, Clone, Eq, PartialEq)] -pub enum MarkedForm { - Nil, - Int(i32), - Bool(bool), - Symbol(String), - Pair(u64, NeededIds, Rc, Rc), - - SuspendedSymbol(u64, Option>, String), // Needs IDs if Env chains into suspended - SuspendedParamLookup { hash: u64, name: Option, id: EnvID, cdr_num: i32, car: bool, evaled: bool }, - SuspendedEnvLookup { hash: u64, name: Option, id: EnvID }, - SuspendedPair { hash: u64, ids: NeededIds, env: Option>, car: Rc, cdr: Rc, attempted: Option, under_if: Option}, - - SuspendedEnvEval { hash: u64, ids: NeededIds, x: Rc, e: Rc }, - SuspendedIf { hash: u64, ids: NeededIds, id_env: Option<(EnvID,Rc)>, c: Rc, t: Rc, e: Rc }, - - PrimComb { name: String, nonval_ok: bool, takes_de: bool, wrap_level: i32, f: fn(BCtx,DCtx,Rc) -> Result<(BCtx,Rc)> }, - DeriComb { hash: u64, lookup_name: Option, ids: NeededIds, se: Rc, de: Option, id: EnvID, wrap_level: i32, - sequence_params: Vec, rest_params: Option, body: Rc }, -} -impl MarkedForm { - pub fn new_suspended_symbol(e: Option>, name: String) -> Rc { - Rc::new(MarkedForm::SuspendedSymbol(calculate_hash(&("SuspendedSymbol", &e, &name)), e, name)) - } - pub fn new_suspended_param_lookup(name: Option, id: EnvID, cdr_num: i32, car: bool, evaled: bool) -> Rc { - Rc::new(MarkedForm::SuspendedParamLookup { hash: calculate_hash(&("SuspendedParamLookup", &name, &id, &cdr_num, &car, &evaled)), name, id, cdr_num, car, evaled }) - } - pub fn new_suspended_env_lookup(name: Option, id: EnvID) -> Rc { - Rc::new(MarkedForm::SuspendedEnvLookup { hash: calculate_hash(&("SuspendedEnvLookup", &name, &id)), name, id }) - } - pub fn new_suspended_if(id_env: Option<(EnvID,Rc)>, c: Rc, t: Rc, e: Rc) -> Rc { - // if either t or e stopped because of our fake if (SO CHECK IF IT WAS US AT PUSH TIME), - // guard on our condition with that branch in tail - let c_ids = c.ids(); - let t_ids = t.ids(); - let e_ids = e.ids(); - - // and if we had an if_stop, we grab env - let mut n_id_env = None; - let ids = if let Some((this_id, maybe_env)) = id_env { - let ids = if t_ids.contains_if_stop(&this_id) { - n_id_env = Some((this_id.clone(), Rc::clone(&maybe_env))); - c_ids.union_into_tail(&t_ids, Some(&true_id)).union(&maybe_env.ids()) - } else { c_ids.union(&t_ids) }; - if e_ids.contains_if_stop(&this_id) { - n_id_env = Some((this_id, Rc::clone(&maybe_env))); - ids.union_into_tail(&e_ids, Some(&true_id)).union(&maybe_env.ids()) - } else { ids.union(&e_ids) } - } else { - c_ids.union(&t_ids).union(&e_ids) - }; - Rc::new(MarkedForm::SuspendedIf { hash: calculate_hash(&("SuspendedIf", &ids, &n_id_env, &c, &t, &e)), ids, id_env: n_id_env, c, t, e }) - } - pub fn new_suspended_env_eval(x: Rc, e: Rc) -> Rc { - let ids = if e.is_legal_env_chain().unwrap_or(true) { - e.ids().union(&x.ids()) - } else { - e.ids().union_into_tail(&x.ids(), Some(&true_id)) - }; - Rc::new(MarkedForm::SuspendedEnvEval { hash: calculate_hash(&("SuspendedEnvEval", &ids, &x, &e)), ids, x, e }) - } - pub fn new_pair(car: Rc, cdr: Rc) -> Rc { - let new_ids = car.ids().union(&cdr.ids()); - Rc::new(MarkedForm::Pair(calculate_hash(&("SuspendedPair", &car, &cdr)), new_ids, car, cdr)) - } - pub fn new_suspended_pair(env: Option>, attempted: Option, car: Rc, cdr: Rc, under_if: Option) -> Rc { - // differentiate between call and if rec_under - let ids = car.ids().union(&cdr.ids()); - let ids = if let Some(attempted) = &attempted { - //attempted.union_into_tail(&ids, if env.is_some() || attempted.may_contain_id(&true_id) { Some(&true_id) } else { None }) - ids.union(attempted) - } else { - ids - }; - let ids = if let Some(rec_under) =&under_if { ids.add_if_under(rec_under.clone()) } else { ids }; - let ids = if let Some(env) =&env { ids.union(&env.ids()) } else { ids }; - - Rc::new(MarkedForm::SuspendedPair{ hash: calculate_hash(&("SuspendedPair", &ids, &env, &car, &cdr, &attempted, &under_if)), ids, env, car, cdr, attempted, under_if }) - } - fn new_raw_deri_comb(lookup_name: Option, ids: NeededIds, se: Rc, de: Option, id: EnvID, wrap_level: i32, - sequence_params: Vec, rest_params: Option, body: Rc) -> Rc { - Rc::new(MarkedForm::DeriComb { hash: calculate_hash(&("DeriComb", &lookup_name, &ids, &se, &de, &id, &wrap_level, &sequence_params, &rest_params, &body)), lookup_name, ids, se, de, id, wrap_level, sequence_params, rest_params, body }) - } - pub fn new_deri_comb(se: Rc, lookup_name: Option, de: Option, id: EnvID, wrap_level: i32, sequence_params: Vec, rest_params: Option, body: Rc, rec_under: Option) -> Rc { - // HERE! Body ids might cause it to want to evaluate but it won't if SE isn't a legal env - // do we ever need body ids except for true? - // and can we remove se at some point? - //let ids = if !se.is_legal_env_chain().unwrap() { se.ids() } else { se.ids().union_without(&body.ids(), &id) }; - //let ids = if body.ids().may_contain_id(&true_id) { se.ids().union(&NeededIds::new_true()) } else { se.ids() }; - let ids = if !se.is_legal_env_chain().unwrap() { se.ids().union_into_tail(&body.ids(), Some(&id)) } else { se.ids().union(&body.ids().without(&id)) }; - let ids = if let Some(rec_under) = rec_under { - ids.add_body_under(rec_under) - } else { - ids - }; - MarkedForm::new_raw_deri_comb(lookup_name, ids, se, de, id, wrap_level, sequence_params, rest_params, body) - } - pub fn tag_name(self: &Rc, new_name: &str) -> Rc { - match &**self { - MarkedForm::DeriComb { hash, lookup_name, ids, se, de, id, wrap_level, sequence_params, rest_params, body } => - MarkedForm::new_raw_deri_comb(Some(new_name.to_owned()), ids.clone(), se.clone(), de.clone(), id.clone(), *wrap_level, sequence_params.clone(), rest_params.clone(), Rc::clone(body)), - MarkedForm::SuspendedParamLookup { hash, name, id, cdr_num, car, evaled } => MarkedForm::new_suspended_param_lookup(Some(new_name.to_owned()), id.clone(), *cdr_num, *car, *evaled), - _ => Rc::clone(self), - } - } - pub fn wrap_level(&self) -> Option { - match self { - MarkedForm::PrimComb { wrap_level, .. } => Some(*wrap_level), - MarkedForm::DeriComb { wrap_level, .. } => Some(*wrap_level), - _ => None, - } - } - pub fn decrement_wrap_level(&self) -> Option> { - match self { - MarkedForm::PrimComb { name, nonval_ok, takes_de, wrap_level, f } => Some(Rc::new(MarkedForm::PrimComb { name: name.clone(), nonval_ok: *nonval_ok, takes_de: *takes_de, wrap_level: wrap_level-1, f: *f })), - MarkedForm::DeriComb { hash, lookup_name, ids, se, de, id, wrap_level, sequence_params, rest_params, body } => - Some(MarkedForm::new_raw_deri_comb(lookup_name.clone(), ids.clone(), Rc::clone(se), de.clone(), id.clone(), *wrap_level-1, sequence_params.clone(), rest_params.clone(), Rc::clone(body))), - - _ => None, - } - } - pub fn ids(&self) -> NeededIds { - match self { - MarkedForm::Nil => NeededIds::new_none(), - MarkedForm::Int(i) => NeededIds::new_none(), - MarkedForm::Bool(b) => NeededIds::new_none(), - MarkedForm::Symbol(s) => NeededIds::new_none(), - MarkedForm::Pair( hash,ids,car,cdr) => ids.clone(), - MarkedForm::SuspendedSymbol( hash,sus, name) => if let Some(sus) = sus { sus.ids() } else { NeededIds::new_true() }, - MarkedForm::SuspendedEnvLookup { id, .. } => NeededIds::new_single(id.clone()), - MarkedForm::SuspendedParamLookup { id, .. } => NeededIds::new_single(id.clone()), - MarkedForm::SuspendedEnvEval { ids, ..} => ids.clone(), - MarkedForm::SuspendedIf { ids, ..} => ids.clone(), - MarkedForm::SuspendedPair{ ids, .. } => ids.clone(), - MarkedForm::PrimComb { .. } => NeededIds::new_none(), - MarkedForm::DeriComb { ids, .. } => ids.clone(), - } - } - // note, this can be entirely ID based, but this should be more efficient - pub fn is_value(&self) -> bool { - let ids = match self { - MarkedForm::Nil => return true, - MarkedForm::Int(i) => return true, - MarkedForm::Bool(b) => return true, - MarkedForm::Symbol(s) => return true, - MarkedForm::SuspendedSymbol( hash,sus, name) => return false, - MarkedForm::SuspendedEnvLookup { id, .. } => return false, - MarkedForm::SuspendedParamLookup { id, .. } => return false, - MarkedForm::SuspendedEnvEval { ids, ..} => return false, - MarkedForm::SuspendedIf { ids, ..} => return false, - MarkedForm::SuspendedPair{ ids, .. } => return false, - MarkedForm::PrimComb { .. } => return true, - MarkedForm::Pair( hash,ids,car,cdr) => ids.clone(), - MarkedForm::DeriComb { ids, .. } => ids.clone(), - }; - ids.heads.is_empty() && ids.tails.is_empty() - } - pub fn is_pair(&self) -> bool { - match self { - MarkedForm::Pair( hash,ids,car,cdr) => true, - _ => false, - } - } - pub fn is_suspended_param(&self) -> bool { - match self { - MarkedForm::SuspendedParamLookup { .. } => true, - _ => false, - } - } - pub fn is_suspended_env(&self) -> bool { - match self { - MarkedForm::SuspendedEnvLookup { .. } => true, - _ => false, - } - } - pub fn unval(self: &Rc) -> Result> { - match &**self { - MarkedForm::Nil => Ok(Rc::clone(self)), - MarkedForm::Int(i) => Ok(Rc::clone(self)), - MarkedForm::Bool(b) => Ok(Rc::clone(self)), - MarkedForm::Symbol(s) => Ok(MarkedForm::new_suspended_symbol(None, s.clone())), - MarkedForm::Pair( hash,ids,car,cdr) => Ok(MarkedForm::new_suspended_pair(None, Some(NeededIds::new_true()), car.unval()?, Rc::clone(cdr), None)), - MarkedForm::SuspendedSymbol( hash,sus, name) => bail!("trying to unval a suspended symbol"), - MarkedForm::SuspendedEnvLookup { .. } => bail!("trying to unval a suspended env lookup"), - MarkedForm::SuspendedParamLookup { .. } => bail!("trying to unval a suspended param lookup"), - MarkedForm::SuspendedEnvEval { .. } => bail!("trying to unval a suspended env eval"), - MarkedForm::SuspendedIf { .. } => bail!("trying to unval a suspended if"), - MarkedForm::SuspendedPair{ ids, .. } => bail!("trying to unval a suspended pair"), - MarkedForm::PrimComb { .. } => Ok(Rc::clone(self)), - MarkedForm::DeriComb { .. } => Ok(Rc::clone(self)), - } - } - pub fn is_legal_env_chain(&self) -> Result { - let res = match self { - MarkedForm::Nil => Ok(true), - MarkedForm::Pair( hash,ids,car,cdr) => { - match &**car { - MarkedForm::Pair( hash,idsp,carp,cdrp) => { - match &**cdrp { - MarkedForm::SuspendedSymbol( hash,sus, name) => Ok(false), - MarkedForm::SuspendedEnvEval { .. } => Ok(false), - MarkedForm::SuspendedIf { .. } => Ok(false), - MarkedForm::SuspendedPair{ ids, .. } => Ok(false), - _ => Ok(carp.is_sym() && cdr.is_legal_env_chain()?), - } - }, - _ => Ok(false) - } - }, - - // maybe these should be legal? - MarkedForm::SuspendedEnvLookup { .. } => Ok(true), - MarkedForm::SuspendedParamLookup { .. } => Ok(false), - - MarkedForm::SuspendedSymbol( hash,sus, name) => Ok(false), - MarkedForm::SuspendedEnvEval { .. } => Ok(false), - MarkedForm::SuspendedIf { .. } => Ok(false), - MarkedForm::SuspendedPair{ ids, .. } => Ok(false), - - MarkedForm::Int(i) => bail!("bad env {}", self), - MarkedForm::Bool(b) => bail!("bad env {}", self), - MarkedForm::Symbol(s) => bail!("bad env {}", self), - MarkedForm::PrimComb { .. } => bail!("bad env {}", self), - MarkedForm::DeriComb { .. } => bail!("bad env {}", self), - }; - //println!("I was legal {:?} - {}", res, self); - res - } - pub fn truthy(&self) -> Result { - match self { - MarkedForm::Nil => Ok(false), - MarkedForm::Int(i) => Ok(true), - MarkedForm::Bool(b) => Ok(*b), - MarkedForm::Symbol(s) => Ok(true), - MarkedForm::Pair( hash,ids,car,cdr) => Ok(true), - MarkedForm::SuspendedSymbol( hash,sus, name) => bail!("trying to truthy a suspended symbol"), - MarkedForm::SuspendedEnvLookup { .. } => bail!("trying to truthy a suspended env lookup"), - MarkedForm::SuspendedParamLookup { .. } => bail!("trying to truthy a suspended param lookup"), - MarkedForm::SuspendedEnvEval { .. } => bail!("trying to truthy a suspended env eval"), - MarkedForm::SuspendedIf { .. } => bail!("trying to truthy a suspended if"), - MarkedForm::SuspendedPair{ ids, .. } => bail!("trying to truthy a suspended pair"), - MarkedForm::PrimComb { .. } => Ok(true), - MarkedForm::DeriComb { .. } => Ok(true), - } - } - pub fn is_sym(&self) -> bool { - match self { - MarkedForm::Symbol(s) => true, - _ => false, - } - } - pub fn sym(&self) -> Result<&str> { - match self { - MarkedForm::Symbol(s) => Ok(s), - _ => bail!("not a symbol"), - } - } - pub fn int(&self) -> Result { - match self { - MarkedForm::Int(i) => Ok(*i), - _ => bail!("not a int"), - } - } - pub fn car(&self) -> Result> { - match self { - MarkedForm::Pair(h,ids,car,cdr) => Ok(Rc::clone(car)), - MarkedForm::SuspendedParamLookup { hash, name, id, cdr_num, car, evaled } if !car && !evaled => Ok(MarkedForm::new_suspended_param_lookup(name.clone(), id.clone(), - *cdr_num, true, false)), - _ => bail!("not a pair for car: {}", self), - } - } - pub fn cdr(&self) -> Result> { - match self { - MarkedForm::Pair(h,ids,car,cdr) => Ok(Rc::clone(cdr)), - MarkedForm::SuspendedParamLookup { hash, name, id, cdr_num, car, evaled } if !car && !evaled => Ok(MarkedForm::new_suspended_param_lookup(name.clone(), id.clone(), - *cdr_num+1, *car, false)), - _ => bail!("not a pair for cdr: {}", self), - } - } -} -fn make_eval_prim(wrap_level: i32) -> Rc { - Rc::new(MarkedForm::PrimComb { name: "eval".to_owned(), nonval_ok: true, takes_de: false, wrap_level, f: eval_func }) -} -fn eval_func(bctx: BCtx, dctx: DCtx, p: Rc) -> Result<(BCtx,Rc)> { - //println!("Ok, this is inside eval looking at {}", p); - let x = p.car()?; - let e = p.cdr()?.car()?; - if !x.is_value() { - //println!("Checking compatability"); - if let (MarkedForm::SuspendedParamLookup { name, id, cdr_num, car, evaled: false, .. }, MarkedForm::SuspendedEnvLookup { name: oname, id: oid, .. }) = (&*x, &*e) { - if id == oid { - return Ok((bctx, MarkedForm::new_suspended_param_lookup(name.clone(), id.clone(), *cdr_num, *car, true))); - } - } - Ok((bctx, MarkedForm::new_suspended_pair( None, Some(x.ids()), make_eval_prim(0), p, None ))) - } else { - //println!("Ok, returning new suspended env eval with"); - //println!("\t{} {}", p.car()?.unval()?, p.cdr()?.car()?); - Ok((bctx, MarkedForm::new_suspended_env_eval(x.unval()?, e))) - } -} - - -// Implement the suspended param / suspended env traversal -fn make_cons_prim(wrap_level: i32) -> Rc { - Rc::new(MarkedForm::PrimComb { name: "cons".to_owned(), nonval_ok: true, takes_de: false, wrap_level, f: cons_func}) -} -fn cons_func(bctx: BCtx, dctx: DCtx, p: Rc) -> Result<(BCtx,Rc)> { - // the non-vals we should allow are - // Also funcs with outstanding ids probs - // (value . SuspendedParam) - // ! maybe not!(value . SuspendedEnv) - // (value . pair) - // (pair . pair) - let h = p.car()?; - let t = p.cdr()?.car()?; - if !(h.is_value() || h.is_pair()) { - Ok((bctx, MarkedForm::new_suspended_pair(None, Some(h.ids()), make_cons_prim(0), p, None))) - } else if !(t.is_value() || t.is_pair() || t.is_suspended_param() || t.is_suspended_env()) { - Ok((bctx, MarkedForm::new_suspended_pair(None, Some(t.ids()), make_cons_prim(0), p, None))) - } else { - Ok((bctx, MarkedForm::new_pair(h, t))) - } -} -fn make_car_prim(wrap_level: i32)-> Rc { - Rc::new(MarkedForm::PrimComb { name: "car".to_owned(), nonval_ok: true, takes_de: false, wrap_level, f: car_func}) -} -fn car_func(bctx: BCtx, dctx: DCtx, p: Rc) -> Result<(BCtx,Rc)> { - let maybe_pair = p.car()?; - match maybe_pair.car() { - Ok(x) => Ok((bctx, x)), - Err(_) => Ok((bctx, MarkedForm::new_suspended_pair(None, Some(maybe_pair.ids()), make_car_prim(0), p, None))), - } -} -fn make_cdr_prim(wrap_level: i32) -> Rc { - Rc::new(MarkedForm::PrimComb { name: "cdr".to_owned(), nonval_ok: true, takes_de: false, wrap_level, f: cdr_func}) -} -fn cdr_func(bctx: BCtx, dctx: DCtx, p: Rc) -> Result<(BCtx,Rc)> { - let maybe_pair = p.car()?; - match maybe_pair.cdr() { - Ok(x) => Ok((bctx, x)), - Err(_) => Ok((bctx, MarkedForm::new_suspended_pair(None, Some(maybe_pair.ids()), make_cdr_prim(0), p, None))), - } -} - - -fn make_debug_prim() -> Rc { - Rc::new(MarkedForm::PrimComb { name: "debug".to_owned(), nonval_ok: false, takes_de: false, wrap_level: 1, f: debug_func}) -} -fn debug_func(bctx: BCtx, dctx: DCtx, p: Rc) -> Result<(BCtx,Rc)> { - // This one is a bit weird - we put the wrap level at 1 so both sides are pe'd, - // and then return runtime - // Hmm, I do wonder if it should capture ENV for debugging purposes - Ok((bctx, MarkedForm::new_suspended_pair( None, Some(NeededIds::new_single(runtime_id.clone())), make_debug_prim(), p, None ))) -} - -pub fn mark(form: Rc, bctx: BCtx) -> (BCtx, Rc) { - match &*form { - Form::Nil => (bctx, Rc::new(MarkedForm::Nil)), - Form::Int(i) => (bctx, Rc::new(MarkedForm::Int(*i))), - Form::Bool(b) => (bctx, Rc::new(MarkedForm::Bool(*b))), - Form::Symbol(s) => (bctx, Rc::new(MarkedForm::Symbol(s.clone()))), - Form::Pair(car, cdr) => { - let (bctx, car) = mark(Rc::clone(car),bctx); - let (bctx, cdr) = mark(Rc::clone(cdr),bctx); - (bctx, MarkedForm::new_pair(car, cdr)) - }, - Form::DeriComb { se, de, params, body } => { - panic!(); - }, - Form::PrimComb(name, _f) => { - (bctx, match &name[..] { - "vau" => Rc::new(MarkedForm::PrimComb { name: "vau".to_owned(), nonval_ok: false, takes_de: true, wrap_level: 0, f: |bctx, dctx, p| { - let de = p.car()?.sym().map(|s| s.to_owned()).ok(); - let params = p.cdr()?.car()?.sym()?.to_owned(); - let body = p.cdr()?.cdr()?.car()?.unval()?; - let se = Rc::clone(&dctx.e); - let bctx = bctx.set_uses_env(true); - let (bctx, id) = bctx.new_id(); - let wrap_level = 0; - let sequence_params = vec![]; - let rest_params = Some(params); - //println!("vau, making a new func {:?} - {}", id, p); - Ok((bctx, MarkedForm::new_deri_comb( se, None, de, id, wrap_level, sequence_params, rest_params, body, None ))) - }}), - "eval" => make_eval_prim(1), - "cons" => make_cons_prim(1), - "car" => make_car_prim(1), - "cdr" => make_cdr_prim(1), - "debug" => make_debug_prim(), - // Like Debug, listed as wrap_level 1 so bothe sides are pe'd, even though it would - // be sequencing at runtime - "assert" => Rc::new(MarkedForm::PrimComb { name: "assert".to_owned(), nonval_ok: false, takes_de: false, wrap_level: 1, f: |bctx, dctx, p| { - let cond = p.car()?; - if !cond.truthy()? { - bail!("Assertion failed {}", cond) - } - Ok((bctx, p.cdr()?.car()?)) - }}), - "if" => Rc::new(MarkedForm::PrimComb { name: "if".to_owned(), nonval_ok: false, takes_de: false, wrap_level: 0, f: |bctx, dctx, p| { - let c = p.car()?.unval()?; - let t = p.cdr()?.car()?.unval()?; - let e = p.cdr()?.cdr()?.car()?.unval()?; - Ok((bctx, MarkedForm::new_suspended_if(None, c, t, e))) - }}), - // Non val is actually fine - "quote" => Rc::new(MarkedForm::PrimComb { name: "quote".to_owned(), nonval_ok: true, takes_de: false, wrap_level: 0, f: |bctx, dctx, p| { - Ok((bctx, p.car()?)) - }}), - "=" => Rc::new(MarkedForm::PrimComb { name: "=".to_owned(), nonval_ok: false, takes_de: false, wrap_level: 1, f: |bctx, dctx, p| { - let a = p.car()?; - let b = p.cdr()?.car()?; - Ok((bctx, Rc::new(MarkedForm::Bool(a == b)))) - }}), - "<" => Rc::new(MarkedForm::PrimComb { name: "<".to_owned(), nonval_ok: false, takes_de: false, wrap_level: 1, f: |bctx, dctx, p| { - let a = p.car()?; - let b = p.cdr()?.car()?; - Ok((bctx, Rc::new(MarkedForm::Bool(a.int()? < b.int()?)))) - }}), - ">" => Rc::new(MarkedForm::PrimComb { name: ">".to_owned(), nonval_ok: false, takes_de: false, wrap_level: 1, f: |bctx, dctx, p| { - let a = p.car()?; - let b = p.cdr()?.car()?; - Ok((bctx, Rc::new(MarkedForm::Bool(a.int()? > b.int()?)))) - }}), - "<=" => Rc::new(MarkedForm::PrimComb { name: "<=".to_owned(), nonval_ok: false, takes_de: false, wrap_level: 1, f: |bctx, dctx, p| { - let a = p.car()?; - let b = p.cdr()?.car()?; - Ok((bctx, Rc::new(MarkedForm::Bool(a.int()? <= b.int()?)))) - }}), - ">=" => Rc::new(MarkedForm::PrimComb { name: ">=".to_owned(), nonval_ok: false, takes_de: false, wrap_level: 1, f: |bctx, dctx, p| { - let a = p.car()?; - let b = p.cdr()?.car()?; - Ok((bctx, Rc::new(MarkedForm::Bool(a.int()? >= b.int()?)))) - }}), - "+" => Rc::new(MarkedForm::PrimComb { name: "+".to_owned(), nonval_ok: false, takes_de: false, wrap_level: 1, f: |bctx, dctx, p| { - let a = p.car()?.int()?; - let b = p.cdr()?.car()?.int()?; - Ok((bctx, Rc::new(MarkedForm::Int(a + b)))) - }}), - "-" => Rc::new(MarkedForm::PrimComb { name: "-".to_owned(), nonval_ok: false, takes_de: false, wrap_level: 1, f: |bctx, dctx, p| { - let a = p.car()?.int()?; - let b = p.cdr()?.car()?.int()?; - Ok((bctx, Rc::new(MarkedForm::Int(a - b)))) - }}), - "*" => Rc::new(MarkedForm::PrimComb { name: "*".to_owned(), nonval_ok: false, takes_de: false, wrap_level: 1, f: |bctx, dctx, p| { - let a = p.car()?.int()?; - let b = p.cdr()?.car()?.int()?; - Ok((bctx, Rc::new(MarkedForm::Int(a * b)))) - }}), - "/" => Rc::new(MarkedForm::PrimComb { name: "/".to_owned(), nonval_ok: false, takes_de: false, wrap_level: 1, f: |bctx, dctx, p| { - let a = p.car()?.int()?; - let b = p.cdr()?.car()?.int()?; - Ok((bctx, Rc::new(MarkedForm::Int(a / b)))) - }}), - "%" => Rc::new(MarkedForm::PrimComb { name: "%".to_owned(), nonval_ok: false, takes_de: false, wrap_level: 1, f: |bctx, dctx, p| { - let a = p.car()?.int()?; - let b = p.cdr()?.car()?.int()?; - Ok((bctx, Rc::new(MarkedForm::Int(a % b)))) - }}), - "&" => Rc::new(MarkedForm::PrimComb { name: "&".to_owned(), nonval_ok: false, takes_de: false, wrap_level: 1, f: |bctx, dctx, p| { - let a = p.car()?.int()?; - let b = p.cdr()?.car()?.int()?; - Ok((bctx, Rc::new(MarkedForm::Int(a & b)))) - }}), - "|" => Rc::new(MarkedForm::PrimComb { name: "|".to_owned(), nonval_ok: false, takes_de: false, wrap_level: 1, f: |bctx, dctx, p| { - let a = p.car()?.int()?; - let b = p.cdr()?.car()?.int()?; - Ok((bctx, Rc::new(MarkedForm::Int(a | b)))) - }}), - "^" => Rc::new(MarkedForm::PrimComb { name: "^".to_owned(), nonval_ok: false, takes_de: false, wrap_level: 1, f: |bctx, dctx, p| { - let a = p.car()?.int()?; - let b = p.cdr()?.car()?.int()?; - Ok((bctx, Rc::new(MarkedForm::Int(a ^ b)))) - }}), - // This could allow nonval with fallback - "comb?" => Rc::new(MarkedForm::PrimComb { name: "comb?".to_owned(), nonval_ok: false, takes_de: false, wrap_level: 1, f: |bctx, dctx, p| { - Ok((bctx, Rc::new(MarkedForm::Bool(match &* p.car()? { - MarkedForm::PrimComb { .. } => true, - MarkedForm::DeriComb { .. } => true, - _ => false, - })))) - }}), - // This could allow nonval with fallback - "pair?" => Rc::new(MarkedForm::PrimComb { name: "pair?".to_owned(), nonval_ok: false, takes_de: false, wrap_level: 1, f: |bctx, dctx, p| { - Ok((bctx, Rc::new(MarkedForm::Bool(match &* p.car()? { - MarkedForm::Pair(_h, _i, _a,_b) => true, - _ => false, - })))) - }}), - "symbol?" => Rc::new(MarkedForm::PrimComb { name: "symbol?".to_owned(), nonval_ok: false, takes_de: false, wrap_level: 1, f: |bctx, dctx, p| { - Ok((bctx, Rc::new(MarkedForm::Bool(match &* p.car()? { - MarkedForm::Symbol(_) => true, - _ => false, - })))) - }}), - "int?" => Rc::new(MarkedForm::PrimComb { name: "int?".to_owned(), nonval_ok: false, takes_de: false, wrap_level: 1, f: |bctx, dctx, p| { - Ok((bctx, Rc::new(MarkedForm::Bool(match &* p.car()? { - MarkedForm::Int(_) => true, - _ => false, - })))) - }}), - // maybe bool? but also could be derived. Nil def - "bool?" => Rc::new(MarkedForm::PrimComb { name: "bool?".to_owned(), nonval_ok: false, takes_de: false, wrap_level: 1, f: |bctx, dctx, p| { - Ok((bctx, Rc::new(MarkedForm::Bool(match &* p.car()? { - MarkedForm::Bool(_) => true, - _ => false, - })))) - }}), - "nil?" => Rc::new(MarkedForm::PrimComb { name: "nil?".to_owned(), nonval_ok: false, takes_de: false, wrap_level: 1, f: |bctx, dctx, p| { - Ok((bctx, Rc::new(MarkedForm::Bool(match &* p.car()? { - MarkedForm::Nil => true, - _ => false, - })))) - }}), - _ => panic!("gah! don't have partial eval version of {}", name), - }) - }, - } -} - -pub fn combiner_return_ok(x: &Rc, check_id: Option) -> bool { - let ids = x.ids(); - !ids.may_contain_id(&true_id) && check_id.map(|check_id| !ids.may_contain_id(&check_id)).unwrap_or(true) -} - -pub fn partial_eval(bctx_in: BCtx, dctx: DCtx, form: Rc, use_memo: bool) -> Result<(BCtx,Rc)> { - let mut bctx = bctx_in.push_used_ids(); - let mut next_form = Some(Rc::clone(&form)); - let mut skipped_from: Option<(BCtx, DCtx, Rc)> = None; - let mut one04s = 0; - let mut last: Option> = None; - let mut doublings = 0; - loop { - let x = next_form.take().unwrap(); - println!("{:ident$}({})PE:", "", dctx.ident*4, ident=dctx.ident*4); - if dctx.ident*4 == 104 { - one04s += 1; - if one04s == 100_000 { - println!("{:ident$}({})PE: {}", "", dctx.ident*4, one04s, ident=dctx.ident*4); - println!("{:ident$}PE: {}", "", x, ident=dctx.ident*4); - assert!(false); - } - //println!("{:ident$}PE: {}", "", x, ident=dctx.ident*4); - } - if let Some(l) = last { - if x == l { - doublings += 1; - } else { - doublings = 0; - } - } else { - doublings = 0; - } - if doublings == 100 { - println!("100 doublings of {}", x); - println!("(because of {:?} with {:?}/{:?})", x.ids(), dctx.real_set, dctx.fake_set); - } - assert!(doublings < 100); - last = Some(Rc::clone(&x)); - //println!("{:ident$}PE: {}", "", x, ident=dctx.ident*4); - //if !dctx.can_progress(x.ids()) { - if !dctx.can_progress(&x) { - //println!("{:ident$}Shouldn't go! (because of {:?} with {:?}/{:?})", "", x.ids(), dctx.real_set, dctx.fake_set, ident=dctx.ident*4); - if !(x.is_value() || !dctx.fake_set.is_empty()) { - println!("Hmm what's wrong here - it's not a value, but our fake set is empty..."); - println!("{:ident$}{}", "", x, ident=dctx.ident*4); - println!("{:ident$}Shouldn't go! (because of {:?} with {:?}/{:?})", "", x.ids(), dctx.real_set, dctx.fake_set, ident=dctx.ident*4); - } - assert!(x.is_value() || !dctx.fake_set.is_empty()); - let (mut bctx, (uses_env, used_ids)) = bctx.pop_used_ids(); - //if form.is_legal_env_chain().unwrap_or(false) && x.is_legal_env_chain().unwrap_or(false) && x != form { - // if we open it to more then we also need to track usage of current env - if use_memo && x != form { - //if false { - //let form_ids = form.ids(); - //assert!(!form_ids.may_contain_id(&true_id)); - //if !x.is_legal_env_chain().unwrap_or(false) { - //println!("Went from legal hash chain {} to {}", form, x); - //println!("That is, from {}", form); - //println!("That is, to {}", x); - //AHAH! Ok, how it happens is for things like SuspendedParamLookup(offset,eval=true) because it will do a lookup - // that is a legal thing to sub in, but then eval will cause it to become suspended and maybe not a legal environment - // - // Hmm, how do we deal with that? - //} - //assert!(x.is_legal_env_chain().unwrap_or(false)); - //println!("Inserting skip from {} to {} blocked on {:?}-{:?} and {}-{:?} ", form, x, used_ids, dctx.real_hash_set(Some(used_ids.clone())), uses_env, if uses_env { Some(calculate_hash(&dctx.e)) } else { None }); - bctx.memo.insert(form, (dctx.real_hash_set(Some(used_ids)), if uses_env { Some(calculate_hash(&dctx.e)) } else { None }, Rc::clone(&x))); - //bctx.memo.insert(form, (dctx.real_hash_set(), if form_ids.may_contain_id(&true_id) { Some(calculate_hash(&dctx.e)) } else { None }, Rc::clone(&x))); - //bctx.memo.insert(form, (dctx.real_hash_set(), Some(calculate_hash(&dctx.e)), Rc::clone(&x))); - } - //if let Some((obctx, odctx, ox)) = skipped_from { - // println!(); - // println!(); - // println!(); - // println!("STARTING REPATH"); - // println!(); - // println!(); - // let (nobctx, nox) = partial_eval(obctx, odctx, ox, false)?; - // println!(); - // println!(); - // println!(); - // println!("REPATH DONE"); - // println!(); - // println!(); - // if nox != x { - // println!(); - // println!("x : {}", x); - // println!("nox: {}", nox); - // } - // assert!(nox == x); - //} - return Ok((bctx, x)); - } - let got = bctx.memo.get(&x); - // ah crap it's not the same ids it's the same ids with the same hashes - //if false { - if use_memo && got.map(|(ids,maybe_e_hash,it)| maybe_e_hash.map(|h| h == calculate_hash(&dctx.e)).unwrap_or(true) && dctx.real_hash_set(None).is_superset(ids)).unwrap_or(false) { - let skip = Rc::clone(&got.unwrap().2); - println!("{:ident$}({}) SKIPPING PE ", "", dctx.ident, ident=dctx.ident*4); - //println!("{:ident$}({}) PE {} skip forwards to {}", "", dctx.ident, x, skip, ident=dctx.ident*4); - //println!("{:ident$}({}) PE {} skip forwards to {} inside {} - got was {:?} and our hash is {}", "", dctx.ident, x, skip, dctx.e, got, calculate_hash(&dctx.e), ident=dctx.ident*4); - //skipped_from = Some((bctx.clone(), dctx.clone(), x)); - //HERE - let gots = got.unwrap().clone(); - if gots.1.is_some() { - bctx = bctx.set_uses_env(true); - } - for (_,_,id) in gots.0 { - bctx = bctx.add_id(id); - } - //THERE - - next_form = Some(skip); - } else { - //println!("{:ident$}({}) PE {} (because of {:?} with {:?}/{:?})", "", dctx.ident, x, x.ids(), dctx.real_set, dctx.fake_set, ident=dctx.ident*4); - let (new_bctx, new_form) = partial_eval_step(&x, bctx.clone(), &dctx, use_memo)?; - bctx = new_bctx; - // basic Drop redundent veval - // Old one was recursive over parameters to combs, which we might need, since the redundent veval isn't captured by - // ids. TODO! - // - // Nowadays, dropping EnvEval is legal always *unless* - // - True is in ids - // because we have the env attached to suspended lookups, if, and call - if let MarkedForm::SuspendedEnvEval { x, e, .. } = &*new_form { - if !x.ids().may_contain_id(&true_id) && e.is_legal_env_chain()? { - //println!("{:ident$}Dropping redundent eval: {} from {}", "", x, e, ident=dctx.ident*4); - //println!("{:ident$}Dropping redundent eval: {}", "", x, ident=dctx.ident*4); - println!("{:ident$}Dropping redundent eval:", "", ident=dctx.ident*4); - next_form = Some(Rc::clone(x)); - // do we still need force for drop redundent veval? - // Not while it's not recursive, at elaset - } else { - next_form = Some(new_form); - } - } else { - next_form = Some(new_form); - } - } - } -} -enum MapUnvalPEvalResult { - Ok(BCtx,Rc), - NotYet(anyhow::Error), - BadError(anyhow::Error), -} -fn map_unval_peval(bctx: BCtx, dctx: DCtx, x: Rc, use_memo: bool) -> MapUnvalPEvalResult { - match &*x { - MarkedForm::Nil => MapUnvalPEvalResult::Ok(bctx,x), - MarkedForm::Pair(_h, ids, x_car, x_cdr) => { - match x_car.unval() { - Ok(unval) => { - match partial_eval(bctx, dctx.clone(), unval, use_memo) { - Ok((bctx, new_x_car)) => { - match map_unval_peval(bctx, dctx.clone(), Rc::clone(x_cdr), use_memo) { - MapUnvalPEvalResult::Ok(bctx, new_x_cdr) => MapUnvalPEvalResult::Ok(bctx, MarkedForm::new_pair(new_x_car, new_x_cdr)), - e => e, - } - } - Err(e) => MapUnvalPEvalResult::BadError(e), - } - }, - Err(e) => MapUnvalPEvalResult::NotYet(e), - } - }, - - MarkedForm::Int(i) => MapUnvalPEvalResult::BadError(anyhow!("map_unval_peval over not a list")), - MarkedForm::Bool(b) => MapUnvalPEvalResult::BadError(anyhow!("map_unval_peval over not a list")), - MarkedForm::Symbol(s) => MapUnvalPEvalResult::BadError(anyhow!("map_unval_peval over not a list")), - MarkedForm::PrimComb { .. } => MapUnvalPEvalResult::BadError(anyhow!("map_unval_peval over not a list")), - MarkedForm::Pair(h,ids,car,cdr) => MapUnvalPEvalResult::BadError(anyhow!("map_unval_peval over not a list")), - MarkedForm::DeriComb { ids, .. } => MapUnvalPEvalResult::BadError(anyhow!("map_unval_peval over not a list")), - - MarkedForm::SuspendedSymbol(h, sus, name) => MapUnvalPEvalResult::NotYet(anyhow!("map_unval_peval over not (yet) a list")), - MarkedForm::SuspendedEnvLookup { id, .. } => MapUnvalPEvalResult::NotYet(anyhow!("map_unval_peval over not (yet) a list")), - MarkedForm::SuspendedParamLookup { id, .. } => MapUnvalPEvalResult::NotYet(anyhow!("map_unval_peval over not (yet) a list")), - MarkedForm::SuspendedEnvEval { ids, ..} => MapUnvalPEvalResult::NotYet(anyhow!("map_unval_peval over not (yet) a list")), - MarkedForm::SuspendedIf { ids, ..} => MapUnvalPEvalResult::NotYet(anyhow!("map_unval_peval over not (yet) a list")), - MarkedForm::SuspendedPair{ ids, .. } => MapUnvalPEvalResult::NotYet(anyhow!("map_unval_peval over not (yet) a list")), - - } -} -fn partial_eval_step(x: &Rc, bctx: BCtx, dctx: &DCtx, use_memo: bool) -> Result<(BCtx,Rc)> { - //println!("{:ident$}({}) {}", "", dctx.ident, x, ident=dctx.ident*4); - match &**x { - MarkedForm::Pair(h,ids,car,cdr) => { - //println!("{:ident$}pair ({}) {}", "", dctx.ident, x, ident=dctx.ident*4); - let (bctx, car) = partial_eval(bctx, dctx.clone(), Rc::clone(car), use_memo)?; - let (bctx, cdr) = partial_eval(bctx, dctx.clone(), Rc::clone(cdr), use_memo)?; - Ok((bctx, MarkedForm::new_pair(car, cdr))) - }, - MarkedForm::SuspendedSymbol(h, sus, name) => { - // Have to account for the *weird* case that the env chain ends in a suspended param / suspended env - //println!("Lookin up symbol {}", name); - //println!("Lookin up symbol {} in {}", name, dctx.e); - let (bctx, mut t) = if let Some(sus) = sus { - partial_eval(bctx, dctx.clone(), Rc::clone(sus), use_memo)? - } else { - (bctx.set_uses_env(true), Rc::clone(&dctx.e)) - }; - loop { - if let Ok(cmp) = t.car().and_then(|kv| kv.car()).and_then(|s| s.sym().map(|s| s.to_owned())) { - if *name == cmp { - //println!("\tgot for symbol {} {}", name, t.car()?.cdr()?.tag_name(name)); - return Ok((bctx, t.car()?.cdr()?.tag_name(name))); - } else { - t = t.cdr()?; - } - } else { - // bad env - match &*t { - MarkedForm::Nil => bail!("Lookup for {} not found!", name), - MarkedForm::SuspendedSymbol(h,sus, name) => break, - MarkedForm::SuspendedEnvLookup { .. } => break, - MarkedForm::SuspendedParamLookup { .. } => break, - MarkedForm::SuspendedEnvEval { .. } => break, - MarkedForm::SuspendedIf { .. } => break, - MarkedForm::SuspendedPair { .. } => break, - MarkedForm::Pair(h,ids,car,cdr) => break, - _ => bail!("Illegal lookup for {}", name), - } - } - } - //println!("\tcouldn't find it, returning suspended"); - return Ok((bctx, MarkedForm::new_suspended_symbol(Some(t), name.clone()))); - }, - MarkedForm::SuspendedEnvLookup { hash, name, id } => { - if let Some(v) = dctx.sus_env_stack.get(id) { - //println!("SuspendedEnvLookup for {:?} got {}", name, v); - let bctx = bctx.add_id(id.clone()); - Ok((bctx, if let Some(name) = name { v.tag_name(name) } else { Rc::clone(v) })) - } else { - panic!("failed env lookup (forced)"); - } - }, - MarkedForm::SuspendedParamLookup { hash, name, id, cdr_num, car, evaled } => { -println!("SUSSUS param lookup"); - if let Some(v) = dctx.sus_prm_stack.get(id) { - let bctx = bctx.add_id(id.clone()); - let mut translated_value = if let Some(name) = name { v.tag_name(name) } else { Rc::clone(v) }; - for i in 0..*cdr_num { - translated_value = translated_value.cdr()?; - } - if *car { - translated_value = translated_value.car()?; - } - if *evaled { - // but with this, we have to deal with unval failures - // actually, do we have to deal with unval failures? - translated_value = MarkedForm::new_suspended_env_eval(translated_value.unval().unwrap(), MarkedForm::new_suspended_env_lookup(None, id.clone())); - } - Ok((bctx, translated_value)) - } else { - panic!("failed param lookup (forced)"); - } - }, - MarkedForm::SuspendedEnvEval { x, e, .. } => { - // this bit is a little tricky - we'd like to tail call, but we can't lose our env - // if it fails. - let (bctx, e) = partial_eval(bctx, dctx.clone(), Rc::clone(e), use_memo)?; - if !e.is_legal_env_chain()? { - Ok((bctx, MarkedForm::new_suspended_env_eval(Rc::clone(x), e))) - } else { - // Reset uses env b/c we're not, we're using e... - let uses_env = bctx.get_uses_env(); - let (bctx, x) = partial_eval(bctx, dctx.copy_set_env(&e), Rc::clone(x), use_memo)?; - let bctx = bctx.set_uses_env(uses_env); - if x.is_value() { - Ok((bctx, x)) - } else { - Ok((bctx, MarkedForm::new_suspended_env_eval(x, e))) - } - } - // Note also that we drop redundent vevals at the bottom of the loop tail-call loop - // with force - }, - MarkedForm::SuspendedIf { c, id_env, t, e, ids, .. } => { - let (e_override, bctx, dctx) = if let Some((id, env)) = id_env { - let (bctx, nenv) = partial_eval(bctx, dctx.clone(), Rc::clone(env), use_memo)?; - if !nenv.is_legal_env_chain()? { - return Ok((bctx, MarkedForm::new_suspended_if(Some((id.clone(), nenv)), Rc::clone(c), Rc::clone(t), Rc::clone(e)))); - } - (true, bctx, dctx.copy_set_env(&nenv)) - } else { - (false, bctx, dctx.clone()) - }; - let (bctx, c) = partial_eval(bctx, dctx.clone(), Rc::clone(c), use_memo)?; - if let Ok(b) = c.truthy() { - if b { - Ok((bctx, Rc::clone(t))) - } else { - Ok((bctx, Rc::clone(e))) - } - } else { - let (could_stop, dctx) = dctx.copy_push_fake_if(); - let ( bctx, t) = partial_eval(bctx, dctx.clone(), Rc::clone(t), use_memo)?; - let (mut bctx, e) = partial_eval(bctx, dctx.clone(), Rc::clone(e), use_memo)?; - if let Some(cs) = could_stop { - if !e_override { - bctx = bctx.set_uses_env(true); - } - Ok((bctx, MarkedForm::new_suspended_if(Some((cs, Rc::clone(&dctx.e))), c, t, e))) - } else { - Ok((bctx, MarkedForm::new_suspended_if(None, c, t, e))) - } - } - }, - MarkedForm::DeriComb { hash, lookup_name, ids, se, de, id, wrap_level, sequence_params, rest_params, body } => { -println!("SUSSUS deri comb"); - // TODO: figure out wrap level, sequence params, etc - // the current env is our new se - - // wat - //let se = Rc::clone(&dctx.e); - let (bctx, se) = partial_eval(bctx, dctx.clone(), Rc::clone(se), use_memo)?; - if !se.is_legal_env_chain()? { - return Ok((bctx, MarkedForm::new_deri_comb(se, lookup_name.clone(), de.clone(), id.clone(), *wrap_level, sequence_params.clone(), rest_params.clone(), Rc::clone(body), None))); - } - let ident_amount = dctx.ident*4; - - match dctx.copy_push_frame(id.clone(), &se, &de, None, &rest_params, None, body) { - PushFrameResult::Ok(inner_dctx) => { - //println!("{:ident$}Doing a body deri for {:?} which is {}", "", lookup_name, x, ident=ident_amount); - //println!("{:ident$}and also body ids is {:?}", "", body.ids(), ident=ident_amount); - println!("{:ident$}pushing DeriComb for {:?}", "", id, ident=ident_amount); - // inner use doesn't count since through se - let uses_env = bctx.get_uses_env(); - let (bctx, body) = partial_eval(bctx, inner_dctx, Rc::clone(&body), use_memo)?; - let bctx = bctx.set_uses_env(uses_env); - let bctx = bctx.pop_id_frame(id); - println!("{:ident$}popping DeriComb for {:?}", "", id, ident=ident_amount); - //println!("{:ident$}result was {}", "", body, ident=ident_amount); - Ok((bctx, MarkedForm::new_deri_comb(se, lookup_name.clone(), de.clone(), id.clone(), *wrap_level, sequence_params.clone(), rest_params.clone(), body, None))) - }, - PushFrameResult::UnderBody(rec_stop_under) => { - //println!("{:ident$}call of {:?} failed b/c rec_stop_under b/c BODY", "", lookup_name, ident=dctx.ident*4); - Ok((bctx, MarkedForm::new_deri_comb(se, lookup_name.clone(), de.clone(), id.clone(), *wrap_level, sequence_params.clone(), rest_params.clone(), Rc::clone(body), Some(rec_stop_under)))) - }, - PushFrameResult::UnderIf(rec_stop_under) => { - //println!("{:ident$}call of {:?} failed b/c rec_stop_under b/c IF", "", lookup_name, ident=dctx.ident*4); - Ok((bctx, MarkedForm::new_deri_comb(se, lookup_name.clone(), de.clone(), id.clone(), *wrap_level, sequence_params.clone(), rest_params.clone(), Rc::clone(body), Some(rec_stop_under)))) - }, - } - }, - MarkedForm::SuspendedPair { hash, ids, env, car, cdr, attempted, under_if } => { -println!("SUSSUS suspended pair"); - let (e_override, bctx, env) = if let Some(env) = env { - let (bctx, nenv) = partial_eval(bctx, dctx.clone(), Rc::clone(env), use_memo)?; - if !nenv.is_legal_env_chain()? { - return Ok((bctx, MarkedForm::new_suspended_pair( Some(nenv), attempted.clone(), Rc::clone(car), Rc::clone(cdr), under_if.clone()))); - } - (true, bctx, nenv) - } else { - (false, bctx, Rc::clone(&dctx.e)) - }; - let mut need_denv = true; - let ( bctx, mut car) = partial_eval(bctx, dctx.clone(), Rc::clone(car), use_memo)?; - let (mut bctx, mut cdr) = partial_eval(bctx, dctx.clone(), Rc::clone(cdr), use_memo)?; - while let Some(wrap_level) = car.wrap_level() { - if wrap_level > 0 { - // two types of errors here - real ones, and ones that just prevent evaluating - // the entire parameter list right now due to suspended - match map_unval_peval(bctx.clone(), dctx.clone(), Rc::clone(&cdr), use_memo) { - MapUnvalPEvalResult::Ok(new_bctx, new_cdr) => { - car = car.decrement_wrap_level().unwrap(); - cdr = new_cdr; - bctx = new_bctx; - }, - MapUnvalPEvalResult::NotYet(e) => { - //println!("{:ident$} evaling parameters failed (for now) b/c {:?}", "", e, ident=dctx.ident*4); - break; - }, - MapUnvalPEvalResult::BadError(e) => { - //println!("{:ident$} evaling parameters failed (FOREVER) b/c {:?}", "", e, ident=dctx.ident*4); - return Err(e); - }, - } - } else { - // check to see if can do call - // We might want to enable not pure values for cons/car/cdr? - match &*car { - MarkedForm::PrimComb { name, nonval_ok, takes_de, wrap_level, f} => { - need_denv = *takes_de; - if !nonval_ok && !cdr.is_value() { - break; - } - //println!("{:ident$}doing a call eval of {}", "", name, ident=dctx.ident*4); - //println!("{:ident$}parameters {} are? a val because {:?}", "", cdr, cdr.ids(), ident=dctx.ident*4); - //return f(bctx.clone(), dctx.clone(), Rc::clone(&cdr)); - // If it's either already set, or if we're not overriding, keep sub-result - let e_mask = !e_override || bctx.get_uses_env(); - let (bctx,result) = f(bctx.clone(), dctx.copy_set_env(&env), Rc::clone(&cdr))?; - let newue = e_mask && bctx.get_uses_env(); - let bctx = bctx.set_uses_env(newue); - //println!("{:ident$}successful result is {}", "", result, ident=dctx.ident*4); - //println!("{:ident$}successful result", "", ident=dctx.ident*4); - return Ok((bctx,result)); - } - MarkedForm::DeriComb { hash, lookup_name, ids, se, de, id, wrap_level, sequence_params, rest_params, body } => { - need_denv = de.is_some(); - if !cdr.is_value() { - break; - } - let saved_env = if need_denv { Some(Rc::clone(&env)) } else { None }; - //new_attempted = Attempted::True(if de.is_some() { Some(dctx.e.ids()) } else { None }); - if de.is_some() && dctx.e.ids().may_contain_id(id) { - // The current environment may contain a reference to our ID, which - // means if we take that environment, if we then PE that - // environment we will replace it with our real environment that - // still has a dynamic reference to the current environment, which - // will be an infinate loop - if need_denv && !e_override { - bctx = bctx.set_uses_env(true); - } - return Ok((bctx, MarkedForm::new_suspended_pair( saved_env, Some(NeededIds::new_single(id.clone())), car, cdr, None))); - } - // not yet supporting sequence params - match dctx.copy_push_frame(id.clone(), &se, &de, Some(Rc::clone(&env)), &rest_params, Some(Rc::clone(&cdr)), body) { - PushFrameResult::Ok(inner_dctx) => { - let ident_amount = inner_dctx.ident*4; - //println!("{:ident$}doing a call eval of {} in {}", "", body, inner_dctx.e, ident=inner_dctx.ident*4); - //println!("{:ident$}doing a call eval of {:?}", "", lookup_name, ident=ident_amount); - //println!("{:ident$}with_parameters {}", "", cdr, ident=ident_amount); - - //Here is where we could do a tail call instead, but there - //would be no recovery back into the call-form... - println!("{:ident$}pushing true derived call for for {:?}", "", id, ident=ident_amount); - let e_mask = (de.is_some() && !e_override) || bctx.get_uses_env(); - let (bctx, r) = partial_eval(bctx.clone(), inner_dctx, Rc::clone(body), use_memo)?; - println!("{:ident$}popping true derived call for for {:?}", "", id, ident=ident_amount); - let newue = e_mask && bctx.get_uses_env(); - let bctx = bctx.set_uses_env(newue); - - let mut bctx = bctx.pop_id_frame(id); - if combiner_return_ok(&r, Some(id.clone())) { - println!("{:ident$}return ok {:?} - {:?}", "", id, r.ids(), ident=ident_amount); - return Ok((bctx, r)); - } else { - if need_denv && !e_override { - bctx = bctx.set_uses_env(true); - } - let id = id.clone(); - let car_ids = car.ids(); - let cdr_ids = cdr.ids(); - let sus_pair = MarkedForm::new_suspended_pair( saved_env, Some(r.ids()), car, cdr, None); - println!("{:ident$}return not ok, doing sus pair {:?} - {:?} (car_ids {:?}, cdr_ids {:?})", "", id, sus_pair.ids(), car_ids, cdr_ids, ident=ident_amount); - if r.ids().may_contain_id(&id) { - println!("Need self to be real but we were - {}", r); - //ok, so the not progressing when se isn't a legal env is preventing progress that could be made with a real env - // which makes sense - } - assert!(!r.ids().may_contain_id(&id)); - return Ok((bctx, sus_pair)); - } - }, - PushFrameResult::UnderBody(rec_stop_under) => { unreachable!() }, - PushFrameResult::UnderIf(rec_stop_under) => { - //println!("{:ident$}call of {:?} failed b/c rec_stop_under of if", "", lookup_name, ident=dctx.ident*4); - if need_denv && !e_override { - bctx = bctx.set_uses_env(true); - } - return Ok((bctx, MarkedForm::new_suspended_pair( saved_env, None, car, cdr, Some(rec_stop_under)))); - }, - } - }, - // These are illegal values - MarkedForm::Nil => bail!("tried to call a bad value {:?}", car), - MarkedForm::Pair(h, ids, x_car, x_cdr) => bail!("tried to call a bad value {:?}", car), - MarkedForm::Int(i) => bail!("tried to call a bad value {:?}", car), - MarkedForm::Bool(b) => bail!("tried to call a bad value {:?}", car), - MarkedForm::Symbol(s) => bail!("tried to call a bad value {:?}", car), - MarkedForm::PrimComb { .. } => bail!("tried to call a bad value {:?}", car), - MarkedForm::Pair(h,ids,car,cdr) => bail!("tried to call a bad value {:?}", car), - MarkedForm::DeriComb { ids, .. } => bail!("tried to call a bad value {:?}", car), - _ => {}, // suspended, so reform - } - break; - } - } - // Didn't manage to call - if need_denv && !e_override { - bctx = bctx.set_uses_env(true); - } - Ok((bctx, MarkedForm::new_suspended_pair( if need_denv { Some(env) } else { None }, None, car, cdr, None))) - }, - // Values should never get here b/c ids UNLESS FORCE HAH - _ => panic!("value evaled! {}", x), - } -} - -impl fmt::Display for MarkedForm { - fn fmt(&self, f: &mut fmt::Formatter<'_>) -> fmt::Result { - match self { - MarkedForm::Nil => write!(f, "nil"), - MarkedForm::Int(i) => write!(f, "{}", i), - MarkedForm::Bool(b) => write!(f, "{}", b), - MarkedForm::Symbol(s) => write!(f, "{}", s), - MarkedForm::Pair( h, ids, car, cdr) => { - //write!(f, "{:?}#({}", ids, car)?; - write!(f, "({}", car)?; - let mut traverse: Rc = Rc::clone(cdr); - loop { - match &*traverse { - MarkedForm::Pair( ref h, ref ids, ref carp, ref cdrp) => { - write!(f, " {}", carp)?; - traverse = Rc::clone(cdrp); - }, - MarkedForm::Nil => { - write!(f, ")")?; - return Ok(()); - }, - x => { - write!(f, ". {})", x)?; - return Ok(()); - }, - } - } - }, - MarkedForm::SuspendedEnvEval { hash, ids, x, e } => write!(f, "({}){{Sveval {} {}}}", ids, x, e), - MarkedForm::SuspendedIf { hash, ids, id_env, c, t, e } => { - if id_env.is_some() { - write!(f, "({})#HasEnv{{Sif {} {} {}}}", ids, c, t, e) - } else { - write!(f, "({}){{Sif {} {} {}}}", ids, c, t, e) - } - }, - MarkedForm::SuspendedSymbol( hash,sus,name) => if let Some(sus) = sus { write!(f, "({}){}", sus, name) } else { write!(f, "(){}", name) }, - MarkedForm::SuspendedEnvLookup { hash, name, id } => write!(f, "{:?}({:?}env)", name, id), - MarkedForm::SuspendedParamLookup { hash, name, id, cdr_num, car, evaled } => write!(f, "{:?}({:?}{}{}{})", name, id, cdr_num, car, evaled), - MarkedForm::PrimComb { name, wrap_level, .. } => write!(f, "<{}{}>", name, wrap_level), - - MarkedForm::DeriComb { hash, lookup_name, ids, se, de, id, wrap_level, sequence_params, rest_params, body } => { - //let env_form = format!("{}", se); - write!(f, "{}#[{:?}/{:?}/{:?}/{}/{:?}/{:?}/{}]", ids, lookup_name, de, id, wrap_level, sequence_params, rest_params, body) - }, - - MarkedForm::SuspendedPair{ hash, ids, env, car, cdr, .. } => { - if env.is_some() { - write!(f, "{}#HasEnv{{{}", ids, car)?; - } else { - write!(f, "{}#{{{}", ids, car)?; - } - //write!(f, "{{{}", car)?; - let mut traverse: Rc = Rc::clone(cdr); - loop { - match &*traverse { - MarkedForm::Pair( ref h, ref ids, ref carp, ref cdrp) => { - write!(f, " {}", carp)?; - traverse = Rc::clone(cdrp); - }, - MarkedForm::Nil => { - write!(f, "}}")?; - return Ok(()); - }, - x => { - write!(f, ". {}}}", x)?; - return Ok(()); - }, - } - } - }, - } - } -} diff --git a/kr/src/test.rs b/kr/src/test.rs deleted file mode 100644 index 19de4ae..0000000 --- a/kr/src/test.rs +++ /dev/null @@ -1,625 +0,0 @@ -use std::rc::Rc; - -use crate::grammar; -use crate::ast::{eval,root_env,Form,PossibleTailCall}; -use crate::pe_ast::{mark,partial_eval,new_base_ctxs,MarkedForm}; - -#[test] -fn parse_test() { - let g = grammar::TermParser::new(); - for test in [ - "22", "(22)", "(((22)))", - "(22 )", "()", "( )", "( 44)", "(44 )", - "(22 44 (1) 33 (4 5 (6) 6))", "hello", - "-", "+", "(+ 1 ;hi - 3)", "'13", "hello-world", "_", - ] { - assert!(g.parse(test).is_ok()); - } - assert!(g.parse("((22)").is_err()); -} - -fn eval_test>(also_pe: bool, gram: &grammar::TermParser, e: &Rc, code: &str, expected: T) { - println!("Doing test {}", code); - let parsed = Rc::new(gram.parse(code).unwrap()); - let basic_result = eval(Rc::clone(e), Rc::clone(&parsed)); - assert_eq!(*basic_result, expected.into()); - if also_pe { - let (bctx, dctx) = new_base_ctxs(); - let (bctx, marked) = mark(parsed,bctx); - let unvaled = marked.unval().unwrap(); - let (bctx, ped) = partial_eval(bctx, dctx, unvaled, true).unwrap(); - let (bctx, marked_basic_result) = mark(basic_result,bctx); - println!("Final PE {}", ped); - println!("wanted {}", marked_basic_result); - assert_eq!(*ped, *marked_basic_result); - } -} -fn partial_eval_test(gram: &grammar::TermParser, code: &str, expected: &str) { - println!("Doing PE test {}", code); - let parsed = Rc::new(gram.parse(code).unwrap()); - let (bctx, dctx) = new_base_ctxs(); - let (bctx, marked) = mark(parsed,bctx); - let unvaled = marked.unval().unwrap(); - let (bctx, ped) = partial_eval(bctx, dctx, unvaled, true).unwrap(); - println!("Final PE {}", ped); - println!("wanted {}", expected); - assert_eq!(format!("{}", ped), expected); -} -#[test] -fn basic_pe_test() { - let g = grammar::TermParser::new(); - partial_eval_test(&g, "(+ 2 (car (cons 4 '(1 2))))", "6"); - partial_eval_test(&g, "(vau 0 p (+ 1 2))", "NeedsNone#[None/None/EnvID(1)/0/[]/Some(\"p\")/3]"); - - partial_eval_test(&g, "(vau de p (+ (eval (car p) de) (eval (car (cdr p)) de)))", "NeedsNone#[None/Some(\"de\")/EnvID(1)/0/[]/Some(\"p\")/NeedsH{EnvID(1)}#{<+0> Some(\"p\")(EnvID(1)0truetrue) Some(\"p\")(EnvID(1)1truetrue)}]"); - - partial_eval_test(&g, "(vau de p (eval '(+ a 2) (cons (cons 'a (eval (car p) de)) - ((vau de p de)))))", "NeedsNone#[None/Some(\"de\")/EnvID(1)/0/[]/Some(\"p\")/NeedsH{EnvID(1)}#{<+0> Some(\"a\")(EnvID(1)0truetrue) 2}]"); - //partial_eval_test(&g, "(vau de p (eval (+ a b) (cons (cons 'a (eval (car p) de)) - // (cons (cons 'b (eval (car (cdr p)) de)) - // de))))", ""); -} - -#[test] -fn basic_eval_test() { let g = grammar::TermParser::new(); let e = root_env(); - eval_test(true, &g, &e, "(+ 2 (car (cons 4 '(1 2))))", 6); - eval_test(true, &g, &e, "(= 17 ((vau d p (+ (eval (car p) d) 13)) (+ 1 3)))", true); - eval_test(true, &g, &e, "(if (= 2 2) (+ 1 2) (+ 3 4))", 3); - eval_test(true, &g, &e, "(quote a)", "a"); - eval_test(true, &g, &e, "'a", "a"); - eval_test(true, &g, &e, "'(1 . a)", (1, "a")); - eval_test(true, &g, &e, "'(1 a)", (1, ("a", Form::Nil))); - eval_test(true, &g, &e, "true", true); - eval_test(true, &g, &e, "false", false); - eval_test(true, &g, &e, "nil", Form::Nil); - - eval_test(true, &g, &e, "(+ 1 2)", 3); - eval_test(true, &g, &e, "(- 1 2)", -1); - eval_test(true, &g, &e, "(* 1 2)", 2); - eval_test(true, &g, &e, "(/ 4 2)", 2); - eval_test(true, &g, &e, "(% 3 2)", 1); - eval_test(true, &g, &e, "(& 3 2)", 2); - eval_test(true, &g, &e, "(| 2 1)", 3); - eval_test(true, &g, &e, "(^ 2 1)", 3); - eval_test(true, &g, &e, "(^ 3 1)", 2); - - eval_test(true, &g, &e, "(< 3 1)", false); - eval_test(true, &g, &e, "(<= 3 1)", false); - eval_test(true, &g, &e, "(> 3 1)", true); - eval_test(true, &g, &e, "(>= 3 1)", true); - - eval_test(true, &g, &e, "(comb? +)", true); - eval_test(true, &g, &e, "(comb? (vau d p 1))", true); - eval_test(true, &g, &e, "(comb? 1)", false); - eval_test(true, &g, &e, "(pair? '(a))", true); - //eval_test(true, &g, &e, "(pair? '())", true); - eval_test(true, &g, &e, "(nil? nil)", true); - eval_test(true, &g, &e, "(nil? 1)", false); - eval_test(true, &g, &e, "(pair? 1)", false); - eval_test(true, &g, &e, "(symbol? 'a)", true); - eval_test(true, &g, &e, "(symbol? 1)", false); - eval_test(true, &g, &e, "(int? 1)", true); - eval_test(true, &g, &e, "(int? true)", false); - eval_test(true, &g, &e, "(bool? true)", true); - eval_test(true, &g, &e, "(bool? 1)", false); - - eval_test(true, &g, &e, "!(bool?) 1", false); - eval_test(true, &g, &e, "!(bool?) true", true); - - eval_test(true, &g, &e, "((vau root_env _ (eval 'a (cons (cons 'a 2) root_env))))", 2); - eval_test(true, &g, &e, "'name-dash", "name-dash"); -} - - -use once_cell::sync::Lazy; -static LET: Lazy = Lazy::new(|| { - "!((vau root_env p (eval (car p) - (cons (cons 'let1 - (vau de p (eval (car (cdr (cdr p))) (cons (cons (car p) (eval (car (cdr p)) de)) de))) - ) root_env))))".to_owned() -}); - -#[test] -fn let_pe_test() { - let g = grammar::TermParser::new(); - partial_eval_test(&g, &format!("{} (let1 a 2 (+ a (car (cons 4 '(1 2)))))", *LET), "6"); - partial_eval_test(&g, &format!("{} (let1 a 2 (vau 0 p (+ 1 a)))", *LET),"NeedsNone#[None/None/EnvID(3)/0/[]/Some(\"p\")/3]"); - partial_eval_test(&g, &format!("{} - !(let1 a 2) - (vau 0 p (+ 1 a)) - ", *LET), "NeedsNone#[None/None/EnvID(3)/0/[]/Some(\"p\")/3]"); - partial_eval_test(&g, &format!("{} - !(let1 a 2) - !(let1 b 5) - (vau 0 p (+ b a)) - ", *LET), "NeedsNone#[None/None/EnvID(3)/0/[]/Some(\"p\")/7]"); - /* - partial_eval_test(&g, &format!("{} - (vau 0 p - !(let1 a 2) - !(let1 b 5) - (+ b a) - ) - ", *LET), "None({})#[None/None/EnvID(0)/0/[]/Some(\"p\")/7]"); - partial_eval_test(&g, &format!("{} - (vau d p - !(let1 a 2) - (+ (eval (car p) d) a) - ) - ", *LET), "None({})#[None/None/EnvID(2)/0/[]/Some(\"p\")/7]"); - */ -} - -#[test] -fn fib_eval_test() { let g = grammar::TermParser::new(); let e = root_env(); - eval_test(true, &g, &e, &format!("{} (let1 x 10 (+ x 7))", *LET), 17); - let def_fib = " - !(let1 fib (vau de p - !(let1 self (eval (car p) de)) - !(let1 n (eval (car (cdr p)) de)) - !(if (= 0 n) 0) - !(if (= 1 n) 1) - (+ (self self (- n 1)) (self self (- n 2))) - ))"; - eval_test(false, &g, &e, &format!("{} {} (fib fib 6)", *LET, def_fib), 8); -} -#[test] -fn fact_eval_test() { let g = grammar::TermParser::new(); let e = root_env(); - let def_fact = " - !(let1 fact (vau de p - !(let1 self (eval (car p) de)) - !(let1 n (eval (car (cdr p)) de)) - !(if (= 0 n) 1) - (* n (self self (- n 1))) - ))"; - eval_test(true, &g, &e, &format!("{} {} (fact fact 6)", *LET, def_fact), 720); -} -static VAPPLY: Lazy = Lazy::new(|| { - format!(" - {} - !(let1 vapply (vau de p - !(let1 f (eval (car p) de)) - !(let1 ip (eval (car (cdr p)) de)) - !(let1 nde (eval (car (cdr (cdr p))) de)) - (eval (cons f ip) nde) - ))", *LET) -}); -#[test] -fn vapply_eval_test() { let g = grammar::TermParser::new(); let e = root_env(); - // need the vapply to keep env in check because otherwise the env keeps growing - // and the Rc::drop will overflow the stack lol - let def_badid = format!(" - {} - !(let1 badid (vau de p - !(let1 inner (vau ide ip - !(let1 self (car ip)) - !(let1 n (car (cdr ip))) - !(let1 acc (car (cdr (cdr ip)))) - !(if (= 0 n) acc) - (vapply self (cons self (cons (- n 1) (cons (+ acc 1) nil))) de) - )) - (vapply inner (cons inner (cons (eval (car p) de) (cons 0 nil))) de) - ))", *VAPPLY); - // Won't work unless tail calls work - // so no PE? - eval_test(false, &g, &e, &format!("{} (badid 1000)", def_badid), 1000); -} - -static VMAP: Lazy = Lazy::new(|| { - format!(" - {} - !(let1 vmap (vau de p - !(let1 vmap_inner (vau ide ip - !(let1 self (car ip)) - !(let1 f (car (cdr ip))) - !(let1 l (car (cdr (cdr ip)))) - !(if (= nil l) l) - (cons (vapply f (cons (car l) nil) de) (vapply self (cons self (cons f (cons (cdr l) nil))) de)) - )) - (vapply vmap_inner (cons vmap_inner (cons (eval (car p) de) (cons (eval (car (cdr p)) de) nil))) de) - ))", *VAPPLY) -}); -#[test] -fn vmap_eval_test() { let g = grammar::TermParser::new(); let e = root_env(); - // Maybe define in terms of a right fold? - //eval_test(true, &g, &e, &format!("{} (vmap (vau de p (+ 1 (car p))) '(1 2 3))", *VMAP), (2, (3, (4, Form::Nil)))); - eval_test(true, &g, &e, &format!("{} (vmap (vau de p (+ 1 (car p))) '(1))", *VMAP), (2, Form::Nil)); -} - -static WRAP: Lazy = Lazy::new(|| { - format!(" - {} - !(let1 wrap (vau de p - !(let1 f (eval (car p) de)) - (vau ide p (vapply f (vmap (vau _ xp (eval (car xp) ide)) p) ide)) - ))", *VMAP) -}); -#[test] -fn wrap_eval_test() { let g = grammar::TermParser::new(); let e = root_env(); - // Make sure (wrap (vau ...)) and internal style are optimized the same - eval_test(true, &g, &e, &format!("{} ((wrap (vau _ p (+ (car p) 1))) (+ 1 2))", *WRAP), 4); -} - -static UNWRAP: Lazy = Lazy::new(|| { - format!(" - {} - !(let1 unwrap (vau de p - !(let1 f (eval (car p) de)) - (vau ide p (vapply f (vmap (vau _ xp (cons quote (cons (car xp) nil))) p) ide)) - ))", *WRAP) -}); -#[test] -fn unwrap_eval_test() { let g = grammar::TermParser::new(); let e = root_env(); - // Can't represent prims in tests :( - they do work though, uncommenting and checking the - // failed assert verifies - //eval_test(true, &g, &e, &format!("{} ((unwrap (vau de p (car p))) (+ 1 2))", def_unwrap), ("quote", (("+", (1, (2, Form::Nil))), Form::Nil))); - //eval_test(true, &g, &e, &format!("{} ((unwrap (vau de p (eval (car p) de))) (+ 1 2))", def_unwrap), (("+", (1, (2, Form::Nil))), Form::Nil)); - eval_test(true, &g, &e, &format!("{} ((unwrap (vau de p (eval (eval (car p) de) de))) (+ 1 2))", *UNWRAP), 3); - eval_test(true, &g, &e, &format!("{} ((unwrap (vau de p (+ (eval (eval (car p) de) de) 1))) (+ 1 2))", *UNWRAP), 4); -} - -static LAPPLY: Lazy = Lazy::new(|| { - format!(" - {} - !(let1 lapply (vau de p - !(let1 f (eval (car p) de)) - !(let1 ip (eval (car (cdr p)) de)) - !(let1 nde (eval (car (cdr (cdr p))) de)) - (eval (cons (unwrap f) ip) nde) - ))", *UNWRAP) -}); -#[test] -fn lapply_eval_test() { let g = grammar::TermParser::new(); let e = root_env(); - // Should this allow envs at all? It technically can, but I feel like it kinda goes against the - // sensible deriviation - let def_lbadid = format!(" - {} - !(let1 lbadid (vau de p - !(let1 inner (wrap (vau ide ip - !(let1 self (car ip)) - !(let1 n (car (cdr ip))) - !(let1 acc (car (cdr (cdr ip)))) - !(if (= 0 n) acc) - (lapply self (cons self (cons (- n 1) (cons (+ acc 1) nil))) de) - ))) - (lapply inner (cons inner (cons (eval (car p) de) (cons 0 nil))) de) - ))", *LAPPLY); - // Won't work unless tail calls work - // takes a while though - eval_test(false, &g, &e, &format!("{} (lbadid 1000)", def_lbadid), 1000); -} - -static VFOLDL: Lazy = Lazy::new(|| { - format!(" - {} - !(let1 vfoldl (vau de p - !(let1 vfoldl_inner (vau ide ip - !(let1 self (car ip)) - !(let1 f (car (cdr ip))) - !(let1 a (car (cdr (cdr ip)))) - !(let1 l (car (cdr (cdr (cdr ip))))) - !(if (= nil l) a) - (vapply self (cons self (cons f (cons (vapply f (cons a (cons (car l) nil)) de) (cons (cdr l) nil)))) de) - )) - (vapply vfoldl_inner (cons vfoldl_inner (cons (eval (car p) de) (cons (eval (car (cdr p)) de) (cons (eval (car (cdr (cdr p))) de) nil)))) de) - ))", *LAPPLY) -}); -#[test] -fn vfoldl_eval_test() { let g = grammar::TermParser::new(); let e = root_env(); - eval_test(true, &g, &e, &format!("{} (vfoldl (vau de p (+ (car p) (car (cdr p)))) 0 '(1 2 3))", *VFOLDL), 6); -} -static ZIPD: Lazy = Lazy::new(|| { - format!(" - {} - !(let1 zipd (vau de p - !(let1 zipd_inner (vau ide ip - !(let1 self (car ip)) - !(let1 a (car (cdr ip))) - !(let1 b (car (cdr (cdr ip)))) - !(if (= nil a) a) - !(if (= nil b) b) - (cons (cons (car a) (car b)) (vapply self (cons self (cons (cdr a) (cons (cdr b) nil))) de)) - )) - (vapply zipd_inner (cons zipd_inner (cons (eval (car p) de) (cons (eval (car (cdr p)) de) nil))) de) - ))", *VFOLDL) -}); -#[test] -fn zipd_eval_test() { let g = grammar::TermParser::new(); let e = root_env(); - eval_test(true, &g, &e, &format!("{} (zipd '(1 2 3) '(4 5 6))", *ZIPD), ((1,4), ((2,5), ((3,6), Form::Nil)))); -} -static CONCAT: Lazy = Lazy::new(|| { - format!(" - {} - !(let1 concat (vau de p - !(let1 concat_inner (vau ide ip - !(let1 self (car ip)) - !(let1 a (car (cdr ip))) - !(let1 b (car (cdr (cdr ip)))) - !(if (= nil a) b) - (cons (car a) (vapply self (cons self (cons (cdr a) (cons b nil))) de)) - )) - (vapply concat_inner (cons concat_inner (cons (eval (car p) de) (cons (eval (car (cdr p)) de) nil))) de) - ))", *ZIPD) -}); - -#[test] -fn concat_eval_test() { let g = grammar::TermParser::new(); let e = root_env(); - eval_test(true, &g, &e, &format!("{} (concat '(1 2 3) '(4 5 6))", *CONCAT), (1, (2, (3, (4, (5, (6, Form::Nil))))))); -} - -static BVAU: Lazy = Lazy::new(|| { - format!(" - {} - !(let1 match_params (wrap (vau 0 p - !(let1 self (car p)) - !(let1 p_ls (car (cdr p))) - !(let1 dp (car (cdr (cdr p)))) - !(let1 e (car (cdr (cdr (cdr p))))) - !(if (= nil p_ls) (assert (= nil dp) e)) - !(if (symbol? p_ls) (cons (cons p_ls dp) e)) - (self self (cdr p_ls) (cdr dp) (self self (car p_ls) (car dp) e)) - ))) - !(let1 bvau (vau se p - (if (= nil (cdr (cdr p))) - ; No de case - !(let1 p_ls (car p)) - !(let1 b_v (car (cdr p))) - (vau 0 dp - (eval b_v (match_params match_params p_ls dp se)) - ) - - ; de case - !(let1 de_s (car p)) - !(let1 p_ls (car (cdr p))) - !(let1 b_v (car (cdr (cdr p)))) - (vau dde dp - (eval b_v (match_params match_params p_ls dp (cons (cons de_s dde) se))) - ) - ) - ))", *CONCAT) -}); -#[test] -fn bvau_eval_test() { let g = grammar::TermParser::new(); let e = root_env(); - eval_test(true, &g, &e, &format!("{} ((bvau _ (a b c) (+ a (- b c))) 10 2 3)", *BVAU), 9); - //eval_test(true, &g, &e, &format!("{} ((bvau (a b c) (+ a (- b c))) 10 2 3)", *BVAU), 9); - - //eval_test(true, &g, &e, &format!("{} ((bvau (a b . c) c) 10 2 3)", *BVAU), (3, Form::Nil)); - //eval_test(true, &g, &e, &format!("{} ((bvau (a b . c) c) 10 2)", *BVAU), Form::Nil); - //eval_test(true, &g, &e, &format!("{} ((bvau (a b . c) c) 10 2 3 4 5)", *BVAU), (3, (4, (5, Form::Nil)))); - //eval_test(true, &g, &e, &format!("{} ((bvau c c) 3 4 5)", *BVAU), (3, (4, (5, Form::Nil)))); - //eval_test(true, &g, &e, &format!("{} ((bvau c c))", *BVAU), Form::Nil); - //eval_test(true, &g, &e, &format!("{} ((bvau ((a b) . c) c) (10 2) 3 4 5)", *BVAU), (3, (4, (5, Form::Nil)))); - //eval_test(true, &g, &e, &format!("{} ((bvau ((a b) . c) a) (10 2) 3 4 5)", *BVAU), 10); - //eval_test(true, &g, &e, &format!("{} ((bvau ((a b) . c) b) (10 2) 3 4 5)", *BVAU), 2); - - //eval_test(true, &g, &e, &format!("{} ((wrap (bvau _ (a b c) (+ a (- b c)))) (+ 10 1) (+ 2 2) (+ 5 3))", *BVAU), 7); - //eval_test(true, &g, &e, &format!("{} ((wrap (bvau (a b c) (+ a (- b c)))) (+ 10 1) (+ 2 2) (+ 5 3))", *BVAU), 7); -} - -static LAMBDA: Lazy = Lazy::new(|| { - format!(" - {} - !(let1 lambda (vau de p - (wrap (vapply bvau p de)) - ))", *BVAU) -}); -#[test] -fn lambda_eval_test() { let g = grammar::TermParser::new(); let e = root_env(); - eval_test(true, &g, &e, &format!("{} ((lambda (a b c) (+ a (- b c))) (+ 10 1) (+ 2 2) (+ 5 3))", *LAMBDA), 7); - eval_test(true, &g, &e, &format!("{} ((lambda (a b . c) c) 10 2 3)", *LAMBDA), (3, Form::Nil)); - eval_test(true, &g, &e, &format!("{} ((lambda (a b . c) c) 10 2)", *LAMBDA), Form::Nil); - eval_test(true, &g, &e, &format!("{} ((lambda (a b . c) c) 10 2 3 4 5)", *LAMBDA), (3, (4, (5, Form::Nil)))); - eval_test(true, &g, &e, &format!("{} ((lambda c c) 3 4 5)", *LAMBDA), (3, (4, (5, Form::Nil)))); - eval_test(true, &g, &e, &format!("{} ((lambda c c))", *LAMBDA), Form::Nil); - eval_test(true, &g, &e, &format!("{} ((lambda ((a b) . c) c) '(10 2) 3 4 5)", *LAMBDA), (3, (4, (5, Form::Nil)))); - eval_test(true, &g, &e, &format!("{} ((lambda ((a b) . c) a) '(10 2) 3 4 5)", *LAMBDA), 10); - eval_test(true, &g, &e, &format!("{} ((lambda ((a b) . c) b) '(10 2) 3 4 5)", *LAMBDA), 2); - eval_test(true, &g, &e, &format!("{} ((lambda ((a b . c) d) b) '(10 2 3 4) 3)", *LAMBDA), 2); - eval_test(true, &g, &e, &format!("{} ((lambda ((a b . c) d) c) '(10 2 3 4) 3)", *LAMBDA), (3, (4, Form::Nil))); - // should fail - //eval_test(true, &g, &e, &format!("{} ((lambda (a b c) c) 10 2 3 4)", *LAMBDA), 3); -} - -static LET2: Lazy = Lazy::new(|| { - format!(" - {} - !(let1 let1 (bvau dp (s v b) - (eval b (match_params match_params s (eval v dp) dp)) - )) - ", *LAMBDA) -}); - -#[test] -fn let2_eval_test() { let g = grammar::TermParser::new(); let e = root_env(); - - eval_test(true, &g, &e, &format!("{} (let1 x (+ 10 1) (+ x 1))", *LET2), 12); - eval_test(true, &g, &e, &format!("{} (let1 x '(10 1) x)", *LET2), (10, (1, Form::Nil))); - eval_test(true, &g, &e, &format!("{} (let1 (a b) '(10 1) a)", *LET2), 10); - eval_test(true, &g, &e, &format!("{} (let1 (a b) '(10 1) b)", *LET2), 1); - eval_test(true, &g, &e, &format!("{} (let1 (a b . c) '(10 1) c)", *LET2), Form::Nil); - eval_test(true, &g, &e, &format!("{} (let1 (a b . c) '(10 1 2 3) c)", *LET2), (2, (3, Form::Nil))); - eval_test(true, &g, &e, &format!("{} (let1 ((a . b) . c) '((10 1) 2 3) a)", *LET2), 10); - eval_test(true, &g, &e, &format!("{} (let1 ((a . b) . c) '((10 1) 2 3) b)", *LET2), (1, Form::Nil)); - // should fail - //eval_test(true, &g, &e, &format!("{} (let1 (a b c) '(10 2 3 4) a)", *LET2), 10); -} - -static LIST: Lazy = Lazy::new(|| { - format!(" - {} - !(let1 list (lambda args args)) - ", *LET2) -}); - -#[test] -fn list_eval_test() { let g = grammar::TermParser::new(); let e = root_env(); - eval_test(true, &g, &e, &format!("{} (list 1 2 (+ 3 4))", *LIST), (1, (2, (7, Form::Nil)))); -} - -static Y: Lazy = Lazy::new(|| { - format!(" - {} - !(let1 Y (lambda (f3) - ((lambda (x1) (x1 x1)) - (lambda (x2) (f3 (wrap (vau app_env y (lapply (x2 x2) y app_env))))))) - ) - ", *LIST) -}); - -#[test] -fn y_eval_test() { let g = grammar::TermParser::new(); let e = root_env(); - - eval_test(true, &g, &e, &format!("{} ((Y (lambda (recurse) (lambda (n) (if (= 0 n) 1 (* n (recurse (- n 1))))))) 5)", *Y), 120); - -} - -static RLAMBDA: Lazy = Lazy::new(|| { - format!(" - {} - !(let1 rlambda (bvau se (n p b) - (eval (list Y (list lambda (list n) (list lambda p b))) se) - )) - ", *Y) -}); - -#[test] -fn rlambda_eval_test() { let g = grammar::TermParser::new(); let e = root_env(); - eval_test(true, &g, &e, &format!("{} ((rlambda recurse (n) (if (= 0 n) 1 (* n (recurse (- n 1))))) 5)", *RLAMBDA), 120); -} -static AND_OR: Lazy = Lazy::new(|| { - // need to extend for varidac - format!(" - {} - !(let1 and (bvau se (a b) - !(let1 ae (eval a se)) - (if ae (eval b se) ae) - )) - !(let1 or (bvau se (a b) - !(let1 ae (eval a se)) - (if ae ae (eval b se)) - )) - ", *RLAMBDA) -}); - -#[test] -fn and_or_eval_test() { let g = grammar::TermParser::new(); let e = root_env(); - eval_test(true, &g, &e, &format!("{} (and true true)", *AND_OR), true); - eval_test(true, &g, &e, &format!("{} (and false true)", *AND_OR), false); - eval_test(true, &g, &e, &format!("{} (and true false)", *AND_OR), false); - eval_test(true, &g, &e, &format!("{} (and false false)", *AND_OR), false); - - eval_test(true, &g, &e, &format!("{} (or true true)", *AND_OR), true); - eval_test(true, &g, &e, &format!("{} (or false true)", *AND_OR), true); - eval_test(true, &g, &e, &format!("{} (or true false)", *AND_OR), true); - eval_test(true, &g, &e, &format!("{} (or false false)", *AND_OR), false); -} -static LEN: Lazy = Lazy::new(|| { - format!(" - {} - !(let1 len (lambda (l) - !(let1 len_helper (rlambda len_helper (l a) - (if (pair? l) (len_helper (cdr l) (+ 1 a)) - a) - )) - (len_helper l 0) - )) - ", *AND_OR) -}); - -#[test] -fn len_eval_test() { let g = grammar::TermParser::new(); let e = root_env(); - eval_test(true, &g, &e, &format!("{} (len '())", *LEN), 0); - eval_test(true, &g, &e, &format!("{} (len '(1))", *LEN), 1); - eval_test(true, &g, &e, &format!("{} (len '(1 2))", *LEN), 2); - eval_test(true, &g, &e, &format!("{} (len '(1 2 3))", *LEN), 3); -} -static MATCH: Lazy = Lazy::new(|| { - format!(" - {} - !(let1 match (bvau de (x . cases) - !(let1 evaluate_case (rlambda evaluate_case (access c) - !(if (symbol? c) (list true (lambda (b) (list let1 c access b)))) - !(if (and (pair? c) (= 'unquote (car c))) (list (list = access (car (cdr c))) (lambda (b) b))) - !(if (and (pair? c) (= 'quote (car c))) (list (list = access c) (lambda (b) b))) - !(if (pair? c) - !(let1 tests (list and (list pair? access) (list = (len c) (list len access)))) - !(let1 (tests body_func) ((rlambda recurse (c tests access body_func) (if (pair? c) - !(let1 (inner_test inner_body_func) (evaluate_case (list car access) (car c))) - (recurse (cdr c) - (list and tests inner_test) - (list cdr access) - (lambda (b) (body_func (inner_body_func b)))) - ; else - (list tests body_func) - )) - c tests access (lambda (b) b))) - (list tests body_func)) - (list (list = access c) (lambda (b) b)) - )) - !(let1 helper (rlambda helper (x_sym cases) (if (= nil cases) (list assert false) - (let1 (test body_func) (evaluate_case x_sym (car cases)) - (concat (list if test (body_func (car (cdr cases)))) (list (helper x_sym (cdr (cdr cases))))))))) - - (eval (list let1 '___MATCH_SYM x (helper '___MATCH_SYM cases)) de) - ;!(let1 expanded (list let1 '___MATCH_SYM x (helper '___MATCH_SYM cases))) - ;(debug expanded (eval expanded de)) - )) - ", *LEN) -}); -#[test] -fn match_eval_test() { let g = grammar::TermParser::new(); let e = root_env(); - eval_test(true, &g, &e, &format!("{} (match (+ 1 2) 1 2 2 3 3 4 _ 0)", *MATCH), 4); - eval_test(true, &g, &e, &format!("{} (match '(1 2) 1 2 2 3 3 4 _ 0)", *MATCH), 0); - eval_test(true, &g, &e, &format!("{} (match '(1 2) 1 2 2 3 (a b) (+ a (+ 2 b)) _ 0)", *MATCH), 5); - eval_test(true, &g, &e, &format!("{} (match '(1 2) 1 2 2 3 '(1 2) 7 _ 0)", *MATCH), 7); - eval_test(true, &g, &e, &format!("{} (let1 a 70 (match (+ 60 10) (unquote a) 100 2 3 _ 0))", *MATCH), 100); -} -static RBTREE: Lazy = Lazy::new(|| { - format!(" - {} - !(let1 empty (list 'B nil nil nil)) - !(let1 E empty) - !(let1 EE (list 'BB nil nil nil)) - - !(let1 generic-foldl (rlambda generic-foldl (f z t) (match t - (unquote E) z - - (c a x b) !(let1 new_left_result (generic-foldl f z a)) - !(let1 folded (f new_left_result x)) - (generic-foldl f folded b)))) - - !(let1 blacken (lambda (t) (match t - ('R a x b) (list 'B a x b) - t t))) - !(let1 balance (lambda (t) (match t - ; figures 1 and 2 - ('B ('R ('R a x b) y c) z d) (list 'R (list 'B a x b) y (list 'B c z d)) - ('B ('R a x ('R b y c)) z d) (list 'R (list 'B a x b) y (list 'B c z d)) - ('B a x ('R ('R b y c) z d)) (list 'R (list 'B a x b) y (list 'B c z d)) - ('B a x ('R b y ('R c z d))) (list 'R (list 'B a x b) y (list 'B c z d)) - ; figure 8, double black cases - ('BB ('R a x ('R b y c)) z d) (list 'B (list 'B a x b) y (list 'B c z d)) - ('BB a x ('R ('R b y c) z d)) (list 'B (list 'B a x b) y (list 'B c z d)) - ; already balenced - t t))) - - !(let1 map-insert !(let1 ins (rlambda ins (t k v) (match t - (unquote E) (list 'R t (list k v) t) - (c a x b) !(if (< k (car x)) (balance (list c (ins a k v) x b))) - !(if (= k (car x)) (list c a (list k v) b)) - (balance (list c a x (ins b k v)))))) - (lambda (t k v) (blacken (ins t k v)))) - - !(let1 map-empty empty) - - !(let1 make-test-tree (rlambda make-test-tree (n t) (if (<= n 0) t - (make-test-tree (- n 1) (map-insert t n (= 0 (% n 10))))))) - !(let1 reduce-test-tree (lambda (tree) (generic-foldl (lambda (a x) (if (car (cdr x)) (+ a 1) a)) 0 tree))) - ", *MATCH) -}); -#[test] -fn rbtree_eval_test() { let g = grammar::TermParser::new(); let e = root_env(); - eval_test(false, &g, &e, &format!("{} (reduce-test-tree (make-test-tree 10 map-empty))", *RBTREE), 1); - //eval_test(false, &g, &e, &format!("{} (reduce-test-tree (make-test-tree 20 map-empty))", *RBTREE), 2); -} diff --git a/kv/Cargo.lock b/kv/Cargo.lock index cc6ee43..af9b59e 100644 --- a/kv/Cargo.lock +++ b/kv/Cargo.lock @@ -4,29 +4,30 @@ version = 3 [[package]] name = "ahash" -version = "0.8.3" +version = "0.8.6" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "2c99f64d1e06488f620f932677e24bc6e2897582980441ae90a671415bd7ec2f" +checksum = "91429305e9f0a25f6205c5b8e0d2db09e0708a7a6df0f42212bb56c32c8ac97a" dependencies = [ "cfg-if", "once_cell", "version_check", + "zerocopy", ] [[package]] name = "aho-corasick" -version = "1.0.2" +version = "1.1.2" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "43f6cb1bf222025340178f382c426f13757b2960e89779dfcb319c32542a5a41" +checksum = "b2969dcb958b36655471fc61f7e416fa76033bdd4bfed0678d8fee1e2d07a1f0" dependencies = [ "memchr", ] [[package]] name = "anyhow" -version = "1.0.71" +version = "1.0.75" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "9c7d0618f0e0b7e8ff11427422b64564d5fb0be1940354bfe2e0529b18a9d9b8" +checksum = "a4668cab20f66d8d020e1fbc0ebe47217433c1b6c8f2040faf858554e394ace6" [[package]] name = "ascii-canvas" @@ -66,27 +67,21 @@ checksum = "bef38d45163c2f1dde094a7dfd33ccf595c92905c8f8f4fdc18d06fb1037718a" [[package]] name = "bitflags" -version = "2.3.3" +version = "2.4.1" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "630be753d4e58660abd17930c71b647fe46c27ea6b63cc59e1e3851406972e42" +checksum = "327762f6e5a765692301e5bb513e0d9fef63be86bbc14528052b1cd3e6f03e07" [[package]] name = "bumpalo" -version = "3.13.0" +version = "3.14.0" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "a3e2c3daef883ecc1b5d58c15adae93470a91d425f3532ba1695849656af3fc1" +checksum = "7f30e7476521f6f8af1a1c4c0b8cc94f0bee37d91763d0ca2665f299b6cd8aec" [[package]] name = "byteorder" -version = "1.4.3" +version = "1.5.0" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "14c189c53d098945499cdfa7ecc63567cf3886b3332b312a5b4585d8d3a6a610" - -[[package]] -name = "cc" -version = "1.0.79" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "50d30906286121d95be3d479533b458f87493b30a4b5f79a607db8f5d11aa91f" +checksum = "1fd0f2584146f6f2ef48085050886acf353beff7305ebd1ae69500e27c67f64b" [[package]] name = "cfg-if" @@ -247,9 +242,9 @@ dependencies = [ [[package]] name = "either" -version = "1.8.1" +version = "1.9.0" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "7fcaabb2fef8c910e7f4c7ce9f67a1283a1715879a7c230ca9d6d1ae31f16d91" +checksum = "a26ae43d7bcc3b814de94796a5e736d4029efb0ee900c12e2d54c993ad1a1e07" [[package]] name = "ena" @@ -261,24 +256,19 @@ dependencies = [ ] [[package]] -name = "errno" -version = "0.3.1" +name = "equivalent" +version = "1.0.1" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "4bcfec3a70f97c962c307b2d2c56e358cf1d00b558d74262b5f929ee8cc7e73a" -dependencies = [ - "errno-dragonfly", - "libc", - "windows-sys 0.48.0", -] +checksum = "5443807d6dff69373d433ab9ef5378ad8df50ca6298caf15de6e52e24aaf54d5" [[package]] -name = "errno-dragonfly" -version = "0.1.2" +name = "errno" +version = "0.3.7" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "aa68f1b12764fab894d2755d2518754e71b4fd80ecfb822714a1206c2aab39bf" +checksum = "f258a7194e7f7c2a7837a8913aeab7fd8c383457034fa20ce4dd3dcb813e8eb8" dependencies = [ - "cc", "libc", + "windows-sys 0.48.0", ] [[package]] @@ -304,9 +294,9 @@ dependencies = [ [[package]] name = "getrandom" -version = "0.2.10" +version = "0.2.11" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "be4136b2a15dd319360be1c07d9933517ccf0be8f16bf62a3bee4f0d618df427" +checksum = "fe9006bed769170c11f845cf00c7c1e9092aeb3f268e007c3e760ac68008070f" dependencies = [ "cfg-if", "libc", @@ -320,7 +310,7 @@ source = "registry+https://github.com/rust-lang/crates.io-index" checksum = "b6c80984affa11d98d1b88b66ac8853f143217b399d3c74116778ff8fdb4ed2e" dependencies = [ "fallible-iterator", - "indexmap", + "indexmap 1.9.3", "stable_deref_trait", ] @@ -340,10 +330,16 @@ dependencies = [ ] [[package]] -name = "hermit-abi" -version = "0.3.1" +name = "hashbrown" +version = "0.14.2" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "fed44880c466736ef9a5c5b5facefb5ed0785676d0c02d612db14e54f0d84286" +checksum = "f93e7192158dbcda357bdec5fb5788eebf8bbac027f3f33e719d29135ae84156" + +[[package]] +name = "hermit-abi" +version = "0.3.3" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "d77f7ec81a6d05a3abb01ab6eb7590f6083d08449fe5a1c8b1e620283546ccb7" [[package]] name = "indexmap" @@ -356,10 +352,20 @@ dependencies = [ ] [[package]] -name = "is-terminal" -version = "0.4.8" +name = "indexmap" +version = "2.1.0" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "24fddda5af7e54bf7da53067d6e802dbcc381d0a8eef629df528e3ebf68755cb" +checksum = "d530e1a18b1cb4c484e6e34556a0d948706958449fca0cab753d649f2bce3d1f" +dependencies = [ + "equivalent", + "hashbrown 0.14.2", +] + +[[package]] +name = "is-terminal" +version = "0.4.9" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "cb0889898416213fab133e1d33a0e5858a48177452750691bde3666d0fdbaf8b" dependencies = [ "hermit-abi", "rustix", @@ -423,21 +429,32 @@ dependencies = [ [[package]] name = "libc" -version = "0.2.147" +version = "0.2.150" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "b4668fb0ea861c1df094127ac5f1da3409a82116a4ba74fca2e58ef927159bb3" +checksum = "89d92a4743f9a61002fae18374ed11e7973f530cb3a3255fb354818118b2203c" + +[[package]] +name = "libredox" +version = "0.0.1" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "85c833ca1e66078851dba29046874e38f08b2c883700aa29a03ddd3b23814ee8" +dependencies = [ + "bitflags 2.4.1", + "libc", + "redox_syscall", +] [[package]] name = "linux-raw-sys" -version = "0.4.3" +version = "0.4.11" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "09fc20d2ca12cb9f044c93e3bd6d32d523e6e2ec3db4f7b2939cd99026ecd3f0" +checksum = "969488b55f8ac402214f3f5fd243ebb7206cf82de60d3172994707a4bcc2b829" [[package]] name = "lock_api" -version = "0.4.10" +version = "0.4.11" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "c1cc9717a20b1bb222f333e6a92fd32f7d8a18ddc5a3191a11af45dcbf4dcd16" +checksum = "3c168f8615b12bc01f9c17e2eb0cc07dcae1940121185446edc3744920e8ef45" dependencies = [ "autocfg", "scopeguard", @@ -445,9 +462,9 @@ dependencies = [ [[package]] name = "log" -version = "0.4.19" +version = "0.4.20" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "b06a4cde4c0f271a446782e3eff8de789548ce57dbc8eca9292c27f4a42004b4" +checksum = "b5e6163cb8c49088c2c36f57875e58ccd8c87c7427f7fbd50ea6710b2f3f2e8f" [[package]] name = "mach" @@ -460,9 +477,9 @@ dependencies = [ [[package]] name = "memchr" -version = "2.5.0" +version = "2.6.4" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "2dffe52ecf27772e601905b7522cb4ef790d2cc203488bbd0e2fe85fcb74566d" +checksum = "f665ee40bc4a3c5590afb1e9677db74a508659dfd71e126420da8274909a0167" [[package]] name = "new_debug_unreachable" @@ -488,25 +505,25 @@ dependencies = [ [[package]] name = "parking_lot_core" -version = "0.9.8" +version = "0.9.9" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "93f00c865fe7cabf650081affecd3871070f26767e7b2070a3ffae14c654b447" +checksum = "4c42a9226546d68acdd9c0a280d17ce19bfe27a46bf68784e4066115788d008e" dependencies = [ "cfg-if", "libc", - "redox_syscall 0.3.5", + "redox_syscall", "smallvec", - "windows-targets 0.48.1", + "windows-targets 0.48.5", ] [[package]] name = "petgraph" -version = "0.6.3" +version = "0.6.4" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "4dd7d28ee937e54fe3080c91faa1c3a46c06de6252988a7f4592ba2310ef22a4" +checksum = "e1d3afd2628e69da2be385eb6f2fd57c8ac7977ceeff6dc166ff1657b0e386a9" dependencies = [ "fixedbitset", - "indexmap", + "indexmap 2.1.0", ] [[package]] @@ -526,48 +543,39 @@ checksum = "925383efa346730478fb4838dbe9137d2a47675ad789c546d150a6e1dd4ab31c" [[package]] name = "proc-macro2" -version = "1.0.63" +version = "1.0.69" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "7b368fba921b0dce7e60f5e04ec15e565b3303972b42bcfde1d0713b881959eb" +checksum = "134c189feb4956b20f6f547d2cf727d4c0fe06722b20a0eec87ed445a97f92da" dependencies = [ "unicode-ident", ] [[package]] name = "quote" -version = "1.0.29" +version = "1.0.33" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "573015e8ab27661678357f27dc26460738fd2b6c86e46f386fde94cb5d913105" +checksum = "5267fca4496028628a95160fc423a33e8b2e6af8a5302579e322e4b520293cae" dependencies = [ "proc-macro2", ] [[package]] name = "redox_syscall" -version = "0.2.16" +version = "0.4.1" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "fb5a58c1855b4b6819d59012155603f0b22ad30cad752600aadfcb695265519a" -dependencies = [ - "bitflags 1.3.2", -] - -[[package]] -name = "redox_syscall" -version = "0.3.5" -source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "567664f262709473930a4bf9e51bf2ebf3348f2e748ccc50dea20646858f8f29" +checksum = "4722d768eff46b75989dd134e5c353f0d6296e5aaa3132e776cbdb56be7731aa" dependencies = [ "bitflags 1.3.2", ] [[package]] name = "redox_users" -version = "0.4.3" +version = "0.4.4" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "b033d837a7cf162d7993aded9304e30a83213c648b6e389db233191f891e5c2b" +checksum = "a18479200779601e498ada4e8c1e1f50e3ee19deb0259c25825a98b5603b2cb4" dependencies = [ "getrandom", - "redox_syscall 0.2.16", + "libredox", "thiserror", ] @@ -585,13 +593,25 @@ dependencies = [ [[package]] name = "regex" -version = "1.8.4" +version = "1.10.2" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "d0ab3ca65655bb1e41f2a8c8cd662eb4fb035e67c3f78da1d61dffe89d07300f" +checksum = "380b951a9c5e80ddfd6136919eef32310721aa4aacd4889a8d39124b026ab343" dependencies = [ "aho-corasick", "memchr", - "regex-syntax 0.7.2", + "regex-automata", + "regex-syntax 0.8.2", +] + +[[package]] +name = "regex-automata" +version = "0.4.3" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "5f804c7828047e88b2d32e2d7fe5a105da8ee3264f01902f796c8e067dc2483f" +dependencies = [ + "aho-corasick", + "memchr", + "regex-syntax 0.8.2", ] [[package]] @@ -602,9 +622,9 @@ checksum = "f162c6dd7b008981e4d40210aca20b4bd0f9b60ca9271061b07f78537722f2e1" [[package]] name = "regex-syntax" -version = "0.7.2" +version = "0.8.2" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "436b050e76ed2903236f032a59761c1eb99e1b0aead2c257922771dab1fc8c78" +checksum = "c08c74e62047bb2de4ff487b251e4a92e24f48745648451635cec7d591162d9f" [[package]] name = "region" @@ -620,11 +640,11 @@ dependencies = [ [[package]] name = "rustix" -version = "0.38.2" +version = "0.38.25" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "aabcb0461ebd01d6b79945797c27f8529082226cb630a9865a71870ff63532a4" +checksum = "dc99bc2d4f1fed22595588a013687477aedf3cdcfb26558c559edb67b4d9b22e" dependencies = [ - "bitflags 2.3.3", + "bitflags 2.4.1", "errno", "libc", "linux-raw-sys", @@ -633,21 +653,21 @@ dependencies = [ [[package]] name = "rustversion" -version = "1.0.12" +version = "1.0.14" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "4f3208ce4d8448b3f3e7d168a73f5e0c43a61e32930de3bceeccedb388b6bf06" +checksum = "7ffc183a10b4478d04cbbbfc96d0873219d962dd5accaff2ffbd4ceb7df837f4" [[package]] name = "scopeguard" -version = "1.1.0" +version = "1.2.0" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "d29ab0c6d3fc0ee92fe66e2d99f700eab17a8d57d1c1d3b748380fb20baa78cd" +checksum = "94143f37725109f92c262ed2cf5e59bce7498c01bcc1502d7b9afe439a4e9f49" [[package]] name = "siphasher" -version = "0.3.10" +version = "0.3.11" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "7bd3e3206899af3f8b12af284fafc038cc1dc2b41d1b89dd17297221c5d225de" +checksum = "38b58827f4464d87d377d175e90bf58eb00fd8716ff0a62f80356b5e61555d0d" [[package]] name = "slice-group-by" @@ -657,9 +677,9 @@ checksum = "826167069c09b99d56f31e9ae5c99049e932a98c9dc2dac47645b08dbbf76ba7" [[package]] name = "smallvec" -version = "1.10.0" +version = "1.11.2" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "a507befe795404456341dfab10cef66ead4c041f62b8b11bbb92bffe5d0953e0" +checksum = "4dccd0940a2dcdf68d092b8cbab7dc0ad8fa938bf95787e1b916b0e3d0e8e970" [[package]] name = "stable_deref_trait" @@ -682,9 +702,9 @@ dependencies = [ [[package]] name = "syn" -version = "2.0.23" +version = "2.0.39" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "59fb7d6d8281a51045d62b8eb3a7d1ce347b76f312af50cd3dc0af39c87c1737" +checksum = "23e78b90f2fcf45d3e842032ce32e3f2d1545ba6636271dcbf24fa306d87be7a" dependencies = [ "proc-macro2", "quote", @@ -693,9 +713,9 @@ dependencies = [ [[package]] name = "target-lexicon" -version = "0.12.8" +version = "0.12.12" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "1b1c7f239eb94671427157bd93b3694320f3668d4e1eff08c7285366fd777fac" +checksum = "14c39fd04924ca3a864207c66fc2cd7d22d7c016007f9ce846cbb9326331930a" [[package]] name = "term" @@ -710,18 +730,18 @@ dependencies = [ [[package]] name = "thiserror" -version = "1.0.40" +version = "1.0.50" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "978c9a314bd8dc99be594bc3c175faaa9794be04a5a5e153caba6915336cebac" +checksum = "f9a7210f5c9a7156bb50aa36aed4c95afb51df0df00713949448cf9e97d382d2" dependencies = [ "thiserror-impl", ] [[package]] name = "thiserror-impl" -version = "1.0.40" +version = "1.0.50" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "f9456a42c5b0d803c8cd86e73dd7cc9edd429499f37a3550d286d5e86720569f" +checksum = "266b2e40bc00e5a6c09c3584011e08b06f123c00362c92b975ba9843aaaa14b8" dependencies = [ "proc-macro2", "quote", @@ -739,9 +759,9 @@ dependencies = [ [[package]] name = "unicode-ident" -version = "1.0.9" +version = "1.0.12" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "b15811caf2415fb889178633e7724bad2509101cde276048e013b9def5e51fa0" +checksum = "3354b9ac3fae1ff6755cb6db53683adb661634f67557942dea4facebec0fee4b" [[package]] name = "unicode-xid" @@ -809,7 +829,7 @@ version = "0.48.0" source = "registry+https://github.com/rust-lang/crates.io-index" checksum = "677d2418bec65e3338edb076e806bc1ec15693c5d0104683f2efe857f61056a9" dependencies = [ - "windows-targets 0.48.1", + "windows-targets 0.48.5", ] [[package]] @@ -829,17 +849,17 @@ dependencies = [ [[package]] name = "windows-targets" -version = "0.48.1" +version = "0.48.5" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "05d4b17490f70499f20b9e791dcf6a299785ce8af4d709018206dc5b4953e95f" +checksum = "9a2fa6e2155d7247be68c096456083145c183cbbbc2764150dda45a87197940c" dependencies = [ - "windows_aarch64_gnullvm 0.48.0", - "windows_aarch64_msvc 0.48.0", - "windows_i686_gnu 0.48.0", - "windows_i686_msvc 0.48.0", - "windows_x86_64_gnu 0.48.0", - "windows_x86_64_gnullvm 0.48.0", - "windows_x86_64_msvc 0.48.0", + "windows_aarch64_gnullvm 0.48.5", + "windows_aarch64_msvc 0.48.5", + "windows_i686_gnu 0.48.5", + "windows_i686_msvc 0.48.5", + "windows_x86_64_gnu 0.48.5", + "windows_x86_64_gnullvm 0.48.5", + "windows_x86_64_msvc 0.48.5", ] [[package]] @@ -850,9 +870,9 @@ checksum = "597a5118570b68bc08d8d59125332c54f1ba9d9adeedeef5b99b02ba2b0698f8" [[package]] name = "windows_aarch64_gnullvm" -version = "0.48.0" +version = "0.48.5" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "91ae572e1b79dba883e0d315474df7305d12f569b400fcf90581b06062f7e1bc" +checksum = "2b38e32f0abccf9987a4e3079dfb67dcd799fb61361e53e2882c3cbaf0d905d8" [[package]] name = "windows_aarch64_msvc" @@ -862,9 +882,9 @@ checksum = "e08e8864a60f06ef0d0ff4ba04124db8b0fb3be5776a5cd47641e942e58c4d43" [[package]] name = "windows_aarch64_msvc" -version = "0.48.0" +version = "0.48.5" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "b2ef27e0d7bdfcfc7b868b317c1d32c641a6fe4629c171b8928c7b08d98d7cf3" +checksum = "dc35310971f3b2dbbf3f0690a219f40e2d9afcf64f9ab7cc1be722937c26b4bc" [[package]] name = "windows_i686_gnu" @@ -874,9 +894,9 @@ checksum = "c61d927d8da41da96a81f029489353e68739737d3beca43145c8afec9a31a84f" [[package]] name = "windows_i686_gnu" -version = "0.48.0" +version = "0.48.5" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "622a1962a7db830d6fd0a69683c80a18fda201879f0f447f065a3b7467daa241" +checksum = "a75915e7def60c94dcef72200b9a8e58e5091744960da64ec734a6c6e9b3743e" [[package]] name = "windows_i686_msvc" @@ -886,9 +906,9 @@ checksum = "44d840b6ec649f480a41c8d80f9c65108b92d89345dd94027bfe06ac444d1060" [[package]] name = "windows_i686_msvc" -version = "0.48.0" +version = "0.48.5" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "4542c6e364ce21bf45d69fdd2a8e455fa38d316158cfd43b3ac1c5b1b19f8e00" +checksum = "8f55c233f70c4b27f66c523580f78f1004e8b5a8b659e05a4eb49d4166cca406" [[package]] name = "windows_x86_64_gnu" @@ -898,9 +918,9 @@ checksum = "8de912b8b8feb55c064867cf047dda097f92d51efad5b491dfb98f6bbb70cb36" [[package]] name = "windows_x86_64_gnu" -version = "0.48.0" +version = "0.48.5" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "ca2b8a661f7628cbd23440e50b05d705db3686f894fc9580820623656af974b1" +checksum = "53d40abd2583d23e4718fddf1ebec84dbff8381c07cae67ff7768bbf19c6718e" [[package]] name = "windows_x86_64_gnullvm" @@ -910,9 +930,9 @@ checksum = "26d41b46a36d453748aedef1486d5c7a85db22e56aff34643984ea85514e94a3" [[package]] name = "windows_x86_64_gnullvm" -version = "0.48.0" +version = "0.48.5" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "7896dbc1f41e08872e9d5e8f8baa8fdd2677f29468c4e156210174edc7f7b953" +checksum = "0b7b52767868a23d5bab768e390dc5f5c55825b6d30b86c844ff2dc7414044cc" [[package]] name = "windows_x86_64_msvc" @@ -922,6 +942,26 @@ checksum = "9aec5da331524158c6d1a4ac0ab1541149c0b9505fde06423b02f5ef0106b9f0" [[package]] name = "windows_x86_64_msvc" -version = "0.48.0" +version = "0.48.5" source = "registry+https://github.com/rust-lang/crates.io-index" -checksum = "1a515f5799fe4961cb532f983ce2b23082366b898e52ffbce459c86f67c8378a" +checksum = "ed94fce61571a4006852b7389a063ab983c02eb1bb37b47f8272ce92d06d9538" + +[[package]] +name = "zerocopy" +version = "0.7.26" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "e97e415490559a91254a2979b4829267a57d2fcd741a98eee8b722fb57289aa0" +dependencies = [ + "zerocopy-derive", +] + +[[package]] +name = "zerocopy-derive" +version = "0.7.26" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "dd7e48ccf166952882ca8bd778a43502c64f33bf94c12ebe2a7f08e5a0f6689f" +dependencies = [ + "proc-macro2", + "quote", + "syn", +] diff --git a/kv/src/basic.rs b/kv/src/basic.rs index 11de357..46a9778 100644 --- a/kv/src/basic.rs +++ b/kv/src/basic.rs @@ -166,6 +166,8 @@ impl FormT for Form { Rc::new(Form::Nil))), e: e, nc: Box::new(Cont::MetaRet) }, + // I think this is unnecessary and can just be "metac }," + // because reset puts this metac in metac: Cont::CatchRet { nc: Box::new(metac.clone()), restore_meta: Box::new(metac) } }, PrimCombI::Assert => { let thing = Rc::clone(&ps[0]); diff --git a/misc_tests/basic_match.kp b/misc_tests/basic_match.kp deleted file mode 100644 index 978d12f..0000000 --- a/misc_tests/basic_match.kp +++ /dev/null @@ -1,175 +0,0 @@ -((wrap (vau root_env (quote) -((wrap (vau (let1) -(let1 lambda (vau se (p b1) (wrap (eval (array vau p b1) se))) -(let1 current-env (vau de () de) -(let1 cons (lambda (h t) (concat (array h) t)) -(let1 Y (lambda (f3) - ((lambda (x1) (x1 x1)) - (lambda (x2) (f3 (wrap (vau app_env (& y) (lapply (x2 x2) y app_env))))))) -(let1 vY (lambda (f) - ((lambda (x3) (x3 x3)) - (lambda (x4) (f (vau de1 (& y) (vapply (x4 x4) y de1)))))) -(let1 let (vY (lambda (recurse) (vau de2 (vs b) (cond (= (len vs) 0) (eval b de2) - true (vapply let1 (array (idx vs 0) (idx vs 1) (array recurse (slice vs 2 -1) b)) de2))))) - (let ( - lcompose (lambda (g f) (lambda (& args) (lapply g (array (lapply f args))))) - rec-lambda (vau se (n p b) (eval (array Y (array lambda (array n) (array lambda p b))) se)) - if (vau de (con than & else) (eval (array cond con than - true (cond (> (len else) 0) (idx else 0) - true false)) de)) - - map (lambda (f5 l5) - (let (helper (rec-lambda recurse (f4 l4 n4 i4) - (cond (= i4 (len l4)) n4 - (<= i4 (- (len l4) 4)) (recurse f4 l4 (concat n4 (array - (f4 (idx l4 (+ i4 0))) - (f4 (idx l4 (+ i4 1))) - (f4 (idx l4 (+ i4 2))) - (f4 (idx l4 (+ i4 3))) - )) (+ i4 4)) - true (recurse f4 l4 (concat n4 (array (f4 (idx l4 i4)))) (+ i4 1))))) - (helper f5 l5 (array) 0))) - - - map_i (lambda (f l) - (let (helper (rec-lambda recurse (f l n i) - (cond (= i (len l)) n - (<= i (- (len l) 4)) (recurse f l (concat n (array - (f (+ i 0) (idx l (+ i 0))) - (f (+ i 1) (idx l (+ i 1))) - (f (+ i 2) (idx l (+ i 2))) - (f (+ i 3) (idx l (+ i 3))) - )) (+ i 4)) - true (recurse f l (concat n (array (f i (idx l i)))) (+ i 1))))) - (helper f l (array) 0))) - - filter_i (lambda (f l) - (let (helper (rec-lambda recurse (f l n i) - (if (= i (len l)) - n - (if (f i (idx l i)) (recurse f l (concat n (array (idx l i))) (+ i 1)) - (recurse f l n (+ i 1)))))) - (helper f l (array) 0))) - filter (lambda (f l) (filter_i (lambda (i x) (f x)) l)) - - ; Huge thanks to Oleg Kiselyov for his fantastic website - ; http://okmij.org/ftp/Computation/fixed-point-combinators.html - Y* (lambda (& l) - ((lambda (u) (u u)) - (lambda (p) - (map (lambda (li) (lambda (& x) (lapply (lapply li (p p)) x))) l)))) - vY* (lambda (& l) - ((lambda (u) (u u)) - (lambda (p) - (map (lambda (li) (vau ide (& x) (vapply (lapply li (p p)) x ide))) l)))) - - let-rec (vau de (name_func body) - (let (names (filter_i (lambda (i x) (= 0 (% i 2))) name_func) - funcs (filter_i (lambda (i x) (= 1 (% i 2))) name_func) - overwrite_name (idx name_func (- (len name_func) 2))) - (eval (array let (concat (array overwrite_name (concat (array Y*) (map (lambda (f) (array lambda names f)) funcs))) - (lapply concat (map_i (lambda (i n) (array n (array idx overwrite_name i))) names))) - body) de))) - let-vrec (vau de (name_func body) - (let (names (filter_i (lambda (i x) (= 0 (% i 2))) name_func) - funcs (filter_i (lambda (i x) (= 1 (% i 2))) name_func) - overwrite_name (idx name_func (- (len name_func) 2))) - (eval (array let (concat (array overwrite_name (concat (array vY*) (map (lambda (f) (array lambda names f)) funcs))) - (lapply concat (map_i (lambda (i n) (array n (array idx overwrite_name i))) names))) - body) de))) - - flat_map (lambda (f l) - (let (helper (rec-lambda recurse (f l n i) - (if (= i (len l)) - n - (recurse f l (concat n (f (idx l i))) (+ i 1))))) - (helper f l (array) 0))) - flat_map_i (lambda (f l) - (let (helper (rec-lambda recurse (f l n i) - (if (= i (len l)) - n - (recurse f l (concat n (f i (idx l i))) (+ i 1))))) - (helper f l (array) 0))) - - ; with all this, we make a destrucutring-capable let - let (let ( - destructure_helper (rec-lambda recurse (vs i r) - (cond (= (len vs) i) r - (array? (idx vs i)) (let (bad_sym (str-to-symbol (str (idx vs i))) - new_vs (flat_map_i (lambda (i x) (array x (array idx bad_sym i))) (idx vs i)) - ) - (recurse (concat new_vs (slice vs (+ i 2) -1)) 0 (concat r (array bad_sym (idx vs (+ i 1)))))) - true (recurse vs (+ i 2) (concat r (slice vs i (+ i 2)))) - ))) (vau de (vs b) (vapply let (array (destructure_helper vs 0 (array)) b) de))) - - nil (array) - not (lambda (x) (if x false true)) - or (let (macro_helper (rec-lambda recurse (bs i) (cond (= i (len bs)) false - (= (+ 1 i) (len bs)) (idx bs i) - true (array let (array 'tmp (idx bs i)) (array if 'tmp 'tmp (recurse bs (+ i 1))))))) - (vau se (& bs) (eval (macro_helper bs 0) se))) - and (let (macro_helper (rec-lambda recurse (bs i) (cond (= i (len bs)) true - (= (+ 1 i) (len bs)) (idx bs i) - true (array let (array 'tmp (idx bs i)) (array if 'tmp (recurse bs (+ i 1)) 'tmp))))) - (vau se (& bs) (eval (macro_helper bs 0) se))) - - - - foldl (let (helper (rec-lambda recurse (f z vs i) (if (= i (len (idx vs 0))) z - (recurse f (lapply f (cons z (map (lambda (x) (idx x i)) vs))) vs (+ i 1))))) - (lambda (f z & vs) (helper f z vs 0))) - foldr (let (helper (rec-lambda recurse (f z vs i) (if (= i (len (idx vs 0))) z - (lapply f (cons (recurse f z vs (+ i 1)) (map (lambda (x) (idx x i)) vs)))))) - (lambda (f z & vs) (helper f z vs 0))) - reverse (lambda (x) (foldl (lambda (acc i) (cons i acc)) (array) x)) - zip (lambda (& xs) (lapply foldr (concat (array (lambda (a & ys) (cons ys a)) (array)) xs))) - - match (let ( - evaluate_case (rec-lambda evaluate_case (access c) (cond - (symbol? c) (array true (lambda (b) (array let (array c access) b))) - (and (array? c) (= 2 (len c)) (= 'unquote (idx c 0))) (array (array = access (idx c 1)) (lambda (b) b)) - (and (array? c) (= 2 (len c)) (= 'quote (idx c 0))) (array (array = access c) (lambda (b) b)) - (array? c) (let ( - tests (array and (array array? access) (array = (len c) (array len access))) - (tests body_func) ((rec-lambda recurse (tests body_func i) (if (= i (len c)) - (array tests body_func) - (let ( (inner_test inner_body_func) (evaluate_case (array idx access i) (idx c i)) ) - (recurse (concat tests (array inner_test)) - (lambda (b) (body_func (inner_body_func b))) - (+ i 1))))) - tests (lambda (b) b) 0) - ) (array tests body_func)) - true (array (array = access c) (lambda (b) b)) - )) - helper (rec-lambda helper (x_sym cases i) (cond (< i (- (len cases) 1)) (let ( (test body_func) (evaluate_case x_sym (idx cases i)) ) - (concat (array test (body_func (idx cases (+ i 1)))) (helper x_sym cases (+ i 2)))) - true (array true (array error "none matched")))) - ) (vau de (x & cases) (eval (array let (array '___MATCH_SYM x) (concat (array cond) (helper '___MATCH_SYM cases 0))) de))) - - ll-nil nil - ll-cons array - ll-make (rec-lambda ll-make (n) (if (= 0 n) ll-nil - (ll-cons n (ll-make (- n 1))))) - ll-sum (rec-lambda ll-sum (l) (match l - ,nil 0 - (hh (h t)) (+ h hh (ll-sum t)) - (h t) (+ h (ll-sum t)) - )) - - - monad (array 'write 1 (str "running tree test") (vau (written code) - (array 'args (vau (args code) - ;(array 'exit (log (reduce-test-tree (make-test-tree (read-string (idx args 1)) map-empty)))) - (array 'exit (log (let (l (ll-make (read-string (idx args 1))) - _ (log "swapping to sum") - ) (ll-sum l)))) - )) - )) - - ) monad) -; end of all lets -)))))) -; impl of let1 -)) (vau de (s v b) (eval (array (array wrap (array vau (array s) b)) v) de))) -; impl of quote -)) (vau (x5) x5)) diff --git a/misc_tests/fact.kp b/misc_tests/fact.kp deleted file mode 100644 index 0043d9e..0000000 --- a/misc_tests/fact.kp +++ /dev/null @@ -1,35 +0,0 @@ - -((wrap (vau root_env (quote) -((wrap (vau (let1) -(let1 lambda (vau se (p b1) (wrap (eval (array vau p b1) se))) -(let1 current-env (vau de () de) -(let1 cons (lambda (h t) (concat (array h) t)) -(let1 Y (lambda (f3) - ((lambda (x1) (x1 x1)) - (lambda (x2) (f3 (wrap (vau app_env (& y) (lapply (x2 x2) y app_env))))))) -(let1 vY (lambda (f) - ((lambda (x3) (x3 x3)) - (lambda (x4) (f (vau de1 (& y) (vapply (x4 x4) y de1)))))) -(let1 let (vY (lambda (recurse) (vau de2 (vs b) (cond (= (len vs) 0) (eval b de2) - true (vapply let1 (array (idx vs 0) (idx vs 1) (array recurse (slice vs 2 -1) b)) de2))))) - (let ( - rec-lambda (vau se (n p b) (eval (array Y (array lambda (array n) (array lambda p b))) se)) - - fact (rec-lambda fact (n) (cond (= 0 n) 1 - (= 1 n) 1 - true (* n (fact (- n 1))))) - - monad (array 'write 1 "enter number to fact: " (vau (written code) - (array 'read 0 60 (vau (data code) - (array 'exit (fact (read-string data))) - )) - - )) - - ) monad) -; end of all lets -)))))) -; impl of let1 -)) (vau de (s v b) (eval (array (array wrap (array vau (array s) b)) v) de))) -; impl of quote -)) (vau (x5) x5)) diff --git a/misc_tests/fact_lognoopt.kp b/misc_tests/fact_lognoopt.kp deleted file mode 100644 index 489328b..0000000 --- a/misc_tests/fact_lognoopt.kp +++ /dev/null @@ -1,36 +0,0 @@ - -((wrap (vau root_env (quote) -((wrap (vau (let1) -(let1 lambda (vau se (p b1) (wrap (eval (array vau p b1) se))) -(let1 current-env (vau de () de) -(let1 cons (lambda (h t) (concat (array h) t)) -(let1 Y (lambda (f3) - ((lambda (x1) (x1 x1)) - (lambda (x2) (f3 (wrap (vau app_env (& y) (lapply (x2 x2) y app_env))))))) -(let1 vY (lambda (f) - ((lambda (x3) (x3 x3)) - (lambda (x4) (f (vau de1 (& y) (vapply (x4 x4) y de1)))))) -(let1 let (vY (lambda (recurse) (vau de2 (vs b) (cond (= (len vs) 0) (eval b de2) - true (vapply let1 (array (idx vs 0) (idx vs 1) (array recurse (slice vs 2 -1) b)) de2))))) - (let ( - rec-lambda (vau se (n p b) (eval (array Y (array lambda (array n) (array lambda p b))) se)) - - ;fact (rec-lambda fact (n) (cond (= 0 n) 1 - ; (= 1 n) 1 - ; true (band #xFFFFFF (* n (fact (- n 1)))))) - fact (rec-lambda fact (n r) (cond (= 0 n) r - (= 1 n) r - true (fact (- n 1) (band #xFFFFFF (* n r))))) - - monad (array 'write 1 "hao" (vau (written code) - (array 'exit (log (fact (log 10000) 1))) - - )) - - ) monad) -; end of all lets -)))))) -; impl of let1 -)) (vau de (s v b) (eval (array (array wrap (array vau (array s) b)) v) de))) -; impl of quote -)) (vau (x5) x5)) diff --git a/misc_tests/find.kp b/misc_tests/find.kp deleted file mode 100644 index a6e67ff..0000000 --- a/misc_tests/find.kp +++ /dev/null @@ -1,110 +0,0 @@ - -((wrap (vau root_env (quote) -((wrap (vau (let1) -(let1 lambda (vau se (p b1) (wrap (eval (array vau p b1) se))) -(let1 current-env (vau de () de) -(let1 cons (lambda (h t) (concat (array h) t)) -(let1 Y (lambda (f3) - ((lambda (x1) (x1 x1)) - (lambda (x2) (f3 (lambda (& y) (lapply (x2 x2) y)))))) -(let1 vY (lambda (f) - ((lambda (x3) (x3 x3)) - (lambda (x4) (f (vau de1 (& y) (vapply (x4 x4) y de1)))))) -(let1 let (vY (lambda (recurse) (vau de2 (vs b) (cond (= (len vs) 0) (eval b de2) - true (vapply let1 (array (idx vs 0) (idx vs 1) (array recurse (slice vs 2 -1) b)) de2))))) - (let ( - rec-lambda (vau se (n p b) (eval (array Y (array lambda (array n) (array lambda p b))) se)) - cdr (lambda (x) (slice x 1 -1)) - if (vau de (con than & else) (eval (array cond con than - true (cond (> (len else) 0) (idx else 0) - true false)) de)) - and (let (macro_helper (rec-lambda recurse (bs i) (cond (= i (len bs)) true - (= (+ 1 i) (len bs)) (idx bs i) - true (array let (array 'tmp (idx bs i)) (array if 'tmp (recurse bs (+ i 1)) 'tmp))))) - (vau se (& bs) (eval (macro_helper bs 0) se))) - - ; if len(s1) > 0 && len(sub) > 0: - ; char1 = s1[0] - ; rest1 = s1[1:] - ; char2 = sub[0] - ; rest2 = sub[1:] - ; if char1 == char2: - ; return recurse(rest1, rest2) - ; else - ; return false - ; else if len(s1) > 0 && len(sub) == 0: - ; return true - ; else if len(s1) == 0: - ; return false - ; else: - ; return false - ; - ; - compare_substr (rec-lambda cmp (str1 str2) (let ( - str1_len (len str1) - str2_len (len str2)) - ; len(s1) > 0 && len(sub) > 0 - (cond (and (> str1_len 0) (> str2_len 0)) - (let ( - char1 (idx str1 0) - rest1 (cdr str1) - char2 (idx str2 0) - rest2 (cdr str2) - same_char (= char1 char2) - ; if char1 == char2: return recurse(str, sub) - ; else: return false - ) (cond same_char (cmp rest1 rest2) - true false - )) - ; len(s1) > 0 && len(sub) == 0 - (and (> str1_len 0) (= str2_len 0)) true - ; else - true false - ) - )) - ; i = index of current match start, passed in - ; len1 = len(str) - ; len2 = len(sub) - ; - ; if len2 > len1: - ; return -1 - ; else if len1 > 0 && len2 == 0: - ; // No more substr, we matched? - ; return i - ; else if len1 > 0 && len2 > 0: - ; if compare(str, sub): - ; return i - ; else: - ; rest1 = str[1:] - ; return recurse(rest1, sub, i+1) - ; else - ; return -1 - ; - _find (rec-lambda _find (str sub i) (let ( - len1 (len str) - len2 (len sub) - ) (cond (> len2 len1) -1 - (= len2 0) i - (and (> len1 0) (> len2 0)) (cond (compare_substr str sub) i - true (_find (cdr str) sub (+ i 1))) - true -1 - ))) - ; find the index of a substr in a str - ; check if a substr is in a str - find (lambda (str sub) (_find str sub 0)) - contains (lambda (str sub) (!= (find str sub) -1)) - - monad (array 'write 1 "testing find funcs: \n" (vau (written code) - (array 'write 1 "find in \"foobar\" the string \"oba\"\n" (vau (written code) - (array 'write 1 (concat (str (contains "foobar" "oba")) "\n") (vau (written code) - (array 'exit 0))) - )) - )) - - ) monad) -; end of all lets -)))))) -; impl of let1 -)) (vau de (s v b) (eval (array (array wrap (array vau (array s) b)) v) de))) -; impl of quote -)) (vau (x5) x5)) diff --git a/misc_tests/int2hex.kp b/misc_tests/int2hex.kp deleted file mode 100644 index 2934c2a..0000000 --- a/misc_tests/int2hex.kp +++ /dev/null @@ -1,66 +0,0 @@ - -((wrap (vau root_env (quote) -((wrap (vau (let1) -(let1 lambda (vau se (p b1) (wrap (eval (array vau p b1) se))) -(let1 current-env (vau de () de) -(let1 cons (lambda (h t) (concat (array h) t)) -(let1 Y (lambda (f3) - ((lambda (x1) (x1 x1)) - (lambda (x2) (f3 (lambda (& y) (lapply (x2 x2) y)))))) -(let1 vY (lambda (f) - ((lambda (x3) (x3 x3)) - (lambda (x4) (f (vau de1 (& y) (vapply (x4 x4) y de1)))))) -(let1 let (vY (lambda (recurse) (vau de2 (vs b) (cond (= (len vs) 0) (eval b de2) - true (vapply let1 (array (idx vs 0) (idx vs 1) (array recurse (slice vs 2 -1) b)) de2))))) - (let ( - ; Some helper hex literals - xF 15 - xF0 240 - xFF 255 - xFF00 65280 - xFFFF 65535 - xFFFF0000 4294901760 - - ; nibble to hex digit - nibble_to_hexstr(lambda (n) - (cond (= n 15) "f" - (= n 14) "e" - (= n 13) "d" - (= n 12) "c" - (= n 11) "b" - (= n 10) "a" - true (str n)) - ) - ; char to hex str - char_to_hexstr (lambda (c) - (concat - (nibble_to_hexstr (>> (band c xF0) 4)) - (nibble_to_hexstr (band c xF))) - ) - ; short to hex str - short_to_hexstr (lambda (s) - (concat - (char_to_hexstr (>> (band s xFF00) 8)) - (char_to_hexstr (band s xFF))) - ) - ; 32 bit int to hex string helper - int_to_hexstr (lambda (i) - (str - (concat - (short_to_hexstr (>> (band i xFFFF0000) 16)) - (short_to_hexstr (band i xFFFF))) - ) - ) - - monad (array 'write 1 "enter int to get hex string: " (vau (written code) - (array 'read 0 60 (vau (num code) - (array 'write 1 (concat (int_to_hexstr (read-string num)) "\n") (vau (written code) - (array 'exit 0) - )))))) - ) monad) -; end of all lets -)))))) -; impl of let1 -)) (vau de (s v b) (eval (array (array wrap (array vau (array s) b)) v) de))) -; impl of quote -)) (vau (x5) x5)) diff --git a/misc_tests/leftrotate32bit.kp b/misc_tests/leftrotate32bit.kp deleted file mode 100644 index eb3cf3e..0000000 --- a/misc_tests/leftrotate32bit.kp +++ /dev/null @@ -1,36 +0,0 @@ - -((wrap (vau root_env (quote) -((wrap (vau (let1) -(let1 lambda (vau se (p b1) (wrap (eval (array vau p b1) se))) -(let1 current-env (vau de () de) -(let1 cons (lambda (h t) (concat (array h) t)) -(let1 Y (lambda (f3) - ((lambda (x1) (x1 x1)) - (lambda (x2) (f3 (lambda (& y) (lapply (x2 x2) y)))))) -(let1 vY (lambda (f) - ((lambda (x3) (x3 x3)) - (lambda (x4) (f (vau de1 (& y) (vapply (x4 x4) y de1)))))) -(let1 let (vY (lambda (recurse) (vau de2 (vs b) (cond (= (len vs) 0) (eval b de2) - true (vapply let1 (array (idx vs 0) (idx vs 1) (array recurse (slice vs 2 -1) b)) de2))))) - (let ( - - ; bitwise left rotate - leftrotate (lambda (i shift_amt) - ; Rotate i left by shift amt - (bor (<< i shift_amt) (>> i (- 32 shift_amt))) - ) - - monad (array 'write 1 "enter int to left rotate: " (vau (written code) - (array 'read 0 60 (vau (num code) - (array 'write 1 "enter rotate amount: " (vau (written code) - (array 'read 0 60 (vau (amount code) - (array 'write 1 (concat (str (leftrotate (read-string num) (read-string amount))) "\n") (vau (written code) - (array 'exit 0) - )))))))))) - ) monad) -; end of all lets -)))))) -; impl of let1 -)) (vau de (s v b) (eval (array (array wrap (array vau (array s) b)) v) de))) -; impl of quote -)) (vau (x5) x5)) diff --git a/misc_tests/palindrome.kp b/misc_tests/palindrome.kp deleted file mode 100644 index 3ea6343..0000000 --- a/misc_tests/palindrome.kp +++ /dev/null @@ -1,49 +0,0 @@ - -((wrap (vau root_env (quote) -((wrap (vau (let1) -(let1 lambda (vau se (p b1) (wrap (eval (array vau p b1) se))) -(let1 current-env (vau de () de) -(let1 cons (lambda (h t) (concat (array h) t)) -(let1 Y (lambda (f3) - ((lambda (x1) (x1 x1)) - (lambda (x2) (f3 (lambda (& y) (lapply (x2 x2) y)))))) -(let1 vY (lambda (f) - ((lambda (x3) (x3 x3)) - (lambda (x4) (f (vau de1 (& y) (vapply (x4 x4) y de1)))))) -(let1 let (vY (lambda (recurse) (vau de2 (vs b) (cond (= (len vs) 0) (eval b de2) - true (vapply let1 (array (idx vs 0) (idx vs 1) (array recurse (slice vs 2 -1) b)) de2))))) - (let ( - rec-lambda (vau se (n p b) (eval (array Y (array lambda (array n) (array lambda p b))) se)) - - palindrome (rec-lambda palindrome (s) (let ( - ; _ (log "palindrome called") - length (- (len s) 1) ; -1 because we don't care about \n chars - ; _ (log "length is" (str length)) - ) (cond (= length 0) true - (= length 1) true - true (let ( - ; _ (log "getting first + last chars") - first (idx s 0) - last (idx s (- length 1)) - ; _ (log "Checking chars") - ; _ (log first " == " last) - )(cond (!= first last) false - true (palindrome (slice s 1 -2))) - ) - ))) - palindrome_wrap (lambda (s) (cond (palindrome s) (concat "TRUE! " s " is a palindrome!!\n") - true (concat "FALSE! " s " is not a palindrome!!\n"))) - - - monad (array 'write 1 "enter string to check if it is a palindrome: " (vau (written code) - (array 'read 0 60 (vau (s code) - (array 'write 1 (palindrome_wrap s) (vau (written code) - (array 'exit 0) - )))))) - ) monad) -; end of all lets -)))))) -; impl of let1 -)) (vau de (s v b) (eval (array (array wrap (array vau (array s) b)) v) de))) -; impl of quote -)) (vau (x5) x5)) diff --git a/misc_tests/t.kp b/misc_tests/t.kp deleted file mode 100644 index b23cf36..0000000 --- a/misc_tests/t.kp +++ /dev/null @@ -1,15 +0,0 @@ -((wrap (vau root_env (quote) -((wrap (vau (let1) - - -(array 'write 1 "enter form: " (vau (written code) - (array 'read 0 200 (vau (data code) - ((wrap (vau (asdf) (array 'exit (log (eval (log (read-string data))))))) code) - ;((wrap (vau (asdf) (array 'exit (eval (read-string data))))) code) - ;((wrap (vau (asdf) (array 'exit (cond (log "hi") written true code)))) code) - )) - -)) - -)) (vau de (s v b) (eval (array (array wrap (array vau (array s) b)) v) de))) -)) (vau (x5) x5)) diff --git a/misc_tests/to_compile.kp b/misc_tests/to_compile.kp deleted file mode 100644 index 73bd209..0000000 --- a/misc_tests/to_compile.kp +++ /dev/null @@ -1,917 +0,0 @@ -((wrap (vau root_env (quote) -((wrap (vau (let1) -(let1 lambda (vau se (p b1) (wrap (eval (array vau p b1) se))) -(let1 current-env (vau de () de) -(let1 cons (lambda (h t) (concat (array h) t)) -(let1 Y (lambda (f3) - ((lambda (x1) (x1 x1)) - (lambda (x2) (f3 (wrap (vau app_env (& y) (lapply (x2 x2) y app_env))))))) -(let1 vY (lambda (f) - ((lambda (x3) (x3 x3)) - (lambda (x4) (f (vau de1 (& y) (vapply (x4 x4) y de1)))))) -(let1 let (vY (lambda (recurse) (vau de2 (vs b) (cond (= (len vs) 0) (eval b de2) - true (vapply let1 (array (idx vs 0) (idx vs 1) (array recurse (slice vs 2 -1) b)) de2))))) - (let ( - lcompose (lambda (g f) (lambda (& args) (lapply g (array (lapply f args))))) - rec-lambda (vau se (n p b) (eval (array Y (array lambda (array n) (array lambda p b))) se)) - ;if (vau de (con than & else) (cond (eval con de) (eval than de) - ; (> (len else) 0) (eval (idx else 0) de) - ; true false)) - if (vau de (con than & else) (eval (array cond con than - true (cond (> (len else) 0) (idx else 0) - true false)) de)) - - map (lambda (f5 l5) - ; now maybe errors on can't find helper? - (let (helper (rec-lambda recurse (f4 l4 n4 i4) - (cond (= i4 (len l4)) n4 - (<= i4 (- (len l4) 4)) (recurse f4 l4 (concat n4 (array - (f4 (idx l4 (+ i4 0))) - (f4 (idx l4 (+ i4 1))) - (f4 (idx l4 (+ i4 2))) - (f4 (idx l4 (+ i4 3))) - )) (+ i4 4)) - true (recurse f4 l4 (concat n4 (array (f4 (idx l4 i4)))) (+ i4 1))))) - (helper f5 l5 (array) 0))) - - - map_i (lambda (f l) - (let (helper (rec-lambda recurse (f l n i) - (cond (= i (len l)) n - (<= i (- (len l) 4)) (recurse f l (concat n (array - (f (+ i 0) (idx l (+ i 0))) - (f (+ i 1) (idx l (+ i 1))) - (f (+ i 2) (idx l (+ i 2))) - (f (+ i 3) (idx l (+ i 3))) - )) (+ i 4)) - true (recurse f l (concat n (array (f i (idx l i)))) (+ i 1))))) - (helper f l (array) 0))) - - filter_i (lambda (f l) - (let (helper (rec-lambda recurse (f l n i) - (if (= i (len l)) - n - (if (f i (idx l i)) (recurse f l (concat n (array (idx l i))) (+ i 1)) - (recurse f l n (+ i 1)))))) - (helper f l (array) 0))) - filter (lambda (f l) (filter_i (lambda (i x) (f x)) l)) - - ; Huge thanks to Oleg Kiselyov for his fantastic website - ; http://okmij.org/ftp/Computation/fixed-point-combinators.html - Y* (lambda (& l) - ((lambda (u) (u u)) - (lambda (p) - (map (lambda (li) (lambda (& x) (lapply (lapply li (p p)) x))) l)))) - vY* (lambda (& l) - ((lambda (u) (u u)) - (lambda (p) - (map (lambda (li) (vau ide (& x) (vapply (lapply li (p p)) x ide))) l)))) - - let-rec (vau de (name_func body) - (let (names (filter_i (lambda (i x) (= 0 (% i 2))) name_func) - funcs (filter_i (lambda (i x) (= 1 (% i 2))) name_func) - overwrite_name (idx name_func (- (len name_func) 2))) - (eval (array let (concat (array overwrite_name (concat (array Y*) (map (lambda (f) (array lambda names f)) funcs))) - (lapply concat (map_i (lambda (i n) (array n (array idx overwrite_name i))) names))) - body) de))) - let-vrec (vau de (name_func body) - (let (names (filter_i (lambda (i x) (= 0 (% i 2))) name_func) - funcs (filter_i (lambda (i x) (= 1 (% i 2))) name_func) - overwrite_name (idx name_func (- (len name_func) 2))) - (eval (array let (concat (array overwrite_name (concat (array vY*) (map (lambda (f) (array lambda names f)) funcs))) - (lapply concat (map_i (lambda (i n) (array n (array idx overwrite_name i))) names))) - body) de))) - - flat_map (lambda (f l) - (let (helper (rec-lambda recurse (f l n i) - (if (= i (len l)) - n - (recurse f l (concat n (f (idx l i))) (+ i 1))))) - (helper f l (array) 0))) - flat_map_i (lambda (f l) - (let (helper (rec-lambda recurse (f l n i) - (if (= i (len l)) - n - (recurse f l (concat n (f i (idx l i))) (+ i 1))))) - (helper f l (array) 0))) - - ; with all this, we make a destrucutring-capable let - let (let ( - destructure_helper (rec-lambda recurse (vs i r) - (cond (= (len vs) i) r - (array? (idx vs i)) (let (bad_sym (str-to-symbol (str (idx vs i))) - new_vs (flat_map_i (lambda (i x) (array x (array idx bad_sym i))) (idx vs i)) - ) - (recurse (concat new_vs (slice vs (+ i 2) -1)) 0 (concat r (array bad_sym (idx vs (+ i 1)))))) - true (recurse vs (+ i 2) (concat r (slice vs i (+ i 2)))) - ))) (vau de (vs b) (vapply let (array (destructure_helper vs 0 (array)) b) de))) - - ; and a destructuring-capable lambda! - only_symbols (rec-lambda recurse (a i) (cond (= i (len a)) true - (symbol? (idx a i)) (recurse a (+ i 1)) - true false)) - - ; Note that if macro_helper is inlined, the mapping lambdas will close over - ; se, and then not be able to be taken in as values to the maps, and the vau - ; will fail to partially evaluate away. - lambda (let (macro_helper (lambda (p b) (let ( - sym_params (map (lambda (param) (if (symbol? param) param - (str-to-symbol (str param)))) p) - body (array let (flat_map_i (lambda (i x) (array (idx p i) x)) sym_params) b) - ) (array vau sym_params body)))) - (vau se (p b) (if (only_symbols p 0) (vapply lambda (array p b) se) - (wrap (eval (macro_helper p b) se))))) - - ; and rec-lambda - yes it's the same definition again - rec-lambda (vau se (n p b) (eval (array Y (array lambda (array n) (array lambda p b))) se)) - - nil (array) - not (lambda (x) (if x false true)) - or (let (macro_helper (rec-lambda recurse (bs i) (cond (= i (len bs)) false - (= (+ 1 i) (len bs)) (idx bs i) - true (array let (array 'tmp (idx bs i)) (array if 'tmp 'tmp (recurse bs (+ i 1))))))) - (vau se (& bs) (eval (macro_helper bs 0) se))) - and (let (macro_helper (rec-lambda recurse (bs i) (cond (= i (len bs)) true - (= (+ 1 i) (len bs)) (idx bs i) - true (array let (array 'tmp (idx bs i)) (array if 'tmp (recurse bs (+ i 1)) 'tmp))))) - (vau se (& bs) (eval (macro_helper bs 0) se))) - - - - foldl (let (helper (rec-lambda recurse (f z vs i) (if (= i (len (idx vs 0))) z - (recurse f (lapply f (cons z (map (lambda (x) (idx x i)) vs))) vs (+ i 1))))) - (lambda (f z & vs) (helper f z vs 0))) - foldr (let (helper (rec-lambda recurse (f z vs i) (if (= i (len (idx vs 0))) z - (lapply f (cons (recurse f z vs (+ i 1)) (map (lambda (x) (idx x i)) vs)))))) - (lambda (f z & vs) (helper f z vs 0))) - reverse (lambda (x) (foldl (lambda (acc i) (cons i acc)) (array) x)) - zip (lambda (& xs) (lapply foldr (concat (array (lambda (a & ys) (cons ys a)) (array)) xs))) - - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ; Begin kludges to align with Scheme kludges - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - dlet (vau se (inners body) (vapply let (array (lapply concat inners) body) se)) - cond (vau se (& inners) (vapply cond (lapply concat inners) se)) - print log - println log - dlambda lambda - mif (vau de (c & bs) (vapply if (cons (array let (array 'tmp c) (array and (array != 'tmp (array quote (array))) 'tmp)) bs) de)) - ;mif (vau de (c & bs) (eval (concat (array if (array let (array 'tmp c) (array and (array != 'tmp) 'tmp))) bs) de)) - - - ) - (dlet ( - - (empty_dict-list (array)) - (put-list (lambda (m k v) (cons (array k v) m))) - (get-list (lambda (d k) ((rec-lambda recurse (k d len_d i) (cond ((= len_d i) false) - ((= k (idx (idx d i) 0)) (idx d i)) - (true (recurse k d len_d (+ 1 i))))) - k d (len d) 0))) - - ;(combine_hash (lambda (a b) (+ (* 37 a) b))) - (combine_hash (lambda (a b) (band #xFFFFFFFFFFFFFF (+ (* 37 a) b)))) - (hash_bool (lambda (b) (if b 2 3))) - (hash_num (lambda (n) (combine_hash 5 n))) - ;(hash_string (lambda (s) (foldl combine_hash 7 (map char->integer (string->list s))))) - (hash_string (lambda (s) (foldl combine_hash 7 s))) - ;(hash_string (lambda (s) (foldl combine_hash 102233 (map char->integer (string->list s))))) - - (empty_dict-tree nil) - (trans-key (lambda (k) (cond ((string? k) (hash_string k)) - ((symbol? k) (hash_string (get-text k))) - (true k)))) - (put-helper (rec-lambda put-helper (m hk k v) (cond ((nil? m) (array hk k v nil nil)) - ((and (= hk (idx m 0)) - (= k (idx m 1))) (array hk k v (idx m 3) (idx m 4))) - ((< hk (idx m 0)) (array (idx m 0) (idx m 1) (idx m 2) (put-helper (idx m 3) hk k v) (idx m 4))) - (true (array (idx m 0) (idx m 1) (idx m 2) (idx m 3) (put-helper (idx m 4) hk k v)))))) - (put-tree (lambda (m k v) (put-helper m (trans-key k) k v))) - (get-helper (rec-lambda get-helper (m hk k) (cond ((nil? m) false) - ((and (= hk (idx m 0)) - (= k (idx m 1))) (array k (idx m 2))) - ((< hk (idx m 0)) (get-helper (idx m 3) hk k)) - (true (get-helper (idx m 4) hk k))))) - (get-tree (lambda (m k) (get-helper m (trans-key k) k))) - - ;(empty_dict empty_dict-list) - ;(put put-list) - ;(get get-list) - (empty_dict empty_dict-tree) - (put put-tree) - (get get-tree) - - (get-value (lambda (d k) (dlet ((result (get d k))) - (if (array? result) (idx result 1) - (error (str "could not find " k " in " d)))))) - (get-value-or-false (lambda (d k) (dlet ((result (get d k))) - (if (array? result) (idx result 1) - false)))) - - - - (in_array (dlet ((helper (rec-lambda recurse (x a len_a i) (cond ((= i len_a) false) - ((= x (idx a i)) true) - (true (recurse x a len_a (+ i 1))))))) - (lambda (x a) (helper x a (len a) 0)))) - (array_item_union (lambda (a bi) (if (in_array bi a) a (cons bi a)))) - (array_union (lambda (a b) (foldl array_item_union a b))) - (array_union_without (lambda (wo a b) - (foldl (lambda (o xi) (if (or (= wo xi) (in_array xi o)) o (cons xi o))) - (array) (concat a b)))) - - ; just for now, should just add all normal linked list primitives - ; as they should be - (car (lambda (x) (idx x 0))) - (cdr (lambda (x) (slice x 1 -1))) - - (intset_word_size 64) - (in_intset (rec-lambda in_intset (x a) (cond ((nil? a) false) - ((>= x intset_word_size) (in_intset (- x intset_word_size) (cdr a))) - (true (!= (band (>> (car a) x) 1) 0))))) - - (intset_item_union (rec-lambda intset_item_union (a bi) (cond ((nil? a) (intset_item_union (array 0) bi)) - ((>= bi intset_word_size) (cons (car a) (intset_item_union (cdr a) (- bi intset_word_size)))) - (true (cons (bor (car a) (<< 1 bi)) (cdr a)))))) - - (intset_item_remove (rec-lambda intset_item_remove (a bi) (cond ((nil? a) nil) - ((>= bi intset_word_size) (dlet ((new_tail (intset_item_remove (cdr a) (- bi intset_word_size)))) - (if (and (nil? new_tail) (= 0 (car a))) nil - (cons (car a) new_tail)))) - (true (dlet ((new_int (band (car a) (bnot (<< 1 bi))))) - (if (and (nil? (cdr a)) (= 0 new_int)) nil - (cons new_int (cdr a)))))))) - (intset_union (rec-lambda intset_union (a b) (cond ((and (nil? a) (nil? b)) nil) - ((nil? a) b) - ((nil? b) a) - (true (cons (bor (car a) (car b)) (intset_union (cdr a) (cdr b))))))) - - (intset_intersection_nonempty (rec-lambda intset_intersection_nonempty (a b) (cond ((nil? a) false) - ((nil? b) false) - (true (or (!= 0 (band (car a) (car b))) (intset_intersection_nonempty (cdr a) (cdr b))))))) - - (intset_union_without (lambda (wo a b) (intset_item_remove (intset_union a b) wo))) - - - (val? (lambda (x) (= 'val (idx x 0)))) - (marked_array? (lambda (x) (= 'marked_array (idx x 0)))) - (marked_symbol? (lambda (x) (= 'marked_symbol (idx x 0)))) - (comb? (lambda (x) (= 'comb (idx x 0)))) - (prim_comb? (lambda (x) (= 'prim_comb (idx x 0)))) - (marked_env? (lambda (x) (= 'env (idx x 0)))) - - (.hash (lambda (x) (idx x 1))) - - (.val (lambda (x) (idx x 2))) - - (.marked_array_is_val (lambda (x) (idx x 2))) - (.marked_array_is_attempted (lambda (x) (idx x 3))) - (.marked_array_needed_for_progress (lambda (x) (idx x 4))) - (.marked_array_values (lambda (x) (idx x 5))) - - (.marked_symbol_needed_for_progress (lambda (x) (idx x 2))) - (.marked_symbol_is_val (lambda (x) (= nil (.marked_symbol_needed_for_progress x)))) - (.marked_symbol_value (lambda (x) (idx x 3))) - (.comb (lambda (x) (slice x 2 -1))) - (.comb_id (lambda (x) (idx x 3))) - (.comb_des (lambda (x) (idx x 4))) - (.comb_env (lambda (x) (idx x 5))) - (.comb_body (lambda (x) (idx x 8))) - (.comb_wrap_level (lambda (x) (idx x 2))) - (.prim_comb_sym (lambda (x) (idx x 3))) - (.prim_comb_handler (lambda (x) (idx x 2))) - (.prim_comb_wrap_level (lambda (x) (idx x 4))) - (.prim_comb_val_head_ok (lambda (x) (idx x 5))) - (.prim_comb (lambda (x) (slice x 2 -1))) - - (.marked_env (lambda (x) (slice x 2 -1))) - (.marked_env_has_vals (lambda (x) (idx x 2))) - (.marked_env_needed_for_progress (lambda (x) (idx x 3))) - (.marked_env_idx (lambda (x) (idx x 4))) - (.marked_env_upper (lambda (x) (idx (idx x 5) -1))) - (.env_marked (lambda (x) (idx x 5))) - (marked_env_real? (lambda (x) (= nil (idx (.marked_env_needed_for_progress x) 0)))) - (.any_comb_wrap_level (lambda (x) (cond ((prim_comb? x) (.prim_comb_wrap_level x)) - ((comb? x) (.comb_wrap_level x)) - (true (error "bad .any_comb_level"))))) - ; The actual needed_for_progress values are either - ; #t - any eval will do something - ; nil - is a value, no eval will do anything - ; (3 4 1...) - list of env ids that would allow forward progress - ; But these are paired with another list of hashes that if you're not inside - ; of an evaluation of, then it could progress futher. These are all caused by - ; the infinite recursion stopper. - (needed_for_progress (rec-lambda needed_for_progress (x) (cond ((marked_array? x) (.marked_array_needed_for_progress x)) - ((marked_symbol? x) (array (.marked_symbol_needed_for_progress x) nil nil)) - ((marked_env? x) (.marked_env_needed_for_progress x)) - ((comb? x) (dlet ((id (.comb_id x)) - ((body_needed _hashes extra1) (needed_for_progress (.comb_body x))) - ((se_needed _hashes extra2) (needed_for_progress (.comb_env x)))) - (if (or (= true body_needed) (= true se_needed)) (array true nil nil) - (array (array_union_without id body_needed se_needed) - nil (array_union_without id extra1 extra2)) - ))) - ((prim_comb? x) (array nil nil nil)) - ((val? x) (array nil nil nil)) - (true (error (str "what is this? in need for progress" x)))))) - (needed_for_progress_slim (lambda (x) (idx (needed_for_progress x) 0))) - - (hash_symbol (lambda (progress_idxs s) (combine_hash (if (= true progress_idxs) 11 (foldl combine_hash 13 (map (lambda (x) (if (= true x) 13 (+ 1 x))) progress_idxs))) (hash_string (get-text s))))) - (hash_array (lambda (is_val attempted a) (foldl combine_hash (if is_val 17 (cond ((int? attempted) (combine_hash attempted 19)) - (attempted 61) - (true 107))) (map .hash a)))) - - (hash_env (lambda (has_vals progress_idxs dbi arrs) (combine_hash (if has_vals 107 109) - (combine_hash (mif dbi (hash_num dbi) 59) (dlet ( - ;(_ (begin (true_print "pre slice " (slice arrs 0 -2)) 0)) - ;(_ (begin (true_print "about to do a fold " progress_idxs " and " (slice arrs 0 -2)) 0)) - (inner_hash (foldl (dlambda (c (s v)) (combine_hash c (combine_hash (hash_symbol true s) (.hash v)))) - (cond ((= nil progress_idxs) 23) - ((= true progress_idxs) 29) - (true (foldl combine_hash 31 progress_idxs))) - (slice arrs 0 -2))) - (end (idx arrs -1)) - (end_hash (mif end (.hash end) 41)) - ) (combine_hash inner_hash end_hash)))))) - - (hash_comb (lambda (wrap_level env_id de? se variadic params body) - (combine_hash 43 - (combine_hash wrap_level - (combine_hash env_id - (combine_hash (mif de? (hash_symbol true de?) 47) - (combine_hash (.hash se) - (combine_hash (hash_bool variadic) - (combine_hash (foldl (lambda (c x) (combine_hash c (hash_symbol true x))) 53 params) - (.hash body)))))))))) - - (hash_prim_comb (lambda (handler_fun real_or_name wrap_level val_head_ok) (combine_hash (combine_hash 59 (hash_symbol true real_or_name)) - (combine_hash (if val_head_ok 89 97) wrap_level)))) - (hash_val (lambda (x) (cond ((bool? x) (hash_bool x)) - ((string? x) (hash_string x)) - ((int? x) (hash_num x)) - (true (error (str "bad thing to hash_val " x)))))) - ; 113 127 131 137 139 149 151 157 163 167 173 - - (marked_symbol (lambda (progress_idxs x) (array 'marked_symbol (hash_symbol progress_idxs x) progress_idxs x))) - (marked_array (lambda (is_val attempted resume_hashes x) (dlet ( - ((sub_progress_idxs hashes extra) (foldl (dlambda ((a ahs aeei) (x xhs x_extra_env_ids)) - (array (cond ((or (= true a) (= true x)) true) - (true (array_union a x))) - (array_union ahs xhs) - (array_union aeei x_extra_env_ids)) - ) (array (array) resume_hashes (array)) (map needed_for_progress x))) - (progress_idxs (cond ((and (= nil sub_progress_idxs) (not is_val) (= true attempted)) nil) - ((and (= nil sub_progress_idxs) (not is_val) (= false attempted)) true) - ((and (= nil sub_progress_idxs) (not is_val) (int? attempted)) (array attempted)) - (true (if (int? attempted) - (array_item_union sub_progress_idxs attempted) - sub_progress_idxs)))) - ) (array 'marked_array (hash_array is_val attempted x) is_val attempted (array progress_idxs hashes extra) x)))) - (marked_env (lambda (has_vals de? de ue dbi arrs) (dlet ( - (de_entry (mif de? (array (array de? de)) (array))) - (full_arrs (concat arrs de_entry (array ue))) - ((progress_idxs1 _hashes extra1) (mif ue (needed_for_progress ue) (array nil nil nil))) - ((progress_idxs2 _hashes extra2) (mif de? (needed_for_progress de) (array nil nil nil))) - (progress_idxs (array_union progress_idxs1 progress_idxs2)) - (extra (array_union extra1 extra2)) - (progress_idxs (if (not has_vals) (cons dbi progress_idxs) progress_idxs)) - (extra (if (!= nil progress_idxs) (cons dbi extra) extra)) - ) (array 'env (hash_env has_vals progress_idxs dbi full_arrs) has_vals (array progress_idxs nil extra) dbi full_arrs)))) - - - (marked_val (lambda (x) (array 'val (hash_val x) x))) - (marked_comb (lambda (wrap_level env_id de? se variadic params body) (array 'comb (hash_comb wrap_level env_id de? se variadic params body) wrap_level env_id de? se variadic params body))) - (marked_prim_comb (lambda (handler_fun real_or_name wrap_level val_head_ok) (array 'prim_comb (hash_prim_comb handler_fun real_or_name wrap_level val_head_ok) handler_fun real_or_name wrap_level val_head_ok))) - - (with_wrap_level (lambda (x new_wrap) (cond ((prim_comb? x) (dlet (((handler_fun real_or_name wrap_level val_head_ok) (.prim_comb x))) - (marked_prim_comb handler_fun real_or_name new_wrap val_head_ok))) - ((comb? x) (dlet (((wrap_level env_id de? se variadic params body) (.comb x))) - (marked_comb new_wrap env_id de? se variadic params body))) - (true (error "bad with_wrap_level"))))) - - - (later_head? (rec-lambda recurse (x) (or (and (marked_array? x) (or (= false (.marked_array_is_val x)) (foldl (lambda (a x) (or a (recurse x))) false (.marked_array_values x)))) - (and (marked_symbol? x) (= false (.marked_symbol_is_val x))) - ))) - - - ; array and comb are the ones wherewhere (= nil (needed_for_progress_slim x)) == total_value? isn't true. - ; Right now we only call functions when all parameters are values, which means you can't - ; create a true_value array with non-value memebers (*right now* anyway), but it does mean that - ; you can create a nil needed for progress array that isn't a value, namely for the give_up_* - ; primitive functions (extra namely, log and error, which are our two main sources of non-purity besides implicit runtime errors). - ; OR, currently, having your code stopped because of infinite recursion checker. This comes up with the Y combiner - ; For combs, being a value is having your env-chain be real? - (total_value? (lambda (x) (if (marked_array? x) (.marked_array_is_val x) - (= nil (needed_for_progress_slim x))))) - - (is_all_values (lambda (evaled_params) (foldl (lambda (a x) (and a (total_value? x))) true evaled_params))) - (is_all_head_values (lambda (evaled_params) (foldl (lambda (a x) (and a (not (later_head? x)))) true evaled_params))) - - (false? (lambda (x) (cond ((and (marked_array? x) (= false (.marked_array_is_val x))) (error "got a later marked_array passed to false? " x)) - ((and (marked_symbol? x) (= false (.marked_symbol_is_val x))) (error "got a later marked_symbol passed to false? " x)) - ((val? x) (not (.val x))) - (true false)))) - - - (mark (rec-lambda recurse (eval_pos x) (cond ((env? x) (error "called mark with an env " x)) - ((combiner? x) (error "called mark with a combiner " x)) - ((symbol? x) (cond ((= 'true x) (marked_val #t)) - ((= 'false x) (marked_val #f)) - (#t (marked_symbol (if eval_pos true nil) x)))) - ((array? x) (marked_array (not eval_pos) false nil - (idx (foldl (dlambda ((ep a) x) (array false (concat a (array (recurse ep x))))) - (array eval_pos (array)) - x) - 1) - )) - (true (marked_val x))))) - - (indent_str (rec-lambda recurse (i) (mif (= i 0) "" - (str " " (recurse (- i 1)))))) - - (speed_hack true) - (true_str str) - (indent_str (if speed_hack (lambda (i) "") indent_str)) - - (str_strip (lambda (& args) (lapply true_str (concat (slice args 0 -2) (array (idx ((rec-lambda recurse (x done_envs) - (cond ((= nil x) (array "" done_envs)) - ((string? x) (array (true_str "") done_envs)) - ((val? x) (array (true_str (.val x)) done_envs)) - ((marked_array? x) (dlet (((stripped_values done_envs) (foldl (dlambda ((vs de) x) (dlet (((v de) (recurse x de))) (array (concat vs (array v)) de))) - (array (array) done_envs) (.marked_array_values x)))) - (mif (.marked_array_is_val x) (array (true_str "[" stripped_values "]") done_envs) - (array (true_str stripped_values) done_envs)))) - ;(array (true_str "" stripped_values) done_envs)))) - ((marked_symbol? x) (mif (.marked_symbol_is_val x) (array (true_str "'" (.marked_symbol_value x)) done_envs) - (array (true_str (.marked_symbol_needed_for_progress x) "#" (.marked_symbol_value x)) done_envs))) - ((comb? x) (dlet (((wrap_level env_id de? se variadic params body) (.comb x)) - ((se_s done_envs) (recurse se done_envs)) - ((body_s done_envs) (recurse body done_envs))) - (array (true_str "") done_envs))) - ((prim_comb? x) (array (true_str "") done_envs)) - ((marked_env? x) (dlet ((e (.env_marked x)) - (index (.marked_env_idx x)) - (u (idx e -1)) - (already (in_array index done_envs)) - (opening (true_str "{" (mif (marked_env_real? x) "real" "fake") (mif (.marked_env_has_vals x) " real vals" " fake vals") " ENV idx: " (true_str index) ", ")) - ((middle done_envs) (if already (array "" done_envs) (foldl (dlambda ((vs de) (k v)) (dlet (((x de) (recurse v de))) (array (concat vs (array (array k x))) de))) - (array (array) done_envs) - (slice e 0 -2)))) - ((upper done_envs) (if already (array "" done_envs) (mif u (recurse u done_envs) (array "no_upper_likely_root_env" done_envs)))) - (done_envs (if already done_envs (cons index done_envs))) - ) (array (if already (true_str opening "omitted}") - (if (> (len e) 30) (true_str "{" (len e) "env}") - (true_str opening middle " upper: " upper "}"))) done_envs) - )) - (true (error (true_str "some other str_strip? |" x "|"))) - ) - ) (idx args -1) (array)) 0)))))) - - (true_str_strip str_strip) - (str_strip (if speed_hack (lambda (& args) 0) str_strip)) - ;(true_str_strip str_strip) - (print_strip (lambda (& args) (println (lapply str_strip args)))) - - (env-lookup-helper (rec-lambda recurse (dict key i fail success) (cond ((and (= i (- (len dict) 1)) (= nil (idx dict i))) (fail)) - ((= i (- (len dict) 1)) (recurse (.env_marked (idx dict i)) key 0 fail success)) - ((= key (idx (idx dict i) 0)) (success (idx (idx dict i) 1))) - (true (recurse dict key (+ i 1) fail success))))) - (env-lookup (lambda (env key) (env-lookup-helper (.env_marked env) key 0 (lambda () (error (str key " not found in env " (str_strip env)))) (lambda (x) x)))) - - (strip (dlet ((helper (rec-lambda recurse (x need_value) - (cond ((val? x) (.val x)) - ((marked_array? x) (dlet ((stripped_values (map (lambda (x) (recurse x need_value)) (.marked_array_values x)))) - (mif (.marked_array_is_val x) stripped_values - (error (str "needed value for this strip but got" x))))) - ((marked_symbol? x) (mif (.marked_symbol_is_val x) (.marked_symbol_value x) - (error (str "needed value for this strip but got" x)))) - ((comb? x) (error "got comb for strip, won't work")) - ((prim_comb? x) (idx x 2)) - ; env emitting doesn't pay attention to real value right now, not sure mif that makes sense - ; TODO: properly handle de Bruijn indexed envs - ((marked_env? x) (error "got env for strip, won't work")) - (true (error (str "some other strip? " x))) - ) - ))) (lambda (x) (dlet ( - ;(_ (print_strip "stripping: " x)) - (r (helper x true)) - ;(_ (println "result of strip " r)) - ) r)))) - - (try_unval (rec-lambda recurse (x fail_f) - (cond ((marked_array? x) (mif (not (.marked_array_is_val x)) (array false (fail_f x)) - (if (!= 0 (len (.marked_array_values x))) - (dlet ((values (.marked_array_values x)) - ((ok f) (recurse (idx values 0) fail_f)) - ) (array ok (marked_array false false nil (cons f (slice values 1 -1))))) - (array true (marked_array false false nil (array)))))) - ((marked_symbol? x) (mif (.marked_symbol_is_val x) (array true (marked_symbol true (.marked_symbol_value x))) - (array false (fail_f x)))) - (true (array true x)) - ) - )) - (try_unval_array (lambda (x) (foldl (dlambda ((ok a) x) (dlet (((nok p) (try_unval x (lambda (_) nil)))) - (array (and ok nok) (concat a (array p))))) - (array true (array)) - x))) - - (check_for_env_id_in_result (lambda (s_env_id x) (idx ((rec-lambda check_for_env_id_in_result (memo s_env_id x) - (dlet ( - ((need _hashes extra) (needed_for_progress x)) - (in_need (if (!= true need) (in_intset s_env_id need) false)) - (in_extra (in_intset s_env_id extra)) - ) (cond ((or in_need in_extra) (array memo true)) - ((!= true need) (array memo false)) - (true (dlet ( - - (old_way (dlet ( - (hash (.hash x)) - (result (if (marked_env? x) (get memo hash) false)) - ) (if (array? result) (array memo (idx result 1)) (cond - ((marked_symbol? x) (array memo false)) - ((marked_array? x) (dlet ( - (values (.marked_array_values x)) - ((memo result) ((rec-lambda recurse (memo i) (if (= (len values) i) (array memo false) - (dlet (((memo r) (check_for_env_id_in_result memo s_env_id (idx values i)))) - (if r (array memo true) - (recurse memo (+ i 1)))))) - memo 0)) - ) (array memo result))) - ((prim_comb? x) (array memo false)) - ((val? x) (array memo false)) - ((comb? x) (dlet ( - ((wrap_level i_env_id de? se variadic params body) (.comb x)) - ((memo in_se) (check_for_env_id_in_result memo s_env_id se)) - ((memo total) (if (and (not in_se) (!= s_env_id i_env_id)) (check_for_env_id_in_result memo s_env_id body) - (array memo in_se))) - ) (array memo total))) - - ((marked_env? x) (if (and (not (marked_env_real? x)) (= s_env_id (.marked_env_idx x))) (array memo true) - (dlet ( - (values (slice (.env_marked x) 0 -2)) - (upper (idx (.env_marked x) -1)) - ((memo result) ((rec-lambda recurse (memo i) (if (= (len values) i) (array memo false) - (dlet (((memo r) (check_for_env_id_in_result memo s_env_id (idx (idx values i) 1)))) - (if r (array memo true) - (recurse memo (+ i 1)))))) - memo 0)) - ((memo result) (if (or result (= nil upper)) (array memo result) - (check_for_env_id_in_result memo s_env_id upper))) - (memo (put memo hash result)) - ) (array memo result)))) - (true (error (str "Something odd passed to check_for_env_id_in_result " x))) - )))) - - ;(new_if_working (or in_need in_extra)) - ;(_ (if (and (!= true need) (!= new_if_working (idx old_way 1))) (error "GAH looking for " s_env_id " - " need " - " extra " - " new_if_working " " (idx old_way 1)))) - ) old_way))))) (array) s_env_id x) 1))) - - (comb_takes_de? (lambda (x l) (cond - ((comb? x) (!= nil (.comb_des x))) - ((prim_comb? x) (cond ( (= (.prim_comb_sym x) 'vau) true) - ((and (= (.prim_comb_sym x) 'eval) (= 1 l)) true) - ((and (= (.prim_comb_sym x) 'veval) (= 1 l)) true) - ( (= (.prim_comb_sym x) 'lapply) true) - ( (= (.prim_comb_sym x) 'vapply) true) - ( (= (.prim_comb_sym x) 'cond) true) ; but not vcond - (true false))) - ((and (marked_array? x) (not (.marked_array_is_val x))) true) - ((and (marked_symbol? x) (not (.marked_symbol_is_val x))) true) - (true (error (str "illegal comb_takes_de? param " x))) - ))) - - ; Handles let 4.3 through macro level leaving it as ( 13) - ; need handling of symbols (which is illegal for eval but ok for calls) to push it farther - (combiner_return_ok (rec-lambda combiner_return_ok (func_result env_id) - (cond ((not (later_head? func_result)) (not (check_for_env_id_in_result env_id func_result))) - ; special cases now - ; *(veval body {env}) => (combiner_return_ok {env}) - ; The reason we don't have to check body is that this form is only creatable in ways that body was origionally a value and only need {env} - ; Either it's created by eval, in which case it's fine, or it's created by something like (eval (array veval x de) de2) and the array has checked it, - ; or it's created via literal vau invocation, in which case the body is a value. - ((and (marked_array? func_result) - (prim_comb? (idx (.marked_array_values func_result) 0)) - (= 'veval (.prim_comb_sym (idx (.marked_array_values func_result) 0))) - (= 3 (len (.marked_array_values func_result))) - (combiner_return_ok (idx (.marked_array_values func_result) 2) env_id)) true) - ; (func ...params) => (and (doesn't take de func) (foldl combiner_return_ok (cons func params))) - ; - ((and (marked_array? func_result) - (not (comb_takes_de? (idx (.marked_array_values func_result) 0) (len (.marked_array_values func_result)))) - (foldl (lambda (a x) (and a (combiner_return_ok x env_id))) true (.marked_array_values func_result))) true) - - ; So that's enough for macro like, but we would like to take it farther - ; For like (let1 a 12 (wrap (vau (x) (let1 y (+ a 1) (+ y x a))))) - ; we get to (+ 13 x 12) not being a value, and it reconstructs - ; ( 13) - ; and that's what eval gets, and eval then gives up as well. - - ; That will get caught by the above cases to remain the expansion ( 13), - ; but ideally we really want another case to allow (+ 13 x 12) to bubble up - ; I think it would be covered by the (func ...params) case if a case is added to allow symbols to be bubbled up if their - ; needed for progress wasn't true or the current environment, BUT this doesn't work for eval, just for functions, - ; since eval changes the entire env chain (but that goes back to case 1, and might be eliminated at compile if it's an env reachable from the func). - ; - ; - ; Do note a key thing to be avoided is allowing any non-val inside a comb, since that can cause a fake env's ID to - ; reference the wrong env/comb in the chain. - ; We do allow calling eval with a fake env, but since it's only callable withbody value and is strict (by calling this) - ; about it's return conditions, and the env it's called with must be ok in the chain, and eval doesn't introduce a new scope, it works ok. - ; We do have to be careful about allowing returned later symbols from it though, since it could be an entirely different env chain. - - (true false) - ) - )) - - (drop_redundent_veval (rec-lambda drop_redundent_veval (partial_eval_helper x de env_stack pectx indent) (dlet ( - (env_id (.marked_env_idx de)) - (r (if - (and (marked_array? x) - (not (.marked_array_is_val x))) - (if (and (prim_comb? (idx (.marked_array_values x) 0)) - (= 'veval (.prim_comb_sym (idx (.marked_array_values x) 0))) - (= 3 (len (.marked_array_values x))) - (not (marked_env_real? (idx (.marked_array_values x) 2))) - (= env_id (.marked_env_idx (idx (.marked_array_values x) 2)))) (drop_redundent_veval partial_eval_helper (idx (.marked_array_values x) 1) de env_stack pectx (+ 1 indent)) - ; wait, can it do this? will this mess with eval? - - ; basically making sure that this comb's params are still good to eval - (if (and (or (prim_comb? (idx (.marked_array_values x) 0)) (comb? (idx (.marked_array_values x) 0))) - (!= -1 (.any_comb_wrap_level (idx (.marked_array_values x) 0)))) - (dlet (((pectx err ress changed) (foldl (dlambda ((c er ds changed) p) (dlet ( - (pre_hash (.hash p)) - ((c e d) (drop_redundent_veval partial_eval_helper p de env_stack c (+ 1 indent))) - (err (mif er er e)) - (changed (mif err false (or (!= pre_hash (.hash d)) changed))) - ) (array c err (concat ds (array d)) changed))) - (array pectx nil (array) false) - (.marked_array_values x))) - ((pectx err new_array) (if (or (!= nil err) (not changed)) - (array pectx err x) - (partial_eval_helper (marked_array false (.marked_array_is_attempted x) nil ress) - false de env_stack pectx (+ indent 1) true))) - - ) (array pectx err new_array)) - (array pectx nil x)) - ) (array pectx nil x)))) - - r))) - - - (make_tmp_inner_env (lambda (params de? ue env_id) - (dlet ((param_entries (map (lambda (p) (array p (marked_symbol env_id p))) params)) - (possible_de (mif (= nil de?) (array) (marked_symbol env_id de?))) - ) (marked_env false de? possible_de ue env_id param_entries)))) - - - (partial_eval_helper (rec-lambda partial_eval_helper (x only_head env env_stack pectx indent force) - (dlet (((for_progress for_progress_hashes extra_env_ids) (needed_for_progress x)) - (_ (print_strip (indent_str indent) "for_progress " for_progress ", for_progress_hashes " for_progress_hashes " for " x)) - ((env_counter memo) pectx) - (hashes_now (foldl (lambda (a hash) (or a (= false (get-value-or-false memo hash)))) false for_progress_hashes)) - ) - (if (or force hashes_now (= for_progress true) (intset_intersection_nonempty for_progress (idx env_stack 0))) - (cond ((val? x) (array pectx nil x)) - ((marked_env? x) (dlet ((dbi (.marked_env_idx x))) - ; compiler calls with empty env stack - (mif dbi (dlet ( (new_env ((rec-lambda rec (i len_env_stack) (cond ((= i len_env_stack) nil) - ((= dbi (.marked_env_idx (idx (idx env_stack 1) i))) (idx (idx env_stack 1) i)) - (true (rec (+ i 1) len_env_stack)))) - 0 (len (idx env_stack 1)))) - (_ (println (str_strip "replacing " x) (str_strip " with (if nonnil) " new_env))) - ) - (array pectx nil (if (!= nil new_env) new_env x))) - (array pectx nil x)))) - - ((comb? x) (dlet (((wrap_level env_id de? se variadic params body) (.comb x))) - (mif (or (and (not (marked_env_real? env)) (not (marked_env_real? se))) ; both aren't real, re-evaluation of creation site - (and (marked_env_real? env) (not (marked_env_real? se)))) ; new env real, but se isn't - creation! - (dlet ((inner_env (make_tmp_inner_env params de? env env_id)) - ((pectx err evaled_body) (partial_eval_helper body false inner_env (array (idx env_stack 0) (cons inner_env (idx env_stack 1))) pectx (+ indent 1) false))) - (array pectx err (mif err nil (marked_comb wrap_level env_id de? env variadic params evaled_body)))) - (array pectx nil x)))) - ((prim_comb? x) (array pectx nil x)) - ((marked_symbol? x) (mif (.marked_symbol_is_val x) x - (env-lookup-helper (.env_marked env) (.marked_symbol_value x) 0 - (lambda () (array pectx (str "could't find " (str_strip x) " in " (str_strip env)) nil)) - (lambda (x) (array pectx nil x))))) - ; Does this ever happen? non-fully-value arrays? - ((marked_array? x) (cond ((.marked_array_is_val x) (dlet ( ((pectx err inner_arr) (foldl (dlambda ((c er ds) p) (dlet (((c e d) (partial_eval_helper p false env env_stack c (+ 1 indent) false))) (array c (mif er er e) (concat ds (array d))))) - (array pectx nil (array)) - (.marked_array_values x))) - ) (array pectx err (mif err nil (marked_array true false nil inner_arr))))) - ((= 0 (len (.marked_array_values x))) (array pectx "Partial eval on empty array" nil)) - (true (dlet ((values (.marked_array_values x)) - (_ (print_strip (indent_str indent) "partial_evaling comb " (idx values 0))) - - (literal_params (slice values 1 -1)) - ((pectx err comb) (partial_eval_helper (idx values 0) true env env_stack pectx (+ 1 indent) false)) - ) (cond ((!= nil err) (array pectx err nil)) - ((later_head? comb) (array pectx nil (marked_array false true nil (cons comb literal_params)))) - ((not (or (comb? comb) (prim_comb? comb))) (array pectx (str "impossible comb value " x) nil)) - (true (dlet ( - ; If we haven't evaluated the function before at all, we would like to partially evaluate it so we know - ; what it needs. We'll see if this re-introduces exponentail (I think this should limit it to twice?) - ((pectx comb_err comb) (if (and (= nil err) (= true (needed_for_progress_slim comb))) - (partial_eval_helper comb false env env_stack pectx (+ 1 indent) false) - (array pectx err comb))) - (_ (println (indent_str indent) "Going to do an array call!")) - (indent (+ 1 indent)) - (_ (print_strip (indent_str indent) "total (in env " (.marked_env_idx env) ") is (proceeding err " err ") " x)) - (map_rp_eval (lambda (pectx ps) (foldl (dlambda ((c er ds) p) (dlet ((_ (print_strip (indent_str indent) "rp_evaling " p)) ((c e d) (partial_eval_helper p false env env_stack c (+ 1 indent) false)) (_ (print_strip (indent_str indent) "result of rp_eval was err " e " and value " d))) (array c (mif er er e) (concat ds (array d))))) - (array pectx nil (array)) - ps))) - (wrap_level (.any_comb_wrap_level comb)) - ; -1 is a minor hack for veval to prevent re-eval - ; in the wrong env and vcond to prevent guarded - ; infinate recursion - ((remaining_wrap param_err evaled_params pectx) (if (= -1 wrap_level) - (array -1 nil literal_params pectx) - ((rec-lambda param-recurse (wrap cparams pectx) - (dlet ( - (_ (print (indent_str indent) "For initial rp_eval:")) - (_ (map (lambda (x) (print_strip (indent_str indent) "item " x)) cparams)) - ((pectx er pre_evaled) (map_rp_eval pectx cparams)) - (_ (print (indent_str indent) "er for intial rp_eval: " er)) - ) - (mif er (array wrap er nil pectx) - (mif (!= 0 wrap) - (dlet (((ok unval_params) (try_unval_array pre_evaled))) - (mif (not ok) (array wrap nil pre_evaled pectx) - (param-recurse (- wrap 1) unval_params pectx))) - (array wrap nil pre_evaled pectx))))) - wrap_level literal_params pectx))) - (_ (println (indent_str indent) "Done evaluating parameters")) - - (l_later_call_array (lambda () (marked_array false true nil (cons (with_wrap_level comb remaining_wrap) evaled_params)))) - (ok_and_non_later (or (= -1 remaining_wrap) - (and (= 0 remaining_wrap) (if (and (prim_comb? comb) (.prim_comb_val_head_ok comb)) - (is_all_head_values evaled_params) - (is_all_values evaled_params))))) - (_ (println (indent_str indent) "ok_and_non_later " ok_and_non_later)) - ) (cond ((!= nil comb_err) (array pectx comb_err nil)) - ((!= nil param_err) (array pectx param_err nil)) - ((not ok_and_non_later) (array pectx nil (l_later_call_array))) - ((prim_comb? comb) (dlet ( - (_ (println (indent_str indent) "Calling prim comb " (.prim_comb_sym comb))) - ((pectx err result) ((.prim_comb_handler comb) only_head env env_stack pectx evaled_params (+ 1 indent))) - ) (if (= 'LATER err) (array pectx nil (l_later_call_array)) - (array pectx err result)))) - ((comb? comb) (dlet ( - ((wrap_level env_id de? se variadic params body) (.comb comb)) - - - (final_params (mif variadic (concat (slice evaled_params 0 (- (len params) 1)) - (array (marked_array true false nil (slice evaled_params (- (len params) 1) -1)))) - evaled_params)) - (de_env (mif (!= nil de?) env nil)) - (inner_env (marked_env true de? de_env se env_id (zip params final_params))) - (_ (print_strip (indent_str indent) " with inner_env is " inner_env)) - (_ (print_strip (indent_str indent) "going to eval " body)) - - ; prevent infinite recursion - (hash (combine_hash (.hash body) (.hash inner_env))) - ((env_counter memo) pectx) - ((pectx func_err func_result rec_stop) (if (!= false (get-value-or-false memo hash)) - (array pectx nil "stopping for infinite recursion" true) - (dlet ( - (new_memo (put memo hash nil)) - (pectx (array env_counter new_memo)) - ((pectx func_err func_result) (partial_eval_helper body only_head inner_env - (array (intset_item_union (idx env_stack 0) env_id) - (cons inner_env (idx env_stack 1))) - pectx (+ 1 indent) false)) - ((env_counter new_memo) pectx) - (pectx (array env_counter memo)) - ) (array pectx func_err func_result false)))) - - (_ (print_strip (indent_str indent) "evaled result of function call (in env " (.marked_env_idx env) ", with inner " env_id ") and err " func_err " is " func_result)) - (must_stop_maybe_id (and (= nil func_err) - (or rec_stop (if (not (combiner_return_ok func_result env_id)) - (if (!= nil de?) (.marked_env_idx env) true) - false)))) - ) (if (!= nil func_err) (array pectx func_err nil) - (if must_stop_maybe_id - (array pectx nil (marked_array false must_stop_maybe_id (if rec_stop (array hash) nil) (cons (with_wrap_level comb remaining_wrap) evaled_params))) - (drop_redundent_veval partial_eval_helper func_result env env_stack pectx indent))))) - ))) - ))))) - - (true (array pectx (str "impossible partial_eval value " x) nil)) - ) - ; otherwise, we can't make progress yet - (drop_redundent_veval partial_eval_helper x env env_stack pectx indent))) - )) - - (needs_params_val_lambda (lambda (f_sym actual_function) (dlet ( - (handler (rec-lambda recurse (only_head de env_stack pectx params indent) - (array pectx nil (mark false (lapply actual_function (map strip params)))))) - ) (array f_sym (marked_prim_comb handler f_sym 1 false))))) - - (give_up_eval_params (lambda (f_sym actual_function) (dlet ( - (handler (lambda (only_head de env_stack pectx params indent) (array pectx 'LATER nil))) - ) (array f_sym (marked_prim_comb handler f_sym 1 false))))) - - (veval_inner (rec-lambda recurse (only_head de env_stack pectx params indent) (dlet ( - (body (idx params 0)) - (implicit_env (!= 2 (len params))) - (eval_env (if implicit_env de (idx params 1))) - ((pectx err eval_env) (if implicit_env (array pectx nil de) - (partial_eval_helper (idx params 1) only_head de env_stack pectx (+ 1 indent) false))) - ((pectx err ebody) (if (or (!= nil err) (not (marked_env? eval_env))) - (array pectx err body) - (partial_eval_helper body only_head eval_env env_stack pectx (+ 1 indent) false))) - ) (cond - ((!= nil err) (array pectx err nil)) - ; If our env was implicit, then our unval'd code can be inlined directly in our caller - (implicit_env (drop_redundent_veval partial_eval_helper ebody de env_stack pectx indent)) - ((combiner_return_ok ebody (.marked_env_idx eval_env)) (drop_redundent_veval partial_eval_helper ebody de env_stack pectx indent)) - (true (drop_redundent_veval partial_eval_helper (marked_array false true nil (array - (marked_prim_comb recurse 'veval -1 true) - ebody - eval_env - )) - de env_stack pectx indent)) - )))) - - - (root_marked_env (marked_env true nil nil nil nil (array - - (array 'eval (marked_prim_comb (rec-lambda recurse (only_head de env_stack pectx evaled_params indent) - (if (not (total_value? (idx evaled_params 0))) (array pectx nil (marked_array false true nil (cons (marked_prim_comb recurse 'eval 0 true) evaled_params))) - (if (and (= 2 (len evaled_params)) (not (marked_env? (idx evaled_params 1)))) (array pectx nil (marked_array false true nil (cons (marked_prim_comb recurse 'eval 0 true) evaled_params))) - (dlet ( - (body (idx evaled_params 0)) - (implicit_env (!= 2 (len evaled_params))) - (eval_env (if implicit_env de (idx evaled_params 1))) - ((ok unval_body) (try_unval body (lambda (_) nil))) - (_ (if (not ok) (error "actually impossible eval unval"))) - ) (veval_inner only_head de env_stack pectx (if implicit_env (array unval_body) (array unval_body eval_env)) indent)))) - ) 'eval 1 true)) - - (array 'vapply (marked_prim_comb (dlambda (only_head de env_stack pectx (f ps ide) indent) - (veval_inner only_head de env_stack pectx (array (marked_array false false nil (cons f (.marked_array_values ps))) ide) (+ 1 indent)) - ) 'vapply 1 true)) - (array 'lapply (marked_prim_comb (dlambda (only_head de env_stack pectx (f ps) indent) - (veval_inner only_head de env_stack pectx (array (marked_array false false nil (cons (with_wrap_level f (- (.any_comb_wrap_level f) 1)) (.marked_array_values ps)))) (+ 1 indent)) - ) 'lapply 1 true)) - - (array 'vau (marked_prim_comb (lambda (only_head de env_stack pectx params indent) (dlet ( - (mde? (mif (= 3 (len params)) (idx params 0) nil)) - (vau_mde? (mif (= nil mde?) (array) (array mde?))) - (_ (print (indent_str indent) "mde? is " mde?)) - (_ (print (indent_str indent) "\tmde? if " (mif mde? #t #f))) - (de? (mif mde? (.marked_symbol_value mde?) nil)) - (_ (print (indent_str indent) "de? is " de?)) - (vau_de? (mif (= nil de?) (array) (array de?))) - (raw_marked_params (mif (= nil de?) (idx params 0) (idx params 1))) - (raw_params (map (lambda (x) (mif (not (marked_symbol? x)) (error (str "not a marked symbol " x)) - (.marked_symbol_value x))) (.marked_array_values raw_marked_params))) - - ((variadic vau_params) (foldl (dlambda ((v a) x) (mif (= x '&) (array true a) (array v (concat a (array x))))) (array false (array)) raw_params)) - ((ok body) (try_unval (mif (= nil de?) (idx params 1) (idx params 2)) (lambda (_) nil))) - (_ (if (not ok) (error "actually impossible vau unval"))) - ((env_counter memo) pectx) - (new_id env_counter) - (env_counter (+ 1 env_counter)) - (pectx (array env_counter memo)) - ((pectx err pe_body) (if only_head (array pectx nil body) - (dlet ( - (inner_env (make_tmp_inner_env vau_params de? de new_id)) - (_ (print_strip (indent_str indent) "in vau, evaluating body with 'later params - " body)) - ((pectx err pe_body) (partial_eval_helper body false inner_env (array (idx env_stack 0) - (cons inner_env (idx env_stack 1))) pectx (+ 1 indent) false)) - (_ (print_strip (indent_str indent) "in vau, result of evaluating body was " pe_body)) - ) (array pectx err pe_body)))) - ) (mif err (array pectx err nil) (array pectx nil (marked_comb 0 new_id de? de variadic vau_params pe_body))) - )) 'vau 0 true)) - - - - - (array 'empty_env (marked_env true nil nil nil nil nil)) - ))) - - - - - ; This causes ?infinate? recursion, doesn't happen if "if" is replaced with cond - ;(test_func (vau (x) (if x (COMICAL 0) 0))) - - - ;(and_fold (foldl and true '(true true false true))) - ;(monad (array 'write 1 (str "Hello from compiled code! " and_fold " here's a hashed string " (hash_string "hia") "\n") (vau (written code) (array 'exit 0)))) - ;(monad (array 'write 1 (str "Hello from compiled code! " (mif nil 1 2) " " (mif 1 3 4) "\n") (vau (written code) (array 'exit 0)))) - (monad (array 'write 1 (str "Hello from compiled code! " "\n") (vau (written code) (array 'exit (if (not written) 1))))) - - ) monad) - ) -; end of all lets -)))))) -; impl of let1 -; this would be the macro style version ((( -)) (vau de (s v b) (eval (array (array wrap (array vau (array s) b)) v) de))) -;)) (vau de (s v b) (eval (array (array vau (array s) b) (eval v de)) de))) -; impl of quote -)) (vau (x5) x5)) diff --git a/partial_eval.scm b/partial_eval.scm deleted file mode 100644 index 8126be6..0000000 --- a/partial_eval.scm +++ /dev/null @@ -1,6946 +0,0 @@ - -; both Gambit and Chez define pretty-print. Chicken doesn't obv -; In Chez, arithmetic-shift is bitwise-arithmetic-shift - -; Chicken -;(import (chicken process-context)) (import (chicken port)) (import (chicken io)) (import (chicken bitwise)) (import (chicken string)) (import (r5rs)) (define write_file (lambda (file bytes) (call-with-output-file file (lambda (out) (foldl (lambda (_ o) (write-byte o out)) (void) bytes))))) (define args (command-line-arguments)) - -; Chez -(define print pretty-print) (define arithmetic-shift bitwise-arithmetic-shift) (define foldl fold-left) (define foldr fold-right) (define write_file (lambda (file bytes) (let* ( (port (open-file-output-port file)) (_ (foldl (lambda (_ o) (put-u8 port o)) (void) bytes)) (_ (close-port port))) '()))) (define args (cdr (command-line))) -;(compile-profile 'source) - -; Gambit - Gambit also has a problem with the dlet definition (somehow recursing and making (cdr nil) for (cdr ls)?), even if using the unstable one that didn't break syntax-rules -;(define print pretty-print) - -(define-syntax rec-lambda - (syntax-rules () - ((_ name params body) (letrec ((name (lambda params body))) name)))) - - -; Based off of http://www.phyast.pitt.edu/~micheles/scheme/scheme15.html -; many thanks! -(define-syntax dlet - (syntax-rules () - ((_ () expr) expr) - ((_ ((() bad)) expr) expr) - ((_ (((arg1 arg2 ...) lst)) expr) - (let ((ls lst)) - (dlet ((arg1 (car ls))) - (dlet (((arg2 ...) (cdr ls))) expr)))) - ((_ ((name value)) expr) (let ((name value)) expr)) - ((_ ((name value) (n v) ...) expr) (dlet ((name value)) (dlet ((n v) ...) expr))) -)) - -(define-syntax dlambda - (syntax-rules () - ((_ params body) (lambda fullparams (dlet ((params fullparams)) body))))) - -(define-syntax mif - (syntax-rules () - ((_ con then ) (if (let ((x con)) (and (not (equal? (list) x)) x)) then '())) - ((_ con then else) (if (let ((x con)) (and (not (equal? (list) x)) x)) then else)))) - - - -(define str (lambda args (begin - (define mp (open-output-string)) - ((rec-lambda recurse (x) (if (and x (not (equal? '() x))) (begin (display (car x) mp) (recurse (cdr x))) '())) args) - (get-output-string mp)))) - -(define true_error error) -(define error (lambda args (begin (print "ERROR! About to Error! args are\n") (print (str args)) (apply true_error args)))) - -; Adapted from https://stackoverflow.com/questions/16335454/reading-from-file-using-scheme WTH -(define (slurp path) - (list->string (call-with-input-file path - (lambda (input-port) - (let loop ((x (read-char input-port))) - (cond - ((eof-object? x) '()) - (#t (begin (cons x (loop (read-char input-port))))))))))) - -(define speed_hack #t) -;(define GLOBAL_MAX 0) - -(let* ( - (lapply apply) - (= equal?) - (!= (lambda (a b) (not (= a b)))) - (array list) - (array? list?) - (concat (lambda args (cond ((equal? (length args) 0) (list)) - ((list? (list-ref args 0)) (apply append args)) - ((string? (list-ref args 0)) (apply string-append args)) - (#t (error "bad value to concat " (list-ref args 0)))))) - (len (lambda (x) (cond ((list? x) (length x)) - ((string? x) (string-length x)) - (#t (error "bad value to len" x))))) - (idx (lambda (x i) (cond ((list? x) (list-ref x (if (< i 0) (+ i (len x)) i))) - ((string? x) (char->integer (list-ref (string->list x) (if (< i 0) (+ i (len x)) i))))))) - (false #f) - (true #t) - (nil '()) - (str-to-symbol string->symbol) - (get-text symbol->string) - - (bor bitwise-ior) - (band bitwise-and) - (bxor bitwise-xor) - (bnot bitwise-not) - (<< arithmetic-shift) - (>> (lambda (a b) (arithmetic-shift a (- b)))) - - (print (lambda args (print (apply str args)))) - (true_str str) - ;(str (if speed_hack (lambda args "") str)) - (true_print print) - (print (if speed_hack (lambda x 0) print)) - ;(true_print print) - (println print) - - - (nil? (lambda (x) (= nil x))) - (bool? (lambda (x) (or (= #t x) (= #f x)))) - - (read-string (lambda (s) (read (open-input-string s)))) - - (zip (lambda args (apply map list args))) - - (% modulo) - (int? integer?) - (str? string?) - (env? (lambda (x) false)) - (combiner? (lambda (x) false)) - - ;; For chicken and Chez - (drop (rec-lambda recurse (x i) (if (= 0 i) x (recurse (cdr x) (- i 1))))) - (take (rec-lambda recurse (x i) (if (= 0 i) (array) (cons (car x) (recurse (cdr x) (- i 1)))))) - (slice (lambda (x s e) (let* ( (l (len x)) - (s (if (< s 0) (+ s l 1) s)) - (e (if (< e 0) (+ e l 1) e)) - (t (- e s)) ) - (if (list? x) (take (drop x s) t) - (list->string (take (drop (string->list x) s) t)))))) - (range (rec-lambda recurse (a b) - (cond ((= a b) nil) - ((< a b) (cons a (recurse (+ a 1) b))) - (true (cons a (recurse (- a 1) b))) - ))) - (filter (rec-lambda recurse (f l) (cond ((nil? l) nil) - ((f (car l)) (cons (car l) (recurse f (cdr l)))) - (true (recurse f (cdr l)))))) - - (flat_map (lambda (f l) ((rec recurse (lambda (f l) (cond - ((equal? '() l) '()) - (#t (append (f (car l)) (recurse f (cdr l))))) - )) f l))) - - (reverse_e (lambda (x) (foldl (lambda (acc i) (cons i acc)) (array) x))) - ;;;;;;;;;;;;;;;;;; - ; End kludges - ;;;;;;;;;;;;;;;;;; - - (empty_dict-list (array)) - ;(put-list (lambda (m k v) (cons (array k v) m))) - (put-list (lambda (m k v) ((rec-lambda recurse (m k v len_m i) (cond ((= len_m i) (cons (array k v) m)) - ((= k (idx (idx m i) 0)) (concat (slice m 0 i) (array (array k v)) (slice m (+ i 1) len_m))) - (true (recurse m k v len_m (+ 1 i))))) - m k v (len m) 0))) - (get-list (lambda (d k) ((rec-lambda recurse (k d len_d i) (cond ((= len_d i) false) - ((= k (idx (idx d i) 0)) (idx d i)) - (true (recurse k d len_d (+ 1 i))))) - k d (len d) 0))) - (put-all-list (lambda (m nv) (map (dlambda ((k v)) (array k nv)) m))) - - ;(combine_hash (lambda (a b) (+ (* 37 a) b))) - (combine_hash (lambda (a b) (band #xFFFFFFFFFFFFFF (+ (* 37 a) b)))) - (hash_bool (lambda (b) (if b 2 3))) - (hash_num (lambda (n) (combine_hash 5 n))) - (hash_string (lambda (s) (foldl combine_hash 7 (map char->integer (string->list s))))) - ;(hash_string (lambda (s) (foldl combine_hash 7 s))) - ;(hash_string (lambda (s) (foldl combine_hash 102233 (map char->integer (string->list s))))) - - - (in_array (dlet ((helper (rec-lambda recurse (x a len_a i) (cond ((= i len_a) false) - ((= x (idx a i)) true) - (true (recurse x a len_a (+ i 1))))))) - (lambda (x a) (helper x a (len a) 0)))) - (any_in_array (dlet ((helper (rec-lambda recurse (f a len_a i) (cond ((= i len_a) false) - ((f (idx a i)) i) - (true (recurse f a len_a (+ i 1))))))) - (lambda (f a) (helper f a (len a) 0)))) - (array_item_union (lambda (a bi) (if (in_array bi a) a (cons bi a)))) - (array_union (lambda (a b) (foldl array_item_union a b))) - - - (intset_word_size 64) - (in_intset (rec-lambda in_intset (x a) (cond ((nil? a) false) - ((>= x intset_word_size) (in_intset (- x intset_word_size) (cdr a))) - (true (!= (band (>> (car a) x) 1) 0))))) - - (intset_item_union (rec-lambda intset_item_union (a bi) (cond ((nil? a) (intset_item_union (array 0) bi)) - ((>= bi intset_word_size) (cons (car a) (intset_item_union (cdr a) (- bi intset_word_size)))) - (true (cons (bor (car a) (<< 1 bi)) (cdr a)))))) - - (intset_item_remove (rec-lambda intset_item_remove (a bi) (cond ((nil? a) nil) - ((>= bi intset_word_size) (dlet ((new_tail (intset_item_remove (cdr a) (- bi intset_word_size)))) - (if (and (nil? new_tail) (= 0 (car a))) nil - (cons (car a) new_tail)))) - (true (dlet ((new_int (band (car a) (bnot (<< 1 bi))))) - (if (and (nil? (cdr a)) (= 0 new_int)) nil - (cons new_int (cdr a)))))))) - (intset_union (rec-lambda intset_union (a b) (cond ((and (nil? a) (nil? b)) nil) - ((nil? a) b) - ((nil? b) a) - (true (cons (bor (car a) (car b)) (intset_union (cdr a) (cdr b))))))) - - (intset_intersection_nonempty (rec-lambda intset_intersection_nonempty (a b) (cond ((nil? a) false) - ((nil? b) false) - (true (or (!= 0 (band (car a) (car b))) (intset_intersection_nonempty (cdr a) (cdr b))))))) - - ;(_ (true_print "of 1 " (intset_item_union nil 1))) - ;(_ (true_print "of 1 and 2 " (intset_item_union (intset_item_union nil 1) 2))) - ;(_ (true_print "of 1 and 2 union 3 4" (intset_union (intset_item_union (intset_item_union nil 1) 2) (intset_item_union (intset_item_union nil 3) 4)))) - - ;(_ (true_print "of 100 " (intset_item_union nil 100))) - ;(_ (true_print "of 100 and 200 " (intset_item_union (intset_item_union nil 100) 200))) - ;(_ (true_print "of 100 and 200 union 300 400" (intset_union (intset_item_union (intset_item_union nil 100) 200) (intset_item_union (intset_item_union nil 300) 400)))) - - ;(_ (true_print "1 in 1 " (in_intset 1 (intset_item_union nil 1)))) - ;(_ (true_print "1 in 1 and 2 " (in_intset 1 (intset_item_union (intset_item_union nil 1) 2)))) - ;(_ (true_print "1 in 1 and 2 union 3 4" (in_intset 1 (intset_union (intset_item_union (intset_item_union nil 1) 2) (intset_item_union (intset_item_union nil 3) 4))))) - - ;(_ (true_print "1 in 1 " (in_intset 1 (intset_item_union nil 1)))) - ;(_ (true_print "1 in 1 and 2 " (in_intset 1 (intset_item_union (intset_item_union nil 1) 2)))) - ;(_ (true_print "1 in 1 and 2 union 3 4" (in_intset 1 (intset_union (intset_item_union (intset_item_union nil 1) 2) (intset_item_union (intset_item_union nil 3) 4))))) - - ;(_ (true_print "5 in 1 " (in_intset 5 (intset_item_union nil 1)))) - ;(_ (true_print "5 in 1 and 2 " (in_intset 5 (intset_item_union (intset_item_union nil 1) 2)))) - ;(_ (true_print "5 in 1 and 2 union 3 4" (in_intset 5 (intset_union (intset_item_union (intset_item_union nil 1) 2) (intset_item_union (intset_item_union nil 3) 4))))) - - ;(_ (true_print "1 in 100 " (in_intset 1 (intset_item_union nil 100)))) - ;(_ (true_print "1 in 100 and 200 " (in_intset 1 (intset_item_union (intset_item_union nil 100) 200)))) - ;(_ (true_print "1 in 100 and 200 union 300 400" (in_intset 1 (intset_union (intset_item_union (intset_item_union nil 100) 200) (intset_item_union (intset_item_union nil 300) 400))))) - ;(_ (true_print "5 in 100 " (in_intset 5 (intset_item_union nil 100)))) - ;(_ (true_print "5 in 100 and 200 " (in_intset 5 (intset_item_union (intset_item_union nil 100) 200)))) - ;(_ (true_print "5 in 100 and 200 union 300 400" (in_intset 5 (intset_union (intset_item_union (intset_item_union nil 100) 200) (intset_item_union (intset_item_union nil 300) 400))))) - ;(_ (true_print "100 in 100 " (in_intset 100 (intset_item_union nil 100)))) - ;(_ (true_print "100 in 100 and 200 " (in_intset 100 (intset_item_union (intset_item_union nil 100) 200)))) - ;(_ (true_print "100 in 100 and 200 union 300 400" (in_intset 100 (intset_union (intset_item_union (intset_item_union nil 100) 200) (intset_item_union (intset_item_union nil 300) 400))))) - ;(_ (true_print "500 in 100 " (in_intset 500 (intset_item_union nil 100)))) - ;(_ (true_print "500 in 100 and 200 " (in_intset 500 (intset_item_union (intset_item_union nil 100) 200)))) - ;(_ (true_print "500 in 100 and 200 union 300 400" (in_intset 500 (intset_union (intset_item_union (intset_item_union nil 100) 200) (intset_item_union (intset_item_union nil 300) 400))))) - - ;(_ (true_print "all removed in 100 and 200 union 300 400" (intset_item_remove (intset_item_remove (intset_item_remove (intset_item_remove (intset_union (intset_item_union (intset_item_union nil 100) 200) (intset_item_union (intset_item_union nil 300) 400)) 100) 200) 300) 400))) - - (intset_union_without (lambda (wo a b) (intset_item_remove (intset_union a b) wo))) - - (val? (lambda (x) (= 'val (idx x 0)))) - (marked_array? (lambda (x) (= 'marked_array (idx x 0)))) - (marked_symbol? (lambda (x) (= 'marked_symbol (idx x 0)))) - (comb? (lambda (x) (= 'comb (idx x 0)))) - (prim_comb? (lambda (x) (= 'prim_comb (idx x 0)))) - (marked_env? (lambda (x) (= 'env (idx x 0)))) - - (.hash (lambda (x) (idx x 1))) - - (.val (lambda (x) (idx x 2))) - - (.marked_array_is_val (lambda (x) (idx x 2))) - (.marked_array_is_attempted (lambda (x) (idx x 3))) - (.marked_array_needed_for_progress (lambda (x) (idx x 4))) - (.marked_array_values (lambda (x) (idx x 5))) - (.marked_array_source (lambda (x) (if (= true (idx x 6)) x (idx x 6)))) - (.marked_array_this_rec_stop (lambda (x) (idx x 7))) - - (.marked_symbol_needed_for_progress (lambda (x) (idx x 2))) - (.marked_symbol_is_val (lambda (x) (= nil (.marked_symbol_needed_for_progress x)))) - (.marked_symbol_value (lambda (x) (idx x 3))) - - (.comb (lambda (x) (slice x 2 -1))) - (.comb_id (lambda (x) (idx x 3))) - (.comb_des (lambda (x) (idx x 4))) - (.comb_env (lambda (x) (idx x 5))) - (.comb_varadic (lambda (x) (idx x 6))) - (.comb_params (lambda (x) (idx x 7))) - (.comb_body (lambda (x) (idx x 8))) - (.comb_wrap_level (lambda (x) (idx x 2))) - - (.prim_comb_sym (lambda (x) (idx x 3))) - (.prim_comb_handler (lambda (x) (idx x 2))) - (.prim_comb_wrap_level (lambda (x) (idx x 4))) - (.prim_comb_val_head_ok (lambda (x) (idx x 5))) - (.prim_comb (lambda (x) (slice x 2 -1))) - - (.marked_env (lambda (x) (slice x 2 -1))) - (.marked_env_has_vals (lambda (x) (idx x 2))) - (.marked_env_needed_for_progress (lambda (x) (idx x 3))) - (.marked_env_id (lambda (x) (idx x 4))) - (.marked_env_upper (lambda (x) (idx (idx x 5) -1))) - (.env_marked (lambda (x) (idx x 5))) - (marked_env_real? (lambda (x) (= nil (idx (.marked_env_needed_for_progress x) 0)))) - (.any_comb_wrap_level (lambda (x) (cond ((prim_comb? x) (.prim_comb_wrap_level x)) - ((comb? x) (.comb_wrap_level x)) - (true (error "bad .any_comb_level"))))) - (empty_dict-tree nil) - ;(trans-key (lambda (k) (cond ((string? k) (cons (hash_string k) k)) - ; ((symbol? k) (cons (hash_string (symbol->string k)) k)) - ; (true (cons k k))))) - ;(put-helper (rec-lambda put-helper (m k v) (cond ((nil? m) (cons (list k v) (cons nil nil))) - ; ((and (= (car k) (caaar m)) - ; (= (cdr k) (cdaar m))) (cons (list k v) (cons (cadr m) (cddr m)))) - ; ((< (car k) (caaar m)) (cons (car m) (cons (put-helper (cadr m) k v) (cddr m)))) - ; (true (cons (car m) (cons (cadr m) (put-helper (cddr m) k v))))))) - ;(put-tree (lambda (m k v) (put-helper m (trans-key k) v))) - ;(get-helper (rec-lambda get-helper (m k) (cond ((nil? m) false) - ; ((and (= (car k) (caaar m)) - ; (= (cdr k) (cdaar m))) (car m)) - ; ((< (car k) (caaar m)) (get-helper (cadr m) k)) - ; (true (get-helper (cddr m) k))))) - (trans-key (lambda (k) (cond ((string? k) (hash_string k)) - ((symbol? k) (hash_string (get-text k))) - ((array? k) (.hash k)) - (true k)))) - (put-helper (rec-lambda put-helper (m hk k v) (cond ((nil? m) (array hk k v nil nil)) - ((and (= hk (idx m 0)) - (= k (idx m 1))) (array hk k v (idx m 3) (idx m 4))) - ((< hk (idx m 0)) (array (idx m 0) (idx m 1) (idx m 2) (put-helper (idx m 3) hk k v) (idx m 4))) - (true (array (idx m 0) (idx m 1) (idx m 2) (idx m 3) (put-helper (idx m 4) hk k v)))))) - (put-tree (lambda (m k v) (put-helper m (trans-key k) k v))) - (get-helper (rec-lambda get-helper (m hk k) (cond ((nil? m) false) - ((and (= hk (idx m 0)) - (= k (idx m 1))) (array k (idx m 2))) - ((< hk (idx m 0)) (get-helper (idx m 3) hk k)) - (true (get-helper (idx m 4) hk k))))) - (get-tree (lambda (m k) (get-helper m (trans-key k) k))) - (foldl-tree (rec-lambda foldl-tree (f a m) (cond ((nil? m) a) - (true (dlet ( - (a (foldl-tree f a (idx m 3))) - (a (f a (idx m 1) (idx m 2))) - (a (foldl-tree f a (idx m 4))) - ) a))))) - - ;(empty_dict empty_dict-list) - ;(put put-list) - ;(get get-list) - (empty_dict empty_dict-tree) - (put put-tree) - (get get-tree) - - ;(empty_dict (list empty_dict-list empty_dict-tree)) - ;(put (lambda (m k v) (list (put-list (idx m 0) k v) (put-tree (idx m 1) k v)))) - ;(get (lambda (m k) (dlet ( ;(_ (true_print "doing a get " m " " k)) - ; (list-result (get-list (idx m 0) k)) - ; (tree-result (get-tree (idx m 1) k)) - ; (_ (if (and (!= list-result tree-result) (!= (idx list-result 1) (idx tree-result 1))) (error "BAD GET " list-result " vs " tree-result))) - ; ) tree-result))) - - (get-value (lambda (d k) (dlet ((result (get d k))) - (if (array? result) (idx result 1) - (error (str "could not find " k " in " d)))))) - (get-value-or-false (lambda (d k) (dlet ((result (get d k))) - (if (array? result) (idx result 1) - false)))) - - - ; The actual needed_for_progress values are either - ; #t - any eval will do something - ; nil - is a value, no eval will do anything - ; (3 4 1...) - list of env ids that would allow forward progress - ; But these are paired with another list of hashes that if you're not inside - ; of an evaluation of, then it could progress futher. These are all caused by - ; the infinite recursion stopper. - (needed_for_progress (rec-lambda needed_for_progress (x) (cond ((marked_array? x) (.marked_array_needed_for_progress x)) - ((marked_symbol? x) (dlet ((n (.marked_symbol_needed_for_progress x))) (array (if (int? n) (intset_item_union nil n) n) nil nil))) - ((marked_env? x) (.marked_env_needed_for_progress x)) - ((comb? x) (dlet ((id (.comb_id x)) - ((body_needed _hashes extra1) (needed_for_progress (.comb_body x))) - ((se_needed _hashes extra2) (needed_for_progress (.comb_env x)))) - (if (or (= true body_needed) (= true se_needed)) (array true nil nil) - (array (intset_union_without id body_needed se_needed) - nil (intset_union_without id extra1 extra2)) - ))) - ((prim_comb? x) (array nil nil nil)) - ((val? x) (array nil nil nil)) - (true (error (str "what is this? in need for progress" x)))))) - (needed_for_progress_slim (lambda (x) (idx (needed_for_progress x) 0))) - (hash_symbol (lambda (progress_idx s) (combine_hash (cond ((= true progress_idx) 11) - ((int? progress_idx) (combine_hash 13 progress_idx)) - (true 113)) (hash_string (get-text s))))) - - (hash_array (lambda (is_val attempted a) (foldl combine_hash (if is_val 17 (cond ((int? attempted) (combine_hash attempted 19)) - (attempted 61) - (true 107))) (map .hash a)))) - (hash_env (lambda (has_vals progress_idxs dbi arrs) (combine_hash (if has_vals 107 109) - (combine_hash (mif dbi (hash_num dbi) 59) (dlet ( - ;(_ (begin (true_print "pre slice " (slice arrs 0 -2)) 0)) - ;(_ (begin (true_print "about to do a fold " progress_idxs " and " (slice arrs 0 -2)) 0)) - (inner_hash (foldl (dlambda (c (s v)) (combine_hash c (combine_hash (hash_symbol true s) (.hash v)))) - (cond ((= nil progress_idxs) 23) - ((= true progress_idxs) 29) - (true (foldl combine_hash 31 progress_idxs))) - (slice arrs 0 -2))) - (end (idx arrs -1)) - (end_hash (mif end (.hash end) 41)) - ) (combine_hash inner_hash end_hash)))))) - (hash_comb (lambda (wrap_level env_id de? se variadic params body) - (combine_hash 43 - (combine_hash wrap_level - (combine_hash env_id - (combine_hash (mif de? (hash_symbol true de?) 47) - (combine_hash (.hash se) - (combine_hash (hash_bool variadic) - (combine_hash (foldl (lambda (c x) (combine_hash c (hash_symbol true x))) 53 params) - (.hash body)))))))))) - (hash_prim_comb (lambda (handler_fun real_or_name wrap_level val_head_ok) (combine_hash (combine_hash 59 (hash_symbol true real_or_name)) - (combine_hash (if val_head_ok 89 97) wrap_level)))) - (hash_val (lambda (x) (cond ((bool? x) (hash_bool x)) - ((string? x) (hash_string x)) - ((int? x) (hash_num x)) - (true (error (str "bad thing to hash_val " x)))))) - ; 127 131 137 139 149 151 157 163 167 173 - - (marked_symbol (lambda (progress_idx x) (array 'marked_symbol (hash_symbol progress_idx x) progress_idx x))) - (marked_array (lambda (is_val attempted resume_hashes x source) (dlet ( - ((sub_progress_idxs hashes extra) (foldl (dlambda ((a ahs aeei) (x xhs x_extra_env_ids)) - (array (cond ((or (= true a) (= true x)) true) - (true (intset_union a x))) - (array_union ahs xhs) - (intset_union aeei x_extra_env_ids)) - ) (array (array) resume_hashes (array)) (map needed_for_progress x))) - (progress_idxs (cond ((and (= nil sub_progress_idxs) (not is_val) (= true attempted)) nil) - ((and (= nil sub_progress_idxs) (not is_val) (= false attempted)) true) - ((and (= nil sub_progress_idxs) (not is_val) (int? attempted)) (array attempted)) - (true (if (int? attempted) - (intset_item_union sub_progress_idxs attempted) - sub_progress_idxs)))) - ) (array 'marked_array (hash_array is_val attempted x) is_val attempted (array progress_idxs hashes extra) x source resume_hashes)))) - - - (marked_env (lambda (has_vals de? de ue dbi arrs) (dlet ( - (de_entry (mif de? (array (array de? de)) (array))) - (full_arrs (concat arrs de_entry (array ue))) - ((progress_idxs1 _hashes extra1) (mif ue (needed_for_progress ue) (array nil nil nil))) - ((progress_idxs2 _hashes extra2) (mif de? (needed_for_progress de) (array nil nil nil))) - (progress_idxs (intset_union progress_idxs1 progress_idxs2)) - (extra (intset_union extra1 extra2)) - (progress_idxs (if (not has_vals) (intset_item_union progress_idxs dbi) progress_idxs)) - (extra (if (!= nil progress_idxs) (intset_item_union extra dbi) extra)) - ) (array 'env (hash_env has_vals progress_idxs dbi full_arrs) has_vals (array progress_idxs nil extra) dbi full_arrs)))) - - - (marked_val (lambda (x) (array 'val (hash_val x) x))) - (marked_comb (lambda (wrap_level env_id de? se variadic params body) (array 'comb (hash_comb wrap_level env_id de? se variadic params body) wrap_level env_id de? se variadic params body))) - (comb_w_body (dlambda ((_comb _hash wrap_level env_id de? se variadic params _body) new_body) (marked_comb wrap_level env_id de? se variadic params new_body))) - (marked_prim_comb (lambda (handler_fun real_or_name wrap_level val_head_ok) (array 'prim_comb (hash_prim_comb handler_fun real_or_name wrap_level val_head_ok) handler_fun real_or_name wrap_level val_head_ok))) - - (with_wrap_level (lambda (x new_wrap) (cond ((prim_comb? x) (dlet (((handler_fun real_or_name wrap_level val_head_ok) (.prim_comb x))) - (marked_prim_comb handler_fun real_or_name new_wrap val_head_ok))) - ((comb? x) (dlet (((wrap_level env_id de? se variadic params body) (.comb x))) - (marked_comb new_wrap env_id de? se variadic params body))) - (true (error "bad with_wrap_level"))))) - - - (later_head? (rec-lambda recurse (x) (or (and (marked_array? x) (or (= false (.marked_array_is_val x)) (foldl (lambda (a x) (or a (recurse x))) false (.marked_array_values x)))) - (and (marked_symbol? x) (= false (.marked_symbol_is_val x))) - ))) - - - ; array and comb are the ones wherewhere (= nil (needed_for_progress_slim x)) == total_value? isn't true. - ; Right now we only call functions when all parameters are values, which means you can't - ; create a true_value array with non-value memebers (*right now* anyway), but it does mean that - ; you can create a nil needed for progress array that isn't a value, namely for the give_up_* - ; primitive functions (extra namely, log and error, which are our two main sources of non-purity besides implicit runtime errors). - ; OR, currently, having your code stopped because of infinite recursion checker. This comes up with the Y combiner - ; For combs, being a value is having your env-chain be real? - (total_value? (lambda (x) (if (marked_array? x) (.marked_array_is_val x) - (= nil (needed_for_progress_slim x))))) - - - (is_all_values (lambda (evaled_params) (foldl (lambda (a x) (and a (total_value? x))) true evaled_params))) - (is_all_head_values (lambda (evaled_params) (foldl (lambda (a x) (and a (not (later_head? x)))) true evaled_params))) - - (false? (lambda (x) (cond ((and (marked_array? x) (= false (.marked_array_is_val x))) (error "got a later marked_array passed to false? " x)) - ((and (marked_symbol? x) (= false (.marked_symbol_is_val x))) (error "got a later marked_symbol passed to false? " x)) - ((val? x) (not (.val x))) - (true false)))) - - - (mark (rec-lambda recurse (x) (cond ((env? x) (error "called mark with an env " x)) - ((combiner? x) (error "called mark with a combiner " x)) - ((symbol? x) (cond ((= 'true x) (marked_val #t)) - ((= 'false x) (marked_val #f)) - (#t (marked_symbol nil x)))) - ((array? x) (marked_array true false nil (map recurse x) true)) - (true (marked_val x))))) - - (indent_str (rec-lambda recurse (i) (mif (= i 0) "" - (str " " (recurse (- i 1)))))) - (indent_str (if speed_hack (lambda (i) "") indent_str)) - - (str_strip (lambda args (apply true_str (concat (slice args 0 -2) (array (idx ((rec-lambda recurse (x done_envs) - (cond ((= nil x) (array "" done_envs)) - ((string? x) (array (true_str "") done_envs)) - ((val? x) (array (true_str (.val x)) done_envs)) - ((marked_array? x) (dlet (((stripped_values done_envs) (foldl (dlambda ((vs de) x) (dlet (((v de) (recurse x de))) (array (concat vs (array v)) de))) - (array (array) done_envs) (.marked_array_values x)))) - (mif (.marked_array_is_val x) (array (true_str "[" stripped_values "]") done_envs) - ;(array (true_str stripped_values) done_envs)))) - (array (true_str "" stripped_values) done_envs)))) - ((marked_symbol? x) (mif (.marked_symbol_is_val x) (array (true_str "'" (.marked_symbol_value x)) done_envs) - (array (true_str (.marked_symbol_needed_for_progress x) "#" (.marked_symbol_value x)) done_envs))) - ((comb? x) (dlet (((wrap_level env_id de? se variadic params body) (.comb x)) - ((se_s done_envs) (recurse se done_envs)) - ((body_s done_envs) (recurse body done_envs))) - (array (true_str "") done_envs))) - ((prim_comb? x) (array (true_str "") done_envs)) - ((marked_env? x) (dlet ((e (.env_marked x)) - (index (.marked_env_id x)) - (u (idx e -1)) - (already (in_array index done_envs)) - (opening (true_str "{" (mif (marked_env_real? x) "real" "fake") (mif (.marked_env_has_vals x) " real vals" " fake vals") " ENV idx: " (true_str index) ", ")) - ((middle done_envs) (if already (array "" done_envs) (foldl (dlambda ((vs de) (k v)) (dlet (((x de) (recurse v de))) (array (concat vs (array (array k x))) de))) - (array (array) done_envs) - (slice e 0 -2)))) - ((upper done_envs) (if already (array "" done_envs) (mif u (recurse u done_envs) (array "no_upper_likely_root_env" done_envs)))) - (done_envs (if already done_envs (cons index done_envs))) - ) (array (if already (true_str opening "omitted}") - (if (> (len e) 30) (true_str "{" (len e) "env}") - (true_str opening middle " upper: " upper "}"))) done_envs) - )) - (true (error (true_str "some other str_strip? |" x "|"))) - ) - ) (idx args -1) (array)) 0)))))) - (true_str_strip str_strip) - (str_strip (if speed_hack (lambda args 0) str_strip)) - ;(true_str_strip str_strip) - (print_strip (lambda args (println (apply str_strip args)))) - - (env-lookup-helper (rec-lambda recurse (dict key i fail success) (cond ((and (= i (- (len dict) 1)) (= nil (idx dict i))) (fail)) - ((= i (- (len dict) 1)) (recurse (.env_marked (idx dict i)) key 0 fail success)) - ((= key (idx (idx dict i) 0)) (success (idx (idx dict i) 1))) - (true (recurse dict key (+ i 1) fail success))))) - (env-lookup (lambda (env key) (env-lookup-helper (.env_marked env) key 0 (lambda () (error (str key " not found in env " (str_strip env)))) (lambda (x) x)))) - - (strip (dlet ((helper (rec-lambda recurse (x need_value) - (cond ((val? x) (.val x)) - ((marked_array? x) (dlet ((stripped_values (map (lambda (x) (recurse x need_value)) (.marked_array_values x)))) - (mif (.marked_array_is_val x) stripped_values - (error (str "needed value for this strip but got" x))))) - ((marked_symbol? x) (mif (.marked_symbol_is_val x) (.marked_symbol_value x) - (error (str "needed value for this strip but got" x)))) - ((comb? x) (error "got comb for strip, won't work")) - ((prim_comb? x) (idx x 2)) - ; env emitting doesn't pay attention to real value right now, not sure mif that makes sense - ; TODO: properly handle de Bruijn indexed envs - ((marked_env? x) (error "got env for strip, won't work")) - (true (error (str "some other strip? " x))) - ) - ))) (lambda (x) (dlet ( - ;(_ (print_strip "stripping: " x)) - (r (helper x true)) - ;(_ (println "result of strip " r)) - ) r)))) - - (try_unval (rec-lambda recurse (x fail_f) - (cond ((marked_array? x) (mif (not (.marked_array_is_val x)) (array false (fail_f x)) - (if (!= 0 (len (.marked_array_values x))) - (dlet ((values (.marked_array_values x)) - ((ok f) (recurse (idx values 0) fail_f)) - ) (array ok (marked_array false false nil (cons f (slice values 1 -1)) (.marked_array_source x)))) - (array true (marked_array false false nil (array) (.marked_array_source x)))))) - ((marked_symbol? x) (mif (.marked_symbol_is_val x) (array true (marked_symbol true (.marked_symbol_value x))) - (array false (fail_f x)))) - (true (array true x)) - ) - )) - (try_unval_array (lambda (x) (foldl (dlambda ((ok a) x) (dlet (((nok p) (try_unval x (lambda (_) nil)))) - (array (and ok nok) (concat a (array p))))) - (array true (array)) - x))) - - (check_for_env_id_in_result (lambda (s_env_id x) (idx ((rec-lambda check_for_env_id_in_result (memo s_env_id x) - (dlet ( - ((need _hashes extra) (needed_for_progress x)) - (in_need (if (!= true need) (in_intset s_env_id need) false)) - (in_extra (in_intset s_env_id extra)) - ;(or in_need in_extra) (array memo true) - ;(!= true need) (array memo false) - ) (cond ((or in_need in_extra) (array memo true)) - ((!= true need) (array memo false)) - (true (dlet ( - - (old_way (dlet ( - (hash (.hash x)) - ;(result (if (or (comb? x) (marked_env? x)) (alist-ref hash memo) false)) - ;(result (if (or (marked_array? x) (marked_env? x)) (alist-ref hash memo) false)) - ;(result (if (marked_env? x) (my-alist-ref hash memo) false)) - (result (if (marked_env? x) (get memo hash) false)) - ) (if (array? result) (array memo (idx result 1)) (cond - ((marked_symbol? x) (array memo false)) - ((marked_array? x) (dlet ( - (values (.marked_array_values x)) - ((memo result) ((rec-lambda recurse (memo i) (if (= (len values) i) (array memo false) - (dlet (((memo r) (check_for_env_id_in_result memo s_env_id (idx values i)))) - (if r (array memo true) - (recurse memo (+ i 1)))))) - memo 0)) - ;(memo (put memo hash result)) - ) (array memo result))) - ((prim_comb? x) (array memo false)) - ((val? x) (array memo false)) - ((comb? x) (dlet ( - ((wrap_level i_env_id de? se variadic params body) (.comb x)) - ((memo in_se) (check_for_env_id_in_result memo s_env_id se)) - ((memo total) (if (and (not in_se) (!= s_env_id i_env_id)) (check_for_env_id_in_result memo s_env_id body) - (array memo in_se))) - ;(memo (put memo hash total)) - ) (array memo total))) - - ((marked_env? x) (if (and (not (marked_env_real? x)) (= s_env_id (.marked_env_id x))) (array memo true) - (dlet ( - (values (slice (.env_marked x) 0 -2)) - (upper (idx (.env_marked x) -1)) - ((memo result) ((rec-lambda recurse (memo i) (if (= (len values) i) (array memo false) - (dlet (((memo r) (check_for_env_id_in_result memo s_env_id (idx (idx values i) 1)))) - (if r (array memo true) - (recurse memo (+ i 1)))))) - memo 0)) - ((memo result) (if (or result (= nil upper)) (array memo result) - (check_for_env_id_in_result memo s_env_id upper))) - (memo (put memo hash result)) - ) (array memo result)))) - (true (error (str "Something odd passed to check_for_env_id_in_result " x))) - )))) - - (new_if_working (or in_need in_extra)) - (_ (if (and (!= true need) (!= new_if_working (idx old_way 1))) (error "GAH looking for " s_env_id " - " need " - " extra " - " new_if_working " " (idx old_way 1)))) - ) old_way))))) (array) s_env_id x) 1))) - - (comb_takes_de? (lambda (x l) (cond - ((comb? x) (!= nil (.comb_des x))) - ((prim_comb? x) (cond ((= (.prim_comb_sym x) 'vau) true) - ((= (.prim_comb_sym x) 'eval) (= 1 l)) - ((= (.prim_comb_sym x) 'veval) (= 1 l)) - ((= (.prim_comb_sym x) 'lapply) (= 1 l)) - ((= (.prim_comb_sym x) 'vapply) (= 1 l)) - ((= (.prim_comb_sym x) 'cond) true) ; but not vcond - (true false))) - ((and (marked_array? x) (not (.marked_array_is_val x))) true) - ((and (marked_symbol? x) (not (.marked_symbol_is_val x))) true) - (true (error (str "illegal comb_takes_de? param " x))) - ))) - - ; Handles let 4.3 through macro level leaving it as ( 13) - ; need handling of symbols (which is illegal for eval but ok for calls) to push it farther - (combiner_return_ok (rec-lambda combiner_return_ok (func_result env_id) - (cond ((not (later_head? func_result)) (not (check_for_env_id_in_result env_id func_result))) - ; special cases now - ; *(veval body {env}) => (combiner_return_ok {env}) - ; The reason we don't have to check body is that this form is only creatable in ways that body was origionally a value and only need {env} - ; Either it's created by eval, in which case it's fine, or it's created by something like (eval (array veval x de) de2) and the array has checked it, - ; or it's created via literal vau invocation, in which case the body is a value. - ((and (marked_array? func_result) - (prim_comb? (idx (.marked_array_values func_result) 0)) - (= 'veval (.prim_comb_sym (idx (.marked_array_values func_result) 0))) - (= 3 (len (.marked_array_values func_result))) - (combiner_return_ok (idx (.marked_array_values func_result) 2) env_id)) true) - ; (func ...params) => (and (doesn't take de func) (foldl combiner_return_ok (cons func params))) - ; - ((and (marked_array? func_result) - (not (comb_takes_de? (idx (.marked_array_values func_result) 0) (len (.marked_array_values func_result)))) - (foldl (lambda (a x) (and a (combiner_return_ok x env_id))) true (.marked_array_values func_result))) true) - - ; So that's enough for macro like, but we would like to take it farther - ; For like (let1 a 12 (wrap (vau (x) (let1 y (+ a 1) (+ y x a))))) - ; we get to (+ 13 x 12) not being a value, and it reconstructs - ; ( 13) - ; and that's what eval gets, and eval then gives up as well. - - ; That will get caught by the above cases to remain the expansion ( 13), - ; but ideally we really want another case to allow (+ 13 x 12) to bubble up - ; I think it would be covered by the (func ...params) case if a case is added to allow symbols to be bubbled up if their - ; needed for progress wasn't true or the current environment, BUT this doesn't work for eval, just for functions, - ; since eval changes the entire env chain (but that goes back to case 1, and might be eliminated at compile if it's an env reachable from the func). - ; - ; - ; Do note a key thing to be avoided is allowing any non-val inside a comb, since that can cause a fake env's ID to - ; reference the wrong env/comb in the chain. - ; We do allow calling eval with a fake env, but since it's only callable withbody value and is strict (by calling this) - ; about it's return conditions, and the env it's called with must be ok in the chain, and eval doesn't introduce a new scope, it works ok. - ; We do have to be careful about allowing returned later symbols from it though, since it could be an entirely different env chain. - - (true false) - ) - )) - - (drop_redundent_veval (rec-lambda drop_redundent_veval (partial_eval_helper x de env_stack pectx indent) (dlet ( - (env_id (.marked_env_id de)) - (r (if - (and (marked_array? x) (not (.marked_array_is_val x))) - (if (and (prim_comb? (idx (.marked_array_values x) 0)) - (= 'veval (.prim_comb_sym (idx (.marked_array_values x) 0))) - (= 3 (len (.marked_array_values x))) - (not (marked_env_real? (idx (.marked_array_values x) 2))) - (= env_id (.marked_env_id (idx (.marked_array_values x) 2)))) (drop_redundent_veval partial_eval_helper (idx (.marked_array_values x) 1) de env_stack pectx (+ 1 indent)) - ; wait, can it do this? will this mess with eval? - - ; basically making sure that this comb's params are still good to eval - (if (and (or (prim_comb? (idx (.marked_array_values x) 0)) (comb? (idx (.marked_array_values x) 0))) - (!= -1 (.any_comb_wrap_level (idx (.marked_array_values x) 0)))) - (dlet (((pectx err ress changed) (foldl (dlambda ((c er ds changed) p) (dlet ( - (pre_hash (.hash p)) - ((c e d) (drop_redundent_veval partial_eval_helper p de env_stack c (+ 1 indent))) - (err (mif er er e)) - (changed (mif err false (or (!= pre_hash (.hash d)) changed))) - ) (array c err (concat ds (array d)) changed))) - (array pectx nil (array) false) - (.marked_array_values x))) - ((pectx err new_array) (if (or (!= nil err) (not changed)) - (array pectx err x) - (partial_eval_helper (marked_array false (.marked_array_is_attempted x) nil ress (.marked_array_source x)) - false de env_stack pectx (+ indent 1) true))) - - ) (array pectx err new_array)) - (array pectx nil x)) - ) (array pectx nil x)))) - - r))) - - (make_tmp_inner_env (lambda (params de? ue env_id) - (dlet ((param_entries (map (lambda (p) (array p (marked_symbol env_id p))) params)) - (possible_de (mif (= nil de?) (array) (marked_symbol env_id de?))) - ) (marked_env false de? possible_de ue env_id param_entries)))) - - - (partial_eval_helper (rec-lambda partial_eval_helper (x only_head env env_stack pectx indent force) - (dlet (((for_progress for_progress_hashes extra_env_ids) (needed_for_progress x)) - (_ (print_strip (indent_str indent) "for_progress " for_progress ", for_progress_hashes " for_progress_hashes " for " x)) - ((env_counter memo) pectx) - (hashes_now (foldl (lambda (a hash) (or a (= false (get-value-or-false memo hash)))) false for_progress_hashes)) - ) - (if (or force hashes_now (= for_progress true) (intset_intersection_nonempty for_progress (idx env_stack 0))) - (cond ((val? x) (array pectx nil x)) - ((marked_env? x) (dlet ((dbi (.marked_env_id x))) - ; compiler calls with empty env stack - (mif dbi (dlet ( (new_env ((rec-lambda rec (i len_env_stack) (cond ((= i len_env_stack) nil) - ((= dbi (.marked_env_id (idx (idx env_stack 1) i))) (idx (idx env_stack 1) i)) - (true (rec (+ i 1) len_env_stack)))) - 0 (len (idx env_stack 1)))) - (_ (println (str_strip "replacing " x) (str_strip " with (if nonnil) " new_env))) - ) - (array pectx nil (if (!= nil new_env) new_env x))) - (array pectx nil x)))) - - ((comb? x) (dlet (((wrap_level env_id de? se variadic params body) (.comb x))) - (mif (or (and (not (marked_env_real? env)) (not (marked_env_real? se))) ; both aren't real, re-evaluation of creation site - (and (marked_env_real? env) (not (marked_env_real? se)))) ; new env real, but se isn't - creation! - (dlet ((inner_env (make_tmp_inner_env params de? env env_id)) - ((pectx err evaled_body) (partial_eval_helper body false inner_env (array (idx env_stack 0) (cons inner_env (idx env_stack 1))) pectx (+ indent 1) false))) - (array pectx err (mif err nil (marked_comb wrap_level env_id de? env variadic params evaled_body)))) - (array pectx nil x)))) - ((prim_comb? x) (array pectx nil x)) - ((marked_symbol? x) (mif (.marked_symbol_is_val x) x - (env-lookup-helper (.env_marked env) (.marked_symbol_value x) 0 - (lambda () (array pectx (str "could't find " (true_str_strip x) " in " (str_strip env)) nil)) - (lambda (x) (array pectx nil x))))) - ; Does this ever happen? non-fully-value arrays? - ((marked_array? x) (cond ((.marked_array_is_val x) (dlet ( ((pectx err inner_arr) (foldl (dlambda ((c er ds) p) (dlet (((c e d) (partial_eval_helper p false env env_stack c (+ 1 indent) false))) (array c (mif er er e) (concat ds (array d))))) - (array pectx nil (array)) - (.marked_array_values x))) - ) (array pectx err (mif err nil (marked_array true false nil inner_arr (.marked_array_source x)))))) - ((= 0 (len (.marked_array_values x))) (array pectx "Partial eval on empty array" nil)) - (true (dlet ((values (.marked_array_values x)) - (_ (print_strip (indent_str indent) "partial_evaling comb " (idx values 0))) - - (literal_params (slice values 1 -1)) - ((pectx err comb) (partial_eval_helper (idx values 0) false env env_stack pectx (+ 1 indent) false)) - ) (cond ((!= nil err) (array pectx err nil)) - ((later_head? comb) (array pectx nil (marked_array false true nil (cons comb literal_params) (.marked_array_source x)))) - ((not (or (comb? comb) (prim_comb? comb))) (array pectx (str "impossible comb value " x) nil)) - (true (dlet ( - ; If we haven't evaluated the function before at all, we would like to partially evaluate it so we know - ; what it needs. We'll see if this re-introduces exponentail (I think this should limit it to twice?) - (comb_err nil) - ;((pectx comb_err comb) (if (and (= nil err) (= true (needed_for_progress_slim comb))) - ; (partial_eval_helper comb false env env_stack pectx (+ 1 indent) false) - ; (array pectx err comb))) - (_ (println (indent_str indent) "Going to do an array call!")) - (indent (+ 1 indent)) - (_ (print_strip (indent_str indent) "total (in env " (.marked_env_id env) ") is (proceeding err " err ") " x)) - (map_rp_eval (lambda (pectx ps) (foldl (dlambda ((c er ds) p) (dlet ((_ (print_strip (indent_str indent) "rp_evaling " p)) ((c e d) (partial_eval_helper p false env env_stack c (+ 1 indent) false)) (_ (print_strip (indent_str indent) "result of rp_eval was err " e " and value " d))) (array c (mif er er e) (concat ds (array d))))) - (array pectx nil (array)) - ps))) - (wrap_level (.any_comb_wrap_level comb)) - ; -1 is a minor hack for veval to prevent re-eval - ; in the wrong env and vcond to prevent guarded - ; infinate recursion - ((remaining_wrap param_err evaled_params pectx) (if (= -1 wrap_level) - (array -1 nil literal_params pectx) - ((rec-lambda param-recurse (wrap cparams pectx) - (dlet ( - (_ (print (indent_str indent) "For initial rp_eval:")) - (_ (map (lambda (x) (print_strip (indent_str indent) "item " x)) cparams)) - ((pectx er pre_evaled) (map_rp_eval pectx cparams)) - (_ (print (indent_str indent) "er for intial rp_eval: " er)) - ) - (mif er (array wrap er nil pectx) - (mif (!= 0 wrap) - (dlet (((ok unval_params) (try_unval_array pre_evaled))) - (mif (not ok) (array wrap nil pre_evaled pectx) - (param-recurse (- wrap 1) unval_params pectx))) - (array wrap nil pre_evaled pectx))))) - wrap_level literal_params pectx))) - (_ (println (indent_str indent) "Done evaluating parameters")) - - (l_later_call_array (lambda () (marked_array false true nil (cons (with_wrap_level comb remaining_wrap) evaled_params) (.marked_array_source x)))) - (ok_and_non_later (or (= -1 remaining_wrap) - (and (= 0 remaining_wrap) (if (and (prim_comb? comb) (.prim_comb_val_head_ok comb)) - (is_all_head_values evaled_params) - (is_all_values evaled_params))))) - (_ (println (indent_str indent) "ok_and_non_later " ok_and_non_later)) - ) (cond ((!= nil comb_err) (array pectx comb_err nil)) - ((!= nil param_err) (array pectx param_err nil)) - ((not ok_and_non_later) (array pectx nil (l_later_call_array))) - ((prim_comb? comb) (dlet ( - ;(_ (println (indent_str indent) "Calling prim comb " (.prim_comb_sym comb))) - ;(_ (if (= '!= (.prim_comb_sym comb)) (true_print (indent_str indent) "Calling prim comb " (.prim_comb_sym comb) " with params " evaled_params))) - ((pectx err result) ((.prim_comb_handler comb) only_head env env_stack pectx evaled_params (+ 1 indent))) - ) (if (= 'LATER err) (array pectx nil (l_later_call_array)) - (array pectx err result)))) - ((comb? comb) (dlet ( - ((wrap_level env_id de? se variadic params body) (.comb comb)) - - - (final_params (mif variadic (concat (slice evaled_params 0 (- (len params) 1)) - (array (marked_array true false nil (slice evaled_params (- (len params) 1) -1) nil))) - evaled_params)) - (de_env (mif (!= nil de?) env nil)) - (inner_env (marked_env true de? de_env se env_id (zip params final_params))) - (_ (print_strip (indent_str indent) " with inner_env is " inner_env)) - (_ (print_strip (indent_str indent) "going to eval " body)) - - ; prevent infinite recursion - (hash (combine_hash (.hash body) (.hash inner_env))) - ((env_counter memo) pectx) - ((pectx func_err func_result rec_stop) (if (!= false (get-value-or-false memo hash)) - (array pectx nil "stopping for infinite recursion" true) - (dlet ( - (new_memo (put memo hash nil)) - (pectx (array env_counter new_memo)) - ((pectx func_err func_result) (partial_eval_helper body only_head inner_env - (array (intset_item_union (idx env_stack 0) env_id) - (cons inner_env (idx env_stack 1))) - pectx (+ 1 indent) false)) - ((env_counter new_memo) pectx) - (pectx (array env_counter memo)) - ) (array pectx func_err func_result false)))) - - (_ (print_strip (indent_str indent) "evaled result of function call (in env " (.marked_env_id env) ", with inner " env_id ") and err " func_err " is " func_result)) - (must_stop_maybe_id (and (= nil func_err) - (or rec_stop (if (not (combiner_return_ok func_result env_id)) - (if (!= nil de?) (.marked_env_id env) true) - false)))) - ) (if (!= nil func_err) (array pectx func_err nil) - (if must_stop_maybe_id - (array pectx nil (marked_array false must_stop_maybe_id (if rec_stop (array hash) nil) (cons (with_wrap_level comb remaining_wrap) evaled_params) (.marked_array_source x))) - (dlet (((pectx err x) (drop_redundent_veval partial_eval_helper func_result env env_stack pectx indent))) - (array pectx err x)))))) - ))) - ))))) - - (true (array pectx (str "impossible partial_eval value " x) nil)) - ) - ; otherwise, we can't make progress yet - (begin (print_strip (indent_str indent) "Not evaluating " x) - ;(print (indent_str indent) "comparing to env stack " env_stack) - (drop_redundent_veval partial_eval_helper x env env_stack pectx indent)))) - )) - - (needs_params_val_lambda (lambda (f_sym actual_function) (dlet ( - (handler (rec-lambda recurse (only_head de env_stack pectx params indent) - (array pectx nil (mark (apply actual_function (map strip params)))))) - ) (array f_sym (marked_prim_comb handler f_sym 1 false))))) - - (give_up_eval_params (lambda (f_sym) (dlet ( - (handler (lambda (only_head de env_stack pectx params indent) (array pectx 'LATER nil))) - ) (array f_sym (marked_prim_comb handler f_sym 1 false))))) - - (veval_inner (rec-lambda recurse (only_head de env_stack pectx params indent) (dlet ( - (body (idx params 0)) - (implicit_env (!= 2 (len params))) - (eval_env (if implicit_env de (idx params 1))) - ((pectx err eval_env) (if implicit_env (array pectx nil de) - (partial_eval_helper (idx params 1) only_head de env_stack pectx (+ 1 indent) false))) - ((pectx err ebody) (if (or (!= nil err) (not (marked_env? eval_env))) - (array pectx err body) - (partial_eval_helper body only_head eval_env env_stack pectx (+ 1 indent) false))) - ) (cond - ((!= nil err) (begin (print (indent_str indent) "got err " err) (array pectx err nil))) - ; If our env was implicit, then our unval'd code can be inlined directly in our caller - (implicit_env (drop_redundent_veval partial_eval_helper ebody de env_stack pectx indent)) - ((combiner_return_ok ebody (.marked_env_id eval_env)) (drop_redundent_veval partial_eval_helper ebody de env_stack pectx indent)) - (true (drop_redundent_veval partial_eval_helper (marked_array false true nil (array (marked_prim_comb recurse 'veval -1 true) ebody eval_env) nil) de env_stack pectx indent)) - )))) - - (env_id_start 1) - (empty_env (marked_env true nil nil nil nil nil)) - (quote_internal (marked_comb 0 env_id_start nil empty_env false (array 'x) (marked_symbol env_id_start 'x))) - (env_id_start (+ 1 env_id_start)) - - (root_marked_env (marked_env true nil nil nil nil (array - - (array 'eval (marked_prim_comb (rec-lambda recurse (only_head de env_stack pectx evaled_params indent) - (if (not (total_value? (idx evaled_params 0))) (array pectx nil (marked_array false true nil (cons (marked_prim_comb recurse 'eval 0 true) evaled_params) nil)) - (if (and (= 2 (len evaled_params)) (not (marked_env? (idx evaled_params 1)))) (array pectx nil (marked_array false true nil (cons (marked_prim_comb recurse 'eval 0 true) evaled_params) nil)) - (dlet ( - (body (idx evaled_params 0)) - (implicit_env (!= 2 (len evaled_params))) - (eval_env (if implicit_env de (idx evaled_params 1))) - ((ok unval_body) (try_unval body (lambda (_) nil))) - (_ (if (not ok) (error "actually impossible eval unval"))) - - - ) (veval_inner only_head de env_stack pectx (if implicit_env (array unval_body) (array unval_body eval_env)) indent)))) - ) 'eval 1 true)) - - (array 'vapply (marked_prim_comb (dlambda (only_head de env_stack pectx args indent) - (veval_inner only_head de env_stack pectx (array (marked_array false false nil (cons (idx args 0) (.marked_array_values (idx args 1))) nil) (mif (= 3 (len args)) (idx args 2) de)) (+ 1 indent)) - ) 'vapply 1 true)) - (array 'lapply (marked_prim_comb (dlambda (only_head de env_stack pectx args indent) - (mif (< 0 (.any_comb_wrap_level (idx args 0))) - (veval_inner only_head de env_stack pectx (array (marked_array false false nil (cons (with_wrap_level (idx args 0) (- (.any_comb_wrap_level (idx args 0)) 1)) (.marked_array_values (idx args 1))) nil) (mif (= 3 (len args)) (idx args 2) de)) (+ 1 indent)) - (veval_inner only_head de env_stack pectx (array (marked_array false false nil (cons (idx args 0) - (map (lambda (x) (marked_array false false nil (array quote_internal x) nil)) (.marked_array_values (idx args 1))) - ) nil) (mif (= 3 (len args)) (idx args 2) de)) (+ 1 indent)) - ) - ) 'lapply 1 true)) - - (array 'vau (marked_prim_comb (lambda (only_head de env_stack pectx params indent) (dlet ( - (mde? (mif (= 3 (len params)) (idx params 0) nil)) - (vau_mde? (mif (= nil mde?) (array) (array mde?))) - (_ (print (indent_str indent) "mde? is " mde?)) - (_ (print (indent_str indent) "\tmde? if " (mif mde? #t #f))) - (de? (mif mde? (.marked_symbol_value mde?) nil)) - (_ (print (indent_str indent) "de? is " de?)) - (vau_de? (mif (= nil de?) (array) (array de?))) - (raw_marked_params (mif (= nil de?) (idx params 0) (idx params 1))) - (raw_params (map (lambda (x) (mif (not (marked_symbol? x)) (error (str "not a marked symbol " x)) - (.marked_symbol_value x))) (.marked_array_values raw_marked_params))) - - ((variadic vau_params) (foldl (dlambda ((v a) x) (mif (= x '&) (array true a) (array v (concat a (array x))))) (array false (array)) raw_params)) - ((ok body) (try_unval (mif (= nil de?) (idx params 1) (idx params 2)) (lambda (_) nil))) - (_ (if (not ok) (error "actually impossible vau unval"))) - ((env_counter memo) pectx) - (new_id env_counter) - (env_counter (+ 1 env_counter)) - (pectx (array env_counter memo)) - ((pectx err pe_body) (if (and false only_head) (begin (print "skipping inner eval cuz only_head") (array pectx nil body)) - (dlet ( - (inner_env (make_tmp_inner_env vau_params de? de new_id)) - (_ (print_strip (indent_str indent) "in vau, evaluating body with 'later params - " body)) - ((pectx err pe_body) (partial_eval_helper body false inner_env (array (idx env_stack 0) - (cons inner_env (idx env_stack 1))) pectx (+ 1 indent) false)) - (_ (print_strip (indent_str indent) "in vau, result of evaluating body was " pe_body)) - ) (array pectx err pe_body)))) - ) (mif err (array pectx err nil) (array pectx nil (marked_comb 0 new_id de? de variadic vau_params pe_body))) - )) 'vau 0 true)) - - (array 'wrap (marked_prim_comb (dlambda (only_head de env_stack pectx (evaled) indent) - (if (comb? evaled) (array pectx nil (with_wrap_level evaled (+ (.any_comb_wrap_level evaled) 1))) - (array pectx "bad passed to wrap" nil)) - ) 'wrap 1 true)) - - (array 'unwrap (marked_prim_comb (dlambda (only_head de env_stack pectx (evaled) indent) - ; TODO should support prim comb like runtime - (if (comb? evaled) (array pectx nil (with_wrap_level evaled (- (.any_comb_wrap_level evaled) 1))) - (array pectx "bad passed to unwrap" nil)) - ) 'unwrap 1 true)) - - (array 'cond (marked_prim_comb ((rec-lambda recurse (already_stripped) (lambda (only_head de env_stack pectx params indent) - (mif (!= 0 (% (len params) 2)) (array pectx (str "partial eval cond with odd params " params) nil) - (dlet ( - (eval_helper (lambda (to_eval pectx) - (dlet (((ok unvald) (if already_stripped (array true to_eval) - (try_unval to_eval (lambda (_) nil))))) - (mif (not ok) - (array pectx "bad unval in cond" nil) - (partial_eval_helper unvald false de env_stack pectx (+ 1 indent) false))))) - ) - ((rec-lambda recurse_inner (i so_far pectx) - (dlet (((pectx err pred) (eval_helper (idx params i) pectx))) - (cond ((!= nil err) (array pectx err nil)) - ((later_head? pred) (dlet ( - (sliced_params (slice params (+ i 1) -1)) - (this (marked_array false true nil (concat (array (marked_prim_comb (recurse false) 'cond 0 true) - pred) - sliced_params) nil)) - (hash (combine_hash (combine_hash 101 (.hash this)) (+ 103 (.marked_env_id de)))) - ((env_counter memo) pectx) - (already_in (!= false (get-value-or-false memo hash))) - (_ (if already_in (print_strip "ALREADY IN " this) - (print_strip "NOT ALREADY IN, CONTINUING with " this))) - ; WE SHOULDN'T DIE ON ERROR, since these errors may be guarded by conditions we - ; can't evaluate. We'll keep branches that error as un-valed only - ((pectx _err evaled_params later_hash) (if already_in - (array pectx nil (if already_stripped sliced_params - (map (lambda (x) (dlet (((ok ux) (try_unval x (lambda (_) nil))) - (_ (if (not ok) (error "BAD cond un first " already_stripped " " x)))) - ux)) - sliced_params)) (array hash)) - (foldl (dlambda ((pectx _err as later_hash) x) - (dlet (((pectx er a) (eval_helper x pectx))) - (mif er (dlet (((ok ux) (if already_stripped (array true x) (try_unval x (lambda (_) nil)))) - (_ (if (not ok) (error (str "BAD cond un second " already_stripped " " x))))) - (array pectx nil (concat as (array ux)) later_hash)) - (array pectx nil (concat as (array a)) later_hash))) - ) (array (array env_counter (put memo hash nil)) nil (array) nil) sliced_params))) - ((env_counter omemo) pectx) - (new_call (concat (array (marked_prim_comb (recurse true) 'vcond -1 true) pred) evaled_params)) - (pectx (array env_counter memo)) - ) (array pectx nil (marked_array false true later_hash new_call nil)))) - ((and (< (+ 2 i) (len params)) (false? pred)) (recurse_inner (+ 2 i) so_far pectx)) - ( (false? pred) (array pectx "comb reached end with no true" nil)) - (true (eval_helper (idx params (+ i 1)) pectx)) - ))) 0 (array) pectx)) - ) - )) false) 'cond 0 true)) - - (needs_params_val_lambda 'symbol? symbol?) - (needs_params_val_lambda 'int? int?) - (needs_params_val_lambda 'string? string?) - - (array 'combiner? (marked_prim_comb (dlambda (only_head de env_stack pectx (evaled_param) indent) - (array pectx nil (cond - ((comb? evaled_param) (marked_val true)) - ((prim_comb? evaled_param) (marked_val true)) - (true (marked_val false)) - )) - ) 'combiner? 1 true)) - (array 'env? (marked_prim_comb (dlambda (only_head de env_stack pectx (evaled_param) indent) - (array pectx nil (cond - ((marked_env? evaled_param) (marked_val true)) - (true (marked_val false)) - )) - ) 'env? 1 true)) - (needs_params_val_lambda 'nil? nil?) - (needs_params_val_lambda 'bool? bool?) - (needs_params_val_lambda 'str-to-symbol str-to-symbol) - (needs_params_val_lambda 'get-text get-text) - - (array 'array? (marked_prim_comb (dlambda (only_head de env_stack pectx (evaled_param) indent) - (array pectx nil (cond - ((marked_array? evaled_param) (marked_val true)) - (true (marked_val false)) - )) - ) 'array? 1 true)) - - ; Look into eventually allowing some non values, perhaps, when we look at combiner non all value params - (array 'array (marked_prim_comb (lambda (only_head de env_stack pectx evaled_params indent) - (array pectx nil (marked_array true false nil evaled_params nil)) - ) 'array 1 false)) - (array 'len (marked_prim_comb (dlambda (only_head de env_stack pectx (evaled_param) indent) - (cond - ((marked_array? evaled_param) (array pectx nil (marked_val (len (.marked_array_values evaled_param))))) - ((and (val? evaled_param) - (string? (.val evaled_param))) (array pectx nil (marked_val (len (.val evaled_param))))) - (true (array pectx (str "bad type to len " evaled_param) nil)) - ) - ) 'len 1 true)) - (array 'idx (marked_prim_comb (dlambda (only_head de env_stack pectx (evaled_array evaled_idx) indent) - (cond - ((and (val? evaled_idx) (marked_array? evaled_array)) (if (< (.val evaled_idx) (len (.marked_array_values evaled_array))) - (array pectx nil (idx (.marked_array_values evaled_array) (.val evaled_idx))) - (array pectx (true_str "idx out of bounds " evaled_array " " evaled_idx) nil))) - ((and (val? evaled_idx) (val? evaled_array) (string? (.val evaled_array))) (array pectx nil (marked_val (idx (.val evaled_array) (.val evaled_idx))))) - (true (array pectx (str "bad type to idx " evaled_idx " " evaled_array) nil)) - ) - ) 'idx 1 true)) - (array 'slice (marked_prim_comb (dlambda (only_head de env_stack pectx (evaled_array evaled_begin evaled_end) indent) - (cond - ((and (val? evaled_begin) (val? evaled_end) (marked_array? evaled_array) - - (int? (.val evaled_begin)) - (or (and (>= (.val evaled_begin) 0) (<= (.val evaled_begin) (len (.marked_array_values evaled_array)))) - (and (< (.val evaled_begin) 0) (>= (+ (.val evaled_begin) 1 (len (.marked_array_values evaled_array))) 0) - (<= (+ (.val evaled_begin) 1 (len (.marked_array_values evaled_array))) (len (.marked_array_values evaled_array))))) - (int? (.val evaled_end)) - (or (and (>= (.val evaled_end) 0) (<= (.val evaled_end) (len (.marked_array_values evaled_array)))) - (and (< (.val evaled_end) 0) (>= (+ (.val evaled_end) 1 (len (.marked_array_values evaled_array))) 0) - (<= (+ (.val evaled_end) 1 (len (.marked_array_values evaled_array))) (len (.marked_array_values evaled_array))))) - ) - (array pectx nil (marked_array true false nil (slice (.marked_array_values evaled_array) (.val evaled_begin) (.val evaled_end)) nil))) - ((and (val? evaled_begin) (val? evaled_end) (val? evaled_array) (string? (.val evaled_array)) - - (int? (.val evaled_begin)) - (or (and (>= (.val evaled_begin) 0) (<= (.val evaled_begin) (len (.val evaled_array)))) - (and (< (.val evaled_begin) 0) (>= (+ (.val evaled_begin) 1 (len (.val evaled_array))) 0) - (<= (+ (.val evaled_begin) 1 (len (.val evaled_array))) (len (.val evaled_array))))) - (int? (.val evaled_end)) - (or (and (>= (.val evaled_end) 0) (<= (.val evaled_end) (len (.val evaled_array)))) - (and (< (.val evaled_end) 0) (>= (+ (.val evaled_end) 1 (len (.val evaled_array))) 0) - (<= (+ (.val evaled_end) 1 (len (.val evaled_array))) (len (.val evaled_array))))) - ) - - (array pectx nil (marked_val (slice (.val evaled_array) (.val evaled_begin) (.val evaled_end))))) - (true (array pectx (str "bad params to slice " evaled_begin " " evaled_end " " evaled_array) nil)) - ) - ) 'slice 1 true)) - (array 'concat (marked_prim_comb (lambda (only_head de env_stack pectx evaled_params indent) - (cond - ((foldl (lambda (a x) (and a (marked_array? x))) true evaled_params) - (array pectx nil (marked_array true false nil (lapply concat (map (lambda (x) (.marked_array_values x)) evaled_params)) nil))) - ((foldl (lambda (a x) (and a (val? x) (string? (.val x)))) true evaled_params) - (array pectx nil (marked_val (lapply concat (map (lambda (x) (.val x)) evaled_params))))) - (true (array pectx (str "bad params to concat " evaled_params) nil)) - ) - ) 'concat 1 true)) - - (needs_params_val_lambda '+ +) - (needs_params_val_lambda '- -) - (needs_params_val_lambda '* *) - (needs_params_val_lambda '/ /) - (needs_params_val_lambda '% %) - (needs_params_val_lambda 'band band) - (needs_params_val_lambda 'bor bor) - (needs_params_val_lambda 'bnot bnot) - (needs_params_val_lambda 'bxor bxor) - (needs_params_val_lambda '<< <<) - (needs_params_val_lambda '>> >>) - (needs_params_val_lambda '= =) - (needs_params_val_lambda '!= !=) - (needs_params_val_lambda '< <) - (needs_params_val_lambda '<= <=) - (needs_params_val_lambda '> >) - (needs_params_val_lambda '>= >=) - (needs_params_val_lambda 'str true_str) - ;(needs_params_val_lambda 'pr-str pr-str) - ;(needs_params_val_lambda 'prn prn) - (give_up_eval_params 'log) - (give_up_eval_params 'debug) - (give_up_eval_params 'builtin_fib) - ; really do need to figure out mif we want to keep meta, and add it mif so - ;(give_up_eval_params 'meta meta) - ;(give_up_eval_params 'with-meta with-meta) - ; mif we want to get fancy, we could do error/recover too - (give_up_eval_params 'error) - ;(give_up_eval_params 'recover) - (needs_params_val_lambda 'read-string read-string) - (array 'empty_env empty_env) - ))) - - (partial_eval (lambda (x) (partial_eval_helper (idx (try_unval (mark x) (lambda (_) nil)) 1) false root_marked_env (array nil nil) (array env_id_start empty_dict) 0 false))) - - - ;; WASM - - ; Vectors and Values - ; Bytes encode themselves - - ; Note that the shift must be arithmatic - (encode_LEB128 (rec-lambda recurse (x) - (dlet ((b (band #x7F x)) - (v (>> x 7))) - - (cond ((or (and (= v 0) (= (band b #x40) 0)) (and (= v -1) (!= (band b #x40) 0))) (array b)) - (true (cons (bor b #x80) (recurse v))))) - )) - (encode_vector (lambda (enc v) - (concat (encode_LEB128 (len v)) (flat_map enc v) ) - )) - (encode_floating_point (lambda (x) (error "unimplemented"))) - (encode_name (lambda (name) - (encode_vector (lambda (x) (array x)) (map char->integer (string->list name))) - )) - (hex_digit (lambda (digit) (dlet ((d (char->integer digit))) - (cond ((< d #x3A) (- d #x30)) - ((< d #x47) (- d #x37)) - (true (- d #x57)))))) - (encode_bytes (lambda (str) - (encode_vector (lambda (x) (array x)) ((rec-lambda recurse (s) (cond - ((= nil s) nil) - ((= #\\ (car s)) (cons (+ (* 16 (hex_digit (car (cdr s)))) - (hex_digit (car (cdr (cdr s))))) (recurse (cdr (cdr (cdr s)))))) - (true (cons (char->integer (car s)) (recurse (cdr s)))) - )) (string->list str))) - )) - - (encode_limits (lambda (x) - (cond ((= 1 (len x)) (concat (array #x00) (encode_LEB128 (idx x 0)))) - ((= 2 (len x)) (concat (array #x01) (encode_LEB128 (idx x 0)) (encode_LEB128 (idx x 1)))) - (true (error "trying to encode bad limits"))) - )) - (encode_number_type (lambda (x) - (cond ((= x 'i32) (array #x7F)) - ((= x 'i64) (array #x7E)) - ((= x 'f32) (array #x7D)) - ((= x 'f64) (array #x7C)) - (true (error (str "bad number type " x)))) - )) - (encode_valtype (lambda (x) - ; we don't handle reference types yet - (encode_number_type x) - )) - (encode_result_type (lambda (x) - (encode_vector encode_valtype x) - )) - (encode_function_type (lambda (x) - (concat (array #x60) (encode_result_type (idx x 0)) - (encode_result_type (idx x 1))) - )) - (encode_ref_type (lambda (t) (cond ((= t 'funcref) (array #x70)) - ((= t 'externref) (array #x6F)) - (true (error (str "Bad ref type " t)))))) - (encode_type_section (lambda (x) - (dlet ( - (encoded (encode_vector encode_function_type x)) - ) (concat (array #x01) (encode_LEB128 (len encoded)) encoded )) - )) - (encode_import (lambda (import) - (dlet ( - ((mod_name name type idx) import) - ) (concat (encode_name mod_name) - (encode_name name) - (cond ((= type 'func) (concat (array #x00) (encode_LEB128 idx))) - ((= type 'table) (concat (array #x01) (error "can't encode table type"))) - ((= type 'memory) (concat (array #x02) (error "can't encode memory type"))) - ((= type 'global) (concat (array #x03) (error "can't encode global type"))) - (true (error (str "bad import type" type))))) - ) - )) - (encode_import_section (lambda (x) - (dlet ( - (encoded (encode_vector encode_import x)) - ) (concat (array #x02) (encode_LEB128 (len encoded)) encoded )) - )) - - (encode_table_type (lambda (t) (concat (encode_ref_type (idx t 0)) (encode_limits (idx t 1))))) - - (encode_table_section (lambda (x) - (dlet ( - (encoded (encode_vector encode_table_type x)) - ) (concat (array #x04) (encode_LEB128 (len encoded)) encoded )) - )) - (encode_memory_section (lambda (x) - (dlet ( - (encoded (encode_vector encode_limits x)) - ) (concat (array #x05) (encode_LEB128 (len encoded)) encoded )) - )) - (encode_export (lambda (export) - (dlet ( - ((name type idx) export) - ) (concat (encode_name name) - (cond ((= type 'func) (array #x00)) - ((= type 'table) (array #x01)) - ((= type 'memory) (array #x02)) - ((= type 'global) (array #x03)) - (true (error "bad export type"))) - (encode_LEB128 idx) - )) - )) - (encode_export_section (lambda (x) - (dlet ( - ;(_ (print "encoding element " x)) - (encoded (encode_vector encode_export x)) - ;(_ (print "donex")) - ) (concat (array #x07) (encode_LEB128 (len encoded)) encoded )) - )) - - (encode_start_section (lambda (x) - (cond ((= 0 (len x)) (array)) - ((= 1 (len x)) (dlet ((encoded (encode_LEB128 (idx x 0)))) (concat (array #x08) (encode_LEB128 (len encoded)) encoded ))) - (true (error (str "bad lenbgth for start section " (len x) " was " x)))) - )) - - (encode_function_section (lambda (x) - (dlet ( ; nil functions are placeholders for improted functions - ;(_ (true_print "encoding function section " x)) - (filtered (filter (lambda (i) (!= nil i)) x)) - ;(_ (true_print "post filtered " filtered)) - (encoded (encode_vector encode_LEB128 filtered)) - ) (concat (array #x03) (encode_LEB128 (len encoded)) encoded )) - )) - (encode_blocktype (lambda (type) (cond ((symbol? type) (encode_valtype type)) - ((= (array) type) (array #x40)) ; empty type - (true (encode_LEB128 type)) - ))) - - (encode_ins (rec-lambda recurse (ins) - (dlet ( - ;(_ (true_print "encoding ins " ins)) - (op (idx ins 0)) - ) (cond ((= op 'unreachable) (array #x00)) - ((= op 'nop) (array #x01)) - ((= op 'block) (concat (array #x02) (encode_blocktype (idx ins 1)) (flat_map recurse (idx ins 2)) (array #x0B))) - ((= op 'loop) (concat (array #x03) (encode_blocktype (idx ins 1)) (flat_map recurse (idx ins 2)) (array #x0B))) - ((= op 'if) (concat (array #x04) (encode_blocktype (idx ins 1)) (flat_map recurse (idx ins 2)) (if (!= 3 (len ins)) (concat (array #x05) (flat_map recurse (idx ins 3))) - (array )) (array #x0B))) - ((= op 'br) (concat (array #x0C) (encode_LEB128 (idx ins 1)))) - ((= op 'br_if) (concat (array #x0D) (encode_LEB128 (idx ins 1)))) - ;... - ((= op 'return) (array #x0F)) - ((= op 'call) (concat (array #x10) (encode_LEB128 (idx ins 1)))) - ((= op 'call_indirect) (concat (array #x11) (encode_LEB128 (idx ins 1)) (encode_LEB128 (idx ins 2)))) - ; skipping a bunch - ; Parametric Instructions - ((= op 'drop) (array #x1A)) - ; skip - ; Variable Instructions - ((= op 'local.get) (concat (array #x20) (encode_LEB128 (idx ins 1)))) - ((= op 'local.set) (concat (array #x21) (encode_LEB128 (idx ins 1)))) - ((= op 'local.tee) (concat (array #x22) (encode_LEB128 (idx ins 1)))) - ((= op 'global.get) (concat (array #x23) (encode_LEB128 (idx ins 1)))) - ((= op 'global.set) (concat (array #x24) (encode_LEB128 (idx ins 1)))) - ; table - ; memory - ((= op 'i32.load) (concat (array #x28) (encode_LEB128 (idx ins 1)) (encode_LEB128 (idx ins 2)))) - ((= op 'i64.load) (concat (array #x29) (encode_LEB128 (idx ins 1)) (encode_LEB128 (idx ins 2)))) - ((= op 'i32.load8_s) (concat (array #x2C) (encode_LEB128 (idx ins 1)) (encode_LEB128 (idx ins 2)))) - ((= op 'i32.load8_u) (concat (array #x2D) (encode_LEB128 (idx ins 1)) (encode_LEB128 (idx ins 2)))) - ((= op 'i32.load16_s) (concat (array #x2E) (encode_LEB128 (idx ins 1)) (encode_LEB128 (idx ins 2)))) - ((= op 'i32.load16_u) (concat (array #x2F) (encode_LEB128 (idx ins 1)) (encode_LEB128 (idx ins 2)))) - ((= op 'i64.load8_s) (concat (array #x30) (encode_LEB128 (idx ins 1)) (encode_LEB128 (idx ins 2)))) - ((= op 'i64.load8_u) (concat (array #x31) (encode_LEB128 (idx ins 1)) (encode_LEB128 (idx ins 2)))) - ((= op 'i64.load16_s) (concat (array #x32) (encode_LEB128 (idx ins 1)) (encode_LEB128 (idx ins 2)))) - ((= op 'i64.load16_u) (concat (array #x33) (encode_LEB128 (idx ins 1)) (encode_LEB128 (idx ins 2)))) - ((= op 'i64.load32_s) (concat (array #x34) (encode_LEB128 (idx ins 1)) (encode_LEB128 (idx ins 2)))) - ((= op 'i64.load32_u) (concat (array #x35) (encode_LEB128 (idx ins 1)) (encode_LEB128 (idx ins 2)))) - ((= op 'i32.store) (concat (array #x36) (encode_LEB128 (idx ins 1)) (encode_LEB128 (idx ins 2)))) - ((= op 'i64.store) (concat (array #x37) (encode_LEB128 (idx ins 1)) (encode_LEB128 (idx ins 2)))) - ((= op 'i32.store8) (concat (array #x3A) (encode_LEB128 (idx ins 1)) (encode_LEB128 (idx ins 2)))) - ((= op 'i32.store16) (concat (array #x3B) (encode_LEB128 (idx ins 1)) (encode_LEB128 (idx ins 2)))) - ((= op 'i64.store8) (concat (array #x3C) (encode_LEB128 (idx ins 1)) (encode_LEB128 (idx ins 2)))) - ((= op 'i64.store16) (concat (array #x3D) (encode_LEB128 (idx ins 1)) (encode_LEB128 (idx ins 2)))) - ((= op 'memory.grow) (array #x40 #x00)) - ; Numeric Instructions - ((= op 'i32.const) (concat (array #x41) (encode_LEB128 (idx ins 1)))) - ((= op 'i64.const) (concat (array #x42) (encode_LEB128 (idx ins 1)))) - ((= op 'i32.eqz) (array #x45)) - ((= op 'i32.eq) (array #x46)) - ((= op 'i32.ne) (array #x47)) - ((= op 'i32.lt_s) (array #x48)) - ((= op 'i32.lt_u) (array #x49)) - ((= op 'i32.gt_s) (array #x4A)) - ((= op 'i32.gt_u) (array #x4B)) - ((= op 'i32.le_s) (array #x4C)) - ((= op 'i32.le_u) (array #x4D)) - ((= op 'i32.ge_s) (array #x4E)) - ((= op 'i32.ge_u) (array #x4F)) - - ((= op 'i64.eqz) (array #x50)) - ((= op 'i64.eq) (array #x51)) - ((= op 'i64.ne) (array #x52)) - ((= op 'i64.lt_s) (array #x53)) - ((= op 'i64.lt_u) (array #x54)) - ((= op 'i64.gt_s) (array #x55)) - ((= op 'i64.gt_u) (array #x56)) - ((= op 'i64.le_s) (array #x57)) - ((= op 'i64.le_u) (array #x58)) - ((= op 'i64.ge_s) (array #x59)) - ((= op 'i64.ge_u) (array #x5A)) - - ((= op 'i32.add) (array #x6A)) - ((= op 'i32.sub) (array #x6B)) - ((= op 'i32.mul) (array #x6C)) - ((= op 'i32.div_s) (array #x6D)) - ((= op 'i32.div_u) (array #x6E)) - ((= op 'i32.rem_s) (array #x6F)) - ((= op 'i32.rem_u) (array #x70)) - ((= op 'i32.and) (array #x71)) - ((= op 'i32.or) (array #x72)) - ((= op 'i32.shl) (array #x74)) - ((= op 'i32.shr_s) (array #x75)) - ((= op 'i32.shr_u) (array #x76)) - ((= op 'i64.add) (array #x7C)) - ((= op 'i64.sub) (array #x7D)) - ((= op 'i64.mul) (array #x7E)) - ((= op 'i64.div_s) (array #x7F)) - ((= op 'i64.div_u) (array #x80)) - ((= op 'i64.rem_s) (array #x81)) - ((= op 'i64.rem_u) (array #x82)) - ((= op 'i64.and) (array #x83)) - ((= op 'i64.or) (array #x84)) - ((= op 'i64.xor) (array #x85)) - ((= op 'i64.shl) (array #x86)) - ((= op 'i64.shr_s) (array #x87)) - ((= op 'i64.shr_u) (array #x88)) - - ((= op 'i32.wrap_i64) (array #xA7)) - ((= op 'i64.extend_i32_s) (array #xAC)) - ((= op 'i64.extend_i32_u) (array #xAD)) - - ((= op 'memory.copy) (array #xFC #x0A #x00 #x00)) - )) - )) - - (encode_expr (lambda (expr) (concat (flat_map encode_ins expr) (array #x0B)))) - (encode_code (lambda (x) - (dlet ( - ((locals body) x) - (enc_locals (encode_vector (lambda (loc) - (concat (encode_LEB128 (idx loc 0)) (encode_valtype (idx loc 1)))) locals)) - (enc_expr (encode_expr body)) - (code_bytes (concat enc_locals enc_expr)) - ) (concat (encode_LEB128 (len code_bytes)) code_bytes)) - )) - (encode_code_section (lambda (x) - (dlet ( - (encoded (encode_vector encode_code x)) - ) (concat (array #x0A) (encode_LEB128 (len encoded)) encoded )) - )) - - (encode_global_type (lambda (t) (concat (encode_valtype (idx t 0)) (cond ((= (idx t 1) 'const) (array #x00)) - ((= (idx t 1) 'mut) (array #x01)) - (true (error (str "bad mutablity " (idx t 1)))))))) - (encode_global_section (lambda (global_section) - (dlet ( - ;(_ (print "encoding exprs " global_section)) - (encoded (encode_vector (lambda (x) (concat (encode_global_type (idx x 0)) (encode_expr (idx x 1)))) global_section)) - ) (concat (array #x06) (encode_LEB128 (len encoded)) encoded )) - )) - - ; only supporting one type of element section for now, active funcrefs with offset - (encode_element (lambda (x) (concat (array #x00) (encode_expr (idx x 0)) (encode_vector encode_LEB128 (idx x 1))))) - (encode_element_section (lambda (x) - (dlet ( - ;(_ (print "encoding element " x)) - (encoded (encode_vector encode_element x)) - ;(_ (print "donex")) - ) (concat (array #x09) (encode_LEB128 (len encoded)) encoded )) - )) - - - (encode_data (lambda (data) (cond ((= 2 (len data)) (concat (array #x00) (encode_expr (idx data 0)) (encode_bytes (idx data 1)))) - ((= 1 (len data)) (concat (array #x01) (encode_bytes (idx data 0)))) - ((= 3 (len data)) (concat (array #x02) (encode_LEB128 (idx data 0)) (encode_expr (idx data 1)) (encode_bytes (idx data 2)))) - (true (error (str "bad data" data)))))) - (encode_data_section (lambda (x) - (dlet ( - (encoded (encode_vector encode_data x)) - ) (concat (array #x0B) (encode_LEB128 (len encoded)) encoded )) - )) - - - (wasm_to_binary (lambda (wasm_code) - (dlet ( - ((type_section import_section function_section table_section memory_section global_section export_section start_section element_section code_section data_section) wasm_code) - ;(_ (println "type_section" type_section "import_section" import_section "function_section" function_section "memory_section" memory_section "global_section" global_section "export_section" export_section "start_section" start_section "element_section" element_section "code_section" code_section "data_section" data_section)) - (magic (array #x00 #x61 #x73 #x6D )) - (version (array #x01 #x00 #x00 #x00 )) - (type (encode_type_section type_section)) - (import (encode_import_section import_section)) - (function (encode_function_section function_section)) - (table (encode_table_section table_section)) - (memory (encode_memory_section memory_section)) - (global (encode_global_section global_section)) - (export (encode_export_section export_section)) - (start (encode_start_section start_section)) - (elem (encode_element_section element_section)) - (code (encode_code_section code_section)) - (data (encode_data_section data_section)) - ;data_count (dlet (body (encode_LEB128 (len data_section))) (concat (array #x0C) (encode_LEB128 (len body)) body)) - (data_count (array)) - ) (concat magic version type import function table memory global export data_count start elem code data)) - )) - - (module (lambda args (dlet ( - (helper (rec-lambda recurse (entries i name_dict type import function table memory global export start elem code data) - (if (= i (len entries)) (array type import function table memory global export start elem code data) - (dlet ( - ((n_d t im f ta m g e s elm c d) ((idx entries i) name_dict type import function table memory global export start elem code data)) - ) (recurse entries (+ i 1) n_d t im f ta m g e s elm c d))))) - ) (helper (apply concat args) 0 empty_dict (array ) (array ) (array ) (array ) (array ) (array ) (array ) (array ) (array ) (array ) (array ))))) - - (table (lambda (idx_name . limits_type) (array (lambda (name_dict type import function table memory global export start elem code data) - (array (put name_dict idx_name (len table)) type import function (concat table (array (array (idx limits_type -1) (slice limits_type 0 -2) ))) memory global export start elem code data ))))) - - (memory (lambda (idx_name . limits) (array (lambda (name_dict type import function table memory global export start elem code data) - (array (put name_dict idx_name (len memory)) type import function table (concat memory (array limits)) global export start elem code data ))))) - - (func (lambda (name . inside) (array (lambda (name_dict type import function table memory global export start elem code data) - (dlet ( - ;(_ (print "ok, doing a func: " name " with inside " inside)) - ((params result locals body) ((rec-lambda recurse (i pe re) - (cond ((and (= false pe) (< i (len inside)) (array? (idx inside i)) (< 0 (len (idx inside i))) (= 'param (idx (idx inside i) 0))) - (recurse (+ i 1) pe re)) - ((and (= false pe) (= false re) (< i (len inside)) (array? (idx inside i)) (< 0 (len (idx inside i))) (= 'result (idx (idx inside i) 0))) - ; only one result possible - (recurse (+ i 1) i (+ i 1))) - ((and (= false re) (< i (len inside)) (array? (idx inside i)) (< 0 (len (idx inside i))) (= 'result (idx (idx inside i) 0))) - ; only one result possible - (recurse (+ i 1) pe (+ i 1))) - ((and (< i (len inside)) (array? (idx inside i)) (< 0 (len (idx inside i))) (= 'local (idx (idx inside i) 0))) - (recurse (+ i 1) (or pe i) (or re i))) - (true (array (slice inside 0 (or pe i)) (slice inside (or pe i) (or re pe i)) (slice inside (or re pe i) i) (slice inside i -1))) - ) - ) 0 false false)) - (result (if (!= 0 (len result)) (array (idx (idx result 0) 1)) - result)) - ;(_ (println "params " params " result " result " locals " locals " body " body)) - (outer_name_dict (put name_dict name (len function))) - ((num_params inner_name_dict) (foldl (lambda (a x) (array (+ (idx a 0) 1) (put (idx a 1) (idx x 1) (idx a 0)))) (array 0 outer_name_dict ) params)) - ((num_locals inner_name_dict) (foldl (lambda (a x) (array (+ (idx a 0) 1) (put (idx a 1) (idx x 1) (idx a 0)))) (array num_params inner_name_dict ) locals)) - ;(_ (println "inner name dict" inner_name_dict)) - (compressed_locals ((rec-lambda recurse (cur_list cur_typ cur_num i) - (cond ((and (= i (len locals)) (= 0 cur_num)) cur_list) - ((= i (len locals)) (concat cur_list (array (array cur_num cur_typ) ))) - ((= cur_typ (idx (idx locals i) 2)) (recurse cur_list cur_typ (+ 1 cur_num) (+ 1 i))) - ((= nil cur_typ) (recurse cur_list (idx (idx locals i) 2) 1 (+ 1 i))) - (true (recurse (concat cur_list (array (array cur_num cur_typ))) (idx (idx locals i) 2) 1 (+ 1 i)))) - ) (array) nil 0 0)) - ;(_ (println "params: " params " result: " result)) - (our_type (array (map (lambda (x) (idx x 2)) params) result)) - ;(inner_env (add-dict-to-env de (put inner_name_dict 'depth 0))) - (inner_name_dict_with_depth (put inner_name_dict 'depth 0)) - ;(_ (println "about to get our_code: " body)) - (our_code (flat_map (lambda (inss) (map (lambda (ins) (ins inner_name_dict_with_depth)) inss)) - body)) - ;(_ (println "resulting code " our_code)) - (final_code (concat code (array (array compressed_locals our_code ) ))) - ) (array - outer_name_dict - ; type - (concat type (array our_type )) - ; import - import - ; function - (concat function (array (len function) )) - ; table - table - ; memory - memory - ; global - global - ; export - export - ; start - start - ; element - elem - ; code - final_code - ; data - data - )) - )))) - - - ;;;;;;;;;;;;;;; - ; Instructions - ;;;;;;;;;;;;;;; - (unreachable (lambda () (array (lambda (name_dict) (array 'unreachable))))) - (_drop (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'drop)))))) - (i32.const (lambda (const) (array (lambda (name_dict) (array 'i32.const const))))) - (i64.const (lambda (const) (array (lambda (name_dict) (array 'i64.const const))))) - (local.get (lambda (const) (array (lambda (name_dict) (array 'local.get (if (int? const) const (get-value name_dict const))))))) - (local.set (lambda (const . flatten) (concat (apply concat flatten) (array (lambda (name_dict) (array 'local.set (if (int? const) const (get-value name_dict const)))))))) - (local.tee (lambda (const . flatten) (concat (apply concat flatten) (array (lambda (name_dict) (array 'local.tee (if (int? const) const (get-value name_dict const)))))))) - (global.get (lambda (const) (array (lambda (name_dict) (array 'global.get (if (int? const) const (get-value name_dict const))))))) - (global.set (lambda (const . flatten) (concat (apply concat flatten) (array (lambda (name_dict) (array 'global.set (if (int? const) const (get-value name_dict const)))))))) - (i32.add (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'i32.add)))))) - (i32.sub (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'i32.sub)))))) - (i32.mul (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'i32.mul)))))) - (i32.div_s (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'i32.div_s)))))) - (i32.div_u (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'i32.div_u)))))) - (i32.rem_s (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'i32.rem_s)))))) - (i32.rem_u (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'i32.rem_u)))))) - (i32.and (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'i32.and)))))) - (i32.or (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'i32.or)))))) - (i64.add (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'i64.add)))))) - (i64.sub (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'i64.sub)))))) - (i64.mul (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'i64.mul)))))) - (i64.div_s (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'i64.div_s)))))) - (i64.div_u (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'i64.div_u)))))) - (i64.rem_s (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'i64.rem_s)))))) - (i64.rem_u (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'i64.rem_u)))))) - (i64.and (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'i64.and)))))) - (i64.or (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'i64.or)))))) - (i64.xor (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'i64.xor)))))) - - (i32.eqz (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'i32.eqz)))))) - (i32.eq (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'i32.eq)))))) - (i32.ne (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'i32.ne)))))) - (i32.lt_s (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'i32.lt_s)))))) - (i32.lt_u (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'i32.lt_u)))))) - (i32.gt_s (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'i32.gt_s)))))) - (i32.gt_u (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'i32.gt_u)))))) - (i32.le_s (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'i32.le_s)))))) - (i32.le_u (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'i32.le_u)))))) - (i32.ge_s (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'i32.ge_s)))))) - (i32.ge_u (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'i32.ge_u)))))) - (i64.eqz (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'i64.eqz)))))) - (i64.eq (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'i64.eq)))))) - (i64.ne (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'i64.ne)))))) - (i64.lt_s (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'i64.lt_s)))))) - (i64.lt_u (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'i64.lt_u)))))) - (i64.gt_s (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'i64.gt_s)))))) - (i64.gt_u (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'i64.gt_u)))))) - (i64.le_s (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'i64.le_s)))))) - (i64.le_u (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'i64.le_u)))))) - (i64.ge_s (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'i64.ge_s)))))) - (i64.ge_u (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'i64.ge_u)))))) - - (mem_load (lambda (op align) (lambda flatten (dlet ( - (explicit_offset (int? (idx flatten 0))) - (offset (if explicit_offset (idx flatten 0) 0)) - (flatten_rest (if explicit_offset (slice flatten 1 -1) flatten)) - ) (concat (apply concat flatten_rest) (array (lambda (name_dict) (array op align offset)))))))) - - (i32.load (mem_load 'i32.load 2)) - (i64.load (mem_load 'i64.load 3)) - (i32.store (mem_load 'i32.store 2)) - (i64.store (mem_load 'i64.store 3)) - (i32.store8 (mem_load 'i32.store8 0)) - (i32.store16 (mem_load 'i32.store16 1)) - (i64.store8 (mem_load 'i64.store8 0)) - (i64.store16 (mem_load 'i64.store16 1)) - - (i32.load8_s (mem_load 'i32.load8_s 0)) - (i32.load8_u (mem_load 'i32.load8_u 0)) - (i32.load16_s (mem_load 'i32.load16_s 1)) - (i32.load16_u (mem_load 'i32.load16_u 1)) - (i64.load8_s (mem_load 'i64.load8_s 0)) - (i64.load8_u (mem_load 'i64.load8_u 0)) - (i64.load16_s (mem_load 'i64.load16_s 1)) - (i64.load16_u (mem_load 'i64.load16_u 1)) - (i64.load32_s (mem_load 'i64.load32_s 2)) - (i64.load32_u (mem_load 'i64.load32_u 2)) - - (memory.grow (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'memory.grow)))))) - (i32.shl (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'i32.shl)))))) - (i32.shr_u (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'i32.shr_u)))))) - (i64.shl (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'i64.shl)))))) - (i64.shr_s (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'i64.shr_s)))))) - (i64.shr_u (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'i64.shr_u)))))) - - (i32.wrap_i64 (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'i32.wrap_i64)))))) - (i64.extend_i32_s (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'i64.extend_i32_s)))))) - (i64.extend_i32_u (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'i64.extend_i32_u)))))) - - (memory.copy (lambda flatten (concat (apply concat flatten) (array (lambda (name_dict) (array 'memory.copy)))))) - - (block_like_body (lambda (name_dict name inner) (dlet ( - (new_depth (+ 1 (get-value name_dict 'depth))) - (inner_env (put (put name_dict name new_depth) 'depth new_depth)) - ) (flat_map (lambda (inss) (map (lambda (ins) (ins inner_env)) inss)) inner)))) - - - (block (lambda (name . inner) (array (lambda (name_dict) (array 'block (array) (block_like_body name_dict name inner)))))) - (_loop (lambda (name . inner) (array (lambda (name_dict) (array 'loop (array) (block_like_body name_dict name inner)))))) - (_if (lambda (name . inner) (dlet ( - ((end_idx else_section) (if (= 'else (idx (idx inner -1) 0)) (array -2 (slice (idx inner -1) 1 -1) ) - (array -1 nil ))) - ((end_idx then_section) (if (= 'then (idx (idx inner end_idx) 0)) (array (- end_idx 1) (slice (idx inner end_idx) 1 -1) ) - (array (- end_idx 1) (array (idx inner end_idx) ) ))) - ((start_idx result_t) (if (= 'result (idx (idx inner 0) 0)) (array 1 (idx (idx inner 0) 1)) - (array 0 (array)))) - (flattened (apply concat (slice inner start_idx end_idx))) - ;(_ (println "result_t " result_t " flattened " flattened " then_section " then_section " else_section " else_section)) - ) (concat flattened (array (lambda (name_dict) (concat ;(dlet ( (_ (true_print "inner if " name " " inner)) ) (array)) - (array 'if result_t (block_like_body name_dict name then_section)) - (if (!= nil else_section) (array (block_like_body name_dict name else_section)) - (array))))))))) - - (then (lambda rest (cons 'then rest))) - (else (lambda rest (cons 'else rest))) - - (br (lambda (block) (array (lambda (name_dict) (array 'br (if (int? block) block (- (get-value name_dict 'depth) (get-value name_dict block)))))))) - (br_if (lambda (block . flatten) (concat (apply concat flatten) (array (lambda (name_dict) (array 'br_if (if (int? block) block (- (get-value name_dict 'depth) (get-value name_dict block))))))))) - (call (lambda (f . flatten) (concat (apply concat flatten) (array (lambda (name_dict) (array 'call (if (int? f) f (get-value name_dict f)))))))) - (call_indirect (lambda (type_idx table_idx . flatten) (concat (apply concat flatten) (array (lambda (name_dict) (array 'call_indirect type_idx table_idx)))))) - - ;;;;;;;;;;;;;;;;;;; - ; End Instructions - ;;;;;;;;;;;;;;;;;;; - - (import (lambda (mod_name name t_idx_typ) (array (lambda (name_dict type import function table memory global export start elem code data) (dlet ( - (_ (if (!= 'func (idx t_idx_typ 0)) (error "only supporting importing functions rn"))) - ((import_type idx_name param_type result_type) t_idx_typ) - (actual_type_idx (len type)) - (actual_type (array (slice param_type 1 -1) (slice result_type 1 -1) )) - ) - (array (put name_dict idx_name (len function)) (concat type (array actual_type)) (concat import (array (array mod_name name import_type actual_type_idx) )) (concat function (array nil)) table memory global export start elem code data )) - )))) - - (global (lambda (idx_name global_type expr) (array (lambda (name_dict type import function table memory global export start elem code data) - (array (put name_dict idx_name (len global)) - type import function table memory - (concat global (array (array (if (array? global_type) (reverse global_type) (array global_type 'const)) (map (lambda (x) (x empty_dict)) expr) ))) - export start elem code data ) - )))) - - (export (lambda (name t_v) (array (lambda (name_dict type import function table memory global export start elem code data) - (array name_dict type import function table memory global - (concat export (array (array name (idx t_v 0) (get-value name_dict (idx t_v 1)) ) )) - start elem code data ) - )))) - - (start (lambda (name) (array (lambda (name_dict type import function table memory global export start elem code data) - (array name_dict type import function table memory global export (concat start (array (get-value name_dict name))) elem code data ) - )))) - - (elem (lambda (offset . entries) (array (lambda (name_dict type import function table memory global export start elem code data) - (array name_dict type import function table memory global export start (concat elem (array (array (map (lambda (x) (x empty_dict)) offset) (map (lambda (x) (if (int? x) x (get-value name_dict x))) entries)))) code data ) - )))) - - (data (lambda it (array (lambda (name_dict type import function table memory global export start elem code data) - (array name_dict type import function table memory global export start elem code - (concat data (array (map (lambda (x) (if (array? x) (map (lambda (y) (y empty_dict)) x) x)) it)))))))) - - - ; Everything is an i64, and we're on a 32 bit wasm system, so we have a good many bits to play with - - ; The two interesting splits are ref-counted/vs not and changes on eval / vs not - ; ref counted is much more important - - ; y is constant bit - ; - all pointers in identical spots - ; - all pointers full 32 bits for easy inlining of - ; refcounting ops (with static -8 offset) - ; - all sizes in identical spots - ; - vals vs not vals split on first bit - ; Int - should maximize int xx0000 (nicely leaves 1000 for BigInt later) - ; False 00100 - ; True 10100 - ; y010 - ; 0011 - ; y111 - symbols 1 bit diff from array for value checking - ; |y101 - both env-carrying values 1 bit different - ; <28 0s> y001 - - ; NOTE / TODO: - ; reduce sizes to 16 bits w/ saturation & include true size field/calculation in object header - ; to allow for 44 bit pointers for wasm64 (48 that could be used + minimum alignment of 16) - ; Biggest loser is func_idx which would become 14 bits, but can perhaps borrow from env pointer if we further align envs - ; currently aligning to 32 bytes, which is 8 word boundries or 4 kraken values (which I think is exactly what env requires, actually) - ; which allows pretty long strings or envs or arrays with 3 values - ; so that's 5 unused bits, to actually only require 43 bit pointers right now, I think - ; Honestly, going to 40 bits is 1024GB of RAM, -5 is 35 bits. If we allow a non-standard encoding for env-funcs, then - ; it leaves 23 bits for a function id, which is 8_388_608 possible functions, which isn't really terrible. - ; We could do this only for env-funcs, or actually for anything depending on the extra slow down vs the extra non-saturating size - ; Note that this does add an extra mask instruction for *everything* since the pointers aren't full width anymore - - (to_hex_digit (lambda (x) (string (integer->char (if (< x 10) (+ x #x30) - (+ x #x37)))))) - (le_hexify_helper (rec-lambda recurse (x i) (if (= i 0) "" - (concat "\\" (to_hex_digit (remainder (quotient x 16) 16)) - (to_hex_digit (remainder x 16)) - (recurse (quotient x 256) (- i 1)))))) - (i64_le_hexify (lambda (x) (le_hexify_helper (bitwise-and x #xFFFFFFFFFFFFFFFF) 8))) - (i32_le_hexify (lambda (x) (le_hexify_helper (bitwise-and x #xFFFFFFFF) 4))) - - (type_mask #b111) - (rc_mask #b1000) - (wrap_mask #b10000) - - (int_tag #b000) - (bool_tag #b100) - (string_tag #b010) - (symbol_tag #b011) - (array_tag #b111) - (env_tag #b001) - (comb_tag #b101) - - (int_mask -16) - - ; catching only 0array and false - ; -12 is #b1111...110100 - ; the 0 for y means don't care about rc - ; the 100 means env, array, or bool - ; and the rest 0 can only mean null env (not possible), nil, or false - (truthy_test (lambda (x) (i64.ne (i64.const #b100) (i64.and x (i64.const -12))))) - (falsey_test (lambda (x) (i64.eq (i64.const #b100) (i64.and x (i64.const -12))))) - - (value_test (lambda (x) (i64.ne (i64.const #b011) (i64.and x (i64.const #b011))))) - - (mk_int_value (lambda (x) (<< x 4))) - (mk_symbol_value (lambda (ptr len) (bor (<< ptr 32) (<< len 4) symbol_tag))) - (mk_string_value (lambda (ptr len) (bor (<< ptr 32) (<< len 4) string_tag))) - (mk_env_value (lambda (ptr) (bor (<< ptr 32) env_tag))) - - (mk_int_code_i64 (lambda (x) (i64.shl x (i64.const 4)))) - (mk_int_code_i32u (lambda (x) (i64.shl (i64.extend_i32_u x) (i64.const 4)))) - (mk_int_code_i32s (lambda (x) (i64.shl (i64.extend_i32_s x) (i64.const 4)))) - - (mk_env_code_rc (lambda (ptr) (i64.or (i64.shl (i64.extend_i32_u ptr) (i64.const 32)) - (i64.const (bor rc_mask env_tag))))) - (mk_array_value (lambda (len ptr) (bor (<< ptr 32) (<< len 4) array_tag))) - (mk_array_code_rc_const_len (lambda (len ptr) (i64.or (i64.shl (i64.extend_i32_u ptr) (i64.const 32)) - (i64.const (bor (<< len 4) rc_mask array_tag))))) - (mk_array_code_rc (lambda (len ptr) (i64.or (i64.or (i64.shl (i64.extend_i32_u ptr) (i64.const 32)) - (i64.const (bor rc_mask array_tag))) - (i64.shl (i64.extend_i32_u len) (i64.const 4))))) - (mk_string_code_rc (lambda (len ptr) (i64.or (i64.or (i64.shl (i64.extend_i32_u ptr) (i64.const 32)) - (i64.const (bor rc_mask string_tag))) - (i64.shl (i64.extend_i32_u len) (i64.const 4))))) - (toggle_sym_str_code (lambda (x) (i64.xor (i64.const #b001) x))) - (toggle_sym_str_code_norc (lambda (x) (i64.and (i64.const -9) (i64.xor (i64.const #b001) x)))) - - (mk_comb_val_nil_env (lambda (fidx uses_de wrap) (bor (<< fidx 6) (<< uses_de 5) (<< wrap 4) comb_tag))) - (mk_comb_val_code_rc_wrap0 (lambda (fidx env uses_de) - (i64.or (i64.and env (i64.const -8)) - (i64.or (i64.const (<< fidx 6)) - (_if '$using_d_env '(result i64) - uses_de - (then (i64.const (bor #b100000 comb_tag))) - (else (i64.const (bor #b000000 comb_tag)))))))) - (combine_env_comb_val (lambda (env_val func_val) (bor (band -8 env_val) func_val))) - (combine_env_code_comb_val_code (lambda (env_code func_val) (i64.or (i64.and env_code (i64.const -8)) (i64.const func_val)))) - - (mod_fval_to_wrap (lambda (it) (cond ((= nil it) it) - ((and (= (band it type_mask) comb_tag) (= #b0 (band (>> it 6) #b1))) (- it (<< 1 6))) - (true it)))) - (extract_unwrapped (lambda (x) (= #b0 (band #b1 (>> x 6))))) - (extract_func_idx (lambda (x) (band #x3FFFFFF (>> x 6)))) - (extract_func_wrap (lambda (x) (band #b1 (>> x 4)))) - (extract_func_usesde (lambda (x) (= #b1 (band #b1 (>> x 5))))) - - - (set_wrap_val (lambda (level func) (bor (<< level 4) (band func -17)))) - - (extract_func_idx_code (lambda (x) (i32.and (i32.const #x3FFFFFF) (i32.wrap_i64 (i64.shr_u x (i64.const 6)))))) - ; mask away all but - ; env ptr and rc-bit - (extract_func_env (lambda (x) (bor env_tag (band (- #xFFFFFFF8) x)))) - (extract_func_env_code (lambda (x) (i64.or (i64.const env_tag) (i64.and (i64.const (- #xFFFFFFF8)) x)))) - (extract_wrap_code (lambda (x) (i64.and (i64.const #b1) (i64.shr_u x (i64.const 4))))) - (set_wrap_code (lambda (level func) (i64.or (i64.shl level (i64.const 4)) (i64.and func (i64.const -17))))) - (is_wrap_code (lambda (level func) (i64.eq (i64.const (<< level 4)) (i64.and func (i64.const #b10000))))) - (needes_de_code (lambda (func) (i64.ne (i64.const 0) (i64.and func (i64.const #b100000))))) - (extract_usede_code (lambda (x) (i32.and (i32.const #b1) (i32.wrap_i64 (i64.shr_u x (i64.const 5)))))) - (extract_int_code (lambda (x) (i64.shr_s x (i64.const 4)))) - (extract_int_code_i32 (lambda (x) (i32.wrap_i64 (extract_int_code x)))) - (extract_ptr_code (lambda (bytes) (i32.wrap_i64 (i64.shr_u bytes (i64.const 32))))) - (extract_size_code (lambda (bytes) (i32.wrap_i64 (i64.and (i64.const #xFFFFFFF) (i64.shr_u bytes (i64.const 4)))))) - (extract_size_code_to_int (lambda (bytes) (i64.and (i64.const #xFFFFFFF0) bytes))) - - - (is_type_code (lambda (tag x) (i64.eq (i64.const tag) (i64.and (i64.const type_mask) x)))) - (is_not_type_code (lambda (tag x) (i64.ne (i64.const tag) (i64.and (i64.const type_mask) x)))) - (is_str_or_sym_code (lambda (x) (i64.eq (i64.const #b010) (i64.and (i64.const #b110) x)))) - - (true_val #b00010100) - (false_val #b00000100) - (empty_parse_value #b00100100) - (close_peren_value #b01000100) - (error_parse_value #b01100100) - (nil_val array_tag) ; automatically 0 ptr, 0 size, 0 ref-counted - (emptystr_val string_tag); ^ ditto - - (compile (dlambda ((pectx partial_eval_err marked_code) dont_partial_eval - dont_lazy_env - dont_y_comb - dont_prim_inline - dont_closure_inline) - (mif partial_eval_err (error partial_eval_err) (wasm_to_binary (module - (import "wasi_unstable" "args_sizes_get" - '(func $args_sizes_get (param i32 i32) - (result i32))) - (import "wasi_unstable" "args_get" - '(func $args_get (param 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" "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))) - (global '$malloc_head '(mut i32) (i32.const 0)) - (global '$phs '(mut i32) (i32.const 0)) - (global '$phl '(mut i32) (i32.const 0)) - - (global '$stack_trace '(mut i64) (i64.const nil_val)) - (global '$debug_depth '(mut i32) (i32.const -1)) - (global '$debug_func_to_call '(mut i64) (i64.const nil_val)) - (global '$debug_params_to_call '(mut i64) (i64.const nil_val)) - (global '$debug_env_to_call '(mut i64) (i64.const nil_val)) - - (global '$num_mallocs '(mut i32) (i32.const 0)) - (global '$num_sbrks '(mut i32) (i32.const 0)) - (global '$num_frees '(mut i32) (i32.const 0)) - - (global '$num_evals '(mut i32) (i32.const 0)) - (global '$num_all_evals '(mut i32) (i32.const 0)) - (global '$num_interp_dzero '(mut i32) (i32.const 0)) - (global '$num_interp_done '(mut i32) (i32.const 0)) - (global '$num_compiled_dzero '(mut i32) (i32.const 0)) - (global '$num_compiled_done '(mut i32) (i32.const 0)) - - (global '$num_array_innerdrops '(mut i32) (i32.const 0)) - (global '$num_env_innerdrops '(mut i32) (i32.const 0)) - (global '$num_array_subdrops '(mut i32) (i32.const 0)) - (global '$num_array_maxsubdrops '(mut i32) (i32.const 0)) - - (global '$num_interned_symbols '(mut i32) (i32.const 0)) - - (dlet ( - (_ (true_print "beginning of dlet")) - (alloc_data (dlambda (d (watermark datas)) (cond ((str? d) (dlet ((size (+ 8 (band (len d) -8)))) - (array (+ watermark 8) - (len d) - (array (+ watermark 8 size) - (concat datas - (data (i32.const watermark) - (concat (i32_le_hexify size) "\\00\\00\\00\\80" d))))))) - (true (error (str "can't alloc_data for anything else besides strings yet" d))) - ) - )) - (memo empty_dict) - ; We won't use 0 because some impls seem to consider that NULL and crash on reading/writing? - (iov_tmp 8) ; <32bit len><32bit ptr> + <32bit numwitten> - (datasi (array (+ iov_tmp 16) (array))) - - (compile-symbol-val (lambda (datasi memo sym) (dlet ((marked_sym (marked_symbol nil sym)) - (maybe_done (get-value-or-false memo marked_sym)) - ) (if maybe_done (array datasi memo maybe_done) - (dlet (((c_loc c_len datasi) (alloc_data (get-text sym) datasi)) - (sym_val (mk_symbol_value c_loc c_len)) - (memo (put memo marked_sym sym_val))) - (array datasi memo sym_val)))))) - - (compile-string-val (lambda (datasi memo s) (dlet ((marked_string (marked_val s)) - (maybe_done (get-value-or-false memo marked_string)) - ) (if maybe_done (array datasi memo maybe_done) - (dlet (((c_loc c_len datasi) (alloc_data s datasi)) - (str_val (mk_string_value c_loc c_len)) - (memo (put memo marked_string str_val))) - (array datasi memo str_val)))))) - - ((true_loc true_length datasi) (alloc_data "true" datasi)) - ((false_loc false_length datasi) (alloc_data "false" datasi)) - - (_ (true_print "made true/false")) - - ((datasi memo bad_source_code_msg_val) (compile-string-val datasi memo "\nError: bad source code compile hit\n")) - ((datasi memo bad_params_number_msg_val) (compile-string-val datasi memo "\nError: passed a bad number of parameters\n")) - ((datasi memo bad_params_type_msg_val) (compile-string-val datasi memo "\nError: passed a bad type of parameters\n")) - ((datasi memo dropping_msg_val) (compile-string-val datasi memo "dropping ")) - ((datasi memo duping_msg_val) (compile-string-val datasi memo "duping ")) - ((datasi memo error_msg_val) (compile-string-val datasi memo "\nError: ")) - ((datasi memo log_msg_val) (compile-string-val datasi memo "\nLog: ")) - ((datasi memo call_ok_msg_val) (compile-string-val datasi memo "call ok!")) - ((datasi memo newline_msg_val) (compile-string-val datasi memo "\n")) - ((datasi memo space_msg_val) (compile-string-val datasi memo " ")) - ((datasi memo remaining_eval_msg_val) (compile-string-val datasi memo "\nError: trying to call remainin eval\n")) - ((datasi memo hit_upper_in_eval_msg_val) (compile-string-val datasi memo "\nError: hit nil upper env when looking up symbol in remaining eval: ")) - ((datasi memo remaining_vau_msg_val) (compile-string-val datasi memo "\nError: trying to call remainin vau (primitive)\n")) - ((datasi memo no_true_cond_msg_val) (compile-string-val datasi memo "\nError: runtime cond had no true branch\n")) - ((datasi memo weird_wrap_msg_val) (compile-string-val datasi memo "\nError: trying to call a combiner with a weird wrap (not 0 or 1)\n")) - ((datasi memo bad_not_vau_msg_val) (compile-string-val datasi memo "\nError: Trying to call a function (not vau) but the parameters caused a compile error\n")) - ((datasi memo going_up_msg_val) (compile-string-val datasi memo "going up")) - ((datasi memo starting_from_msg_val) (compile-string-val datasi memo "starting from ")) - ((datasi memo got_it_msg_val) (compile-string-val datasi memo "got it")) - ((datasi memo couldnt_parse_1_msg_val) (compile-string-val datasi memo "\nError: Couldn't parse:\n")) - ((datasi memo couldnt_parse_2_msg_val) (compile-string-val datasi memo "\nAt character:\n")) - ((datasi memo parse_remaining_msg_val) (compile-string-val datasi memo "\nLeft over after parsing, starting at byte offset:\n")) - ((datasi memo quote_sym_val) (compile-symbol-val datasi memo 'quote)) - ((datasi memo unquote_sym_val) (compile-symbol-val datasi memo 'unquote)) - - ((datasi memo pre_read_val) (compile-string-val datasi memo "\nPreRead\n")) - ((datasi memo post_read_val) (compile-string-val datasi memo "\nPostRead\n")) - ((datasi memo pre_parse_val) (compile-string-val datasi memo "\nPreParse\n")) - ((datasi memo post_parse_val) (compile-string-val datasi memo "\nPostParse\n")) - ((datasi memo pre_symbol_intern_val) (compile-string-val datasi memo "\npre symbol intern\n")) - ((datasi memo pre_eval_val) (compile-string-val datasi memo "\npre eval\n")) - ((datasi memo post_eval_val) (compile-string-val datasi memo "\npost eval\n")) - ((datasi memo pre_inner_eval_val) (compile-string-val datasi memo "\n inner pre eval\n")) - ((datasi memo post_inner_eval_val) (compile-string-val datasi memo "\n inner post eval\n")) - ((datasi memo pre_write_callback) (compile-string-val datasi memo "\n pre write callback\n")) - - (_ (true_print "made string/symbol-vals")) - - ; 0 is get_argc, 1 is get_args, 2 is path_open, 3 is fd_read, 4 is fd_write - (num_pre_functions 5) - ((func_idx funcs) (array num_pre_functions (array))) - - (typecheck (dlambda (idx result_type op type_tag then_branch else_branch) - (apply _if (concat (array '$matches) result_type - (array (op (i64.const type_tag) (i64.and (i64.const type_mask) (i64.load (* 8 idx) (local.get '$ptr))))) - then_branch - else_branch - )) - )) - - (type_assert (rec-lambda type_assert (i type_check name_msg_val) - (typecheck i (array) - i64.ne (if (array? type_check) (idx type_check 0) type_check) - (array (then - (if (and (array? type_check) (> (len type_check) 1)) - (type_assert i (slice type_check 1 -1) name_msg_val) - (concat - (call '$print (i64.const bad_params_type_msg_val)) - (call '$print (i64.const (mk_int_value i))) - (call '$print (i64.const space_msg_val)) - (call '$print (i64.const name_msg_val)) - (call '$print (i64.const space_msg_val)) - (call '$print (i64.load (* 8 i) (local.get '$ptr))) - (unreachable) - ) - ) - )) - nil - ) - )) - - ;(generate_dup (lambda (it) (call '$dup it))) - (generate_dup (lambda (it) (concat - (_if '$is_rc - (i64.ne (i64.const 0) (i64.and (i64.const rc_mask) (local.tee '$rc_bytes it))) - (then - (local.set '$rc_ptr (i32.sub (extract_ptr_code (local.get '$rc_bytes)) (i32.const 4))) - (i32.store (local.get '$rc_ptr) (i32.add (i32.load (local.get '$rc_ptr)) (i32.const 1))) - ) - ) - (local.get '$rc_bytes) - ))) - ;(generate_drop (lambda (it) (call '$drop it))) - (generate_drop (lambda (it) (concat - (_if '$is_rc - (i64.ne (i64.const 0) (i64.and (i64.const rc_mask) (local.tee '$rc_bytes it))) - (then - (_if '$zero - (i32.eqz (local.tee '$rc_tmp (i32.sub (i32.load (local.tee '$rc_ptr (i32.sub (extract_ptr_code (local.get '$rc_bytes)) (i32.const 4)))) (i32.const 1)))) - (then - (call '$drop_free (local.get '$rc_bytes)) - ) - (else (i32.store (local.get '$rc_ptr) (local.get '$rc_tmp))) - ) - ) - ) - ))) - - (_ (true_print "made typecheck/assert")) - - ; malloc allocates with size and refcount in header - ((k_malloc func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$malloc '(param $bytes i32) '(result i32) '(local $result i32) '(local $ptr i32) '(local $last i32) '(local $pages i32) - (global.set '$num_mallocs (i32.add (i32.const 1) (global.get '$num_mallocs))) - - (local.set '$bytes (i32.add (i32.const 8) (local.get '$bytes))) - ; ROUND AND ALIGN to 8 byte boundries (1 word) NOT ALLOWED - we expect 16 byte boundries, seemingly? - ; (though it doesn't seem like it from the ptr encoding :/) It crashes if only 8... - ;(local.set '$bytes (i32.and (i32.const -16) (i32.add (i32.const 15) (local.get '$bytes)))) - ; or heck, to 4 word boundries - ;(local.set '$bytes (i32.and (i32.const -32) (i32.add (i32.const 31) (local.get '$bytes)))) - ; or 8 word boundries! - (local.set '$bytes (i32.and (i32.const -64) (i32.add (i32.const 63) (local.get '$bytes)))) - - (local.set '$result (i32.const 0)) - (_if '$has_head - (i32.ne (i32.const 0) (global.get '$malloc_head)) - (then - (local.set '$ptr (global.get '$malloc_head)) - (local.set '$last (i32.const 0)) - (_loop '$l - (_if '$fits - (i32.ge_u (i32.load 0 (local.get '$ptr)) (local.get '$bytes)) - (then - (local.set '$result (local.get '$ptr)) - (_if '$head - (i32.eq (local.get '$result) (global.get '$malloc_head)) - (then - (global.set '$malloc_head (i32.load 4 (global.get '$malloc_head))) - ) - (else - (i32.store 4 (local.get '$last) (i32.load 4 (local.get '$result))) - ) - ) - ) - (else - (local.set '$last (local.get '$ptr)) - (local.set '$ptr (i32.load 4 (local.get '$ptr))) - (br_if '$l (i32.ne (i32.const 0) (local.get '$ptr))) - ) - ) - ) - ) - ) - (_if '$result_0 - (i32.eqz (local.get '$result)) - (then - (global.set '$num_sbrks (i32.add (i32.const 1) (global.get '$num_sbrks))) - (local.set '$pages (i32.add (i32.const 1) (i32.shr_u (local.get '$bytes) (i32.const 16)))) - (local.set '$result (i32.shl (memory.grow (local.get '$pages)) (i32.const 16))) - (i32.store 0 (local.get '$result) (i32.shl (local.get '$pages) (i32.const 16))) - ) - ) - ; If too big (>= 2x needed), break off a chunk - (_if '$too_big - (i32.ge_u (i32.load 0 (local.get '$result)) (i32.shl (local.get '$bytes) (i32.const 1))) - (then - (local.set '$ptr (i32.add (local.get '$result) (local.get '$bytes))) - (i32.store 0 (local.get '$ptr) (i32.sub (i32.load 0 (local.get '$result)) (local.get '$bytes))) - (i32.store 4 (local.get '$ptr) (global.get '$malloc_head)) - (global.set '$malloc_head (local.get '$ptr)) - (i32.store 0 (local.get '$result) (local.get '$bytes)) - ) - ) - - (i32.store 4 (local.get '$result) (i32.const 1)) - (i32.add (local.get '$result) (i32.const 8)) - )))) - - (_ (true_print "made malloc")) - - ((k_free func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$free '(param $bytes i32) - (local.set '$bytes (i32.sub (local.get '$bytes) (i32.const 8))) - (global.set '$num_frees (i32.add (i32.const 1) (global.get '$num_frees))) - (_if '$properly_counted - (i32.ne (i32.const 1) (i32.load 4 (local.get '$bytes))) - (then - (unreachable) - ) - ) - (i32.store 4 (local.get '$bytes) (global.get '$malloc_head)) - (global.set '$malloc_head (local.get '$bytes)) - )))) - - ((k_get_ptr func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$get_ptr '(param $bytes i64) '(result i32) - (_if '$isnt_rc '(result i32) - (i64.eqz (i64.and (i64.const rc_mask) (local.get '$bytes))) - (then (i32.const 0)) - (else (extract_ptr_code (local.get '$bytes))) - ) - )))) - - ((k_env_alloc func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$env_alloc '(param $keys i64) '(param $vals i64) '(param $upper i64) '(result i64) '(local $tmp i32) - (local.set '$tmp (call '$malloc (i32.const (* 8 3)))) - (i64.store 0 (local.get '$tmp) (local.get '$keys)) - (i64.store 8 (local.get '$tmp) (local.get '$vals)) - (i64.store 16 (local.get '$tmp) (local.get '$upper)) - (mk_env_code_rc (local.get '$tmp)) - )))) - - ((k_array1_alloc func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$array1_alloc '(param $item i64) '(result i64) '(local $tmp i32) - (local.set '$tmp (call '$malloc (i32.const 8))) - (i64.store 0 (local.get '$tmp) (local.get '$item)) - (mk_array_code_rc_const_len 1 (local.get '$tmp)) - )))) - ((k_array2_alloc func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$array2_alloc '(param $a i64) '(param $b i64) '(result i64) '(local $tmp i32) - (local.set '$tmp (call '$malloc (i32.const 16))) - (i64.store 0 (local.get '$tmp) (local.get '$a)) - (i64.store 8 (local.get '$tmp) (local.get '$b)) - (mk_array_code_rc_const_len 2 (local.get '$tmp)) - )))) - ((k_array3_alloc func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$array3_alloc '(param $a i64) '(param $b i64) '(param $c i64) '(result i64) '(local $tmp i32) - (local.set '$tmp (call '$malloc (i32.const 24))) - (i64.store 0 (local.get '$tmp) (local.get '$a)) - (i64.store 8 (local.get '$tmp) (local.get '$b)) - (i64.store 16 (local.get '$tmp) (local.get '$c)) - (mk_array_code_rc_const_len 3 (local.get '$tmp)) - )))) - ((k_array5_alloc func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$array5_alloc '(param $a i64) '(param $b i64) '(param $c i64) '(param $d i64) '(param $e i64) '(result i64) '(local $tmp i32) - (local.set '$tmp (call '$malloc (i32.const 40))) - (i64.store 0 (local.get '$tmp) (local.get '$a)) - (i64.store 8 (local.get '$tmp) (local.get '$b)) - (i64.store 16 (local.get '$tmp) (local.get '$c)) - (i64.store 24 (local.get '$tmp) (local.get '$d)) - (i64.store 32 (local.get '$tmp) (local.get '$e)) - (mk_array_code_rc_const_len 5 (local.get '$tmp)) - )))) - - (_ (true_print "made array allocs")) - - ; Not called with actual objects, not subject to refcounting - ((k_int_digits func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$int_digits '(param $int i64) '(result i32) '(local $tmp i32) - (_if '$is_neg - (i64.lt_s (local.get '$int) (i64.const 0)) - (then - (local.set '$int (i64.sub (i64.const 0) (local.get '$int))) - (local.set '$tmp (i32.const 2)) - ) - (else - (local.set '$tmp (i32.const 1)) - ) - ) - (block '$b - (_loop '$l - (br_if '$b (i64.le_u (local.get '$int) (i64.const 9))) - (local.set '$tmp (i32.add (i32.const 1) (local.get '$tmp))) - (local.set '$int (i64.div_u (local.get '$int) (i64.const 10))) - (br '$l) - ) - ) - (local.get '$tmp) - )))) - ; Utility method, not subject to refcounting - ((k_str_len func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$str_len '(param $to_str_len i64) '(result i32) '(local $running_len_tmp i32) '(local $i_tmp i32) '(local $x_tmp i32) '(local $y_tmp i32) '(local $ptr_tmp i32) '(local $item i64) - (_if '$is_true '(result i32) - (i64.eq (i64.const true_val) (local.get '$to_str_len)) - (then (i32.const true_length)) - (else - (_if '$is_false '(result i32) - (i64.eq (i64.const false_val) (local.get '$to_str_len)) - (then (i32.const false_length)) - (else - (_if '$is_str_or_symbol '(result i32) - (is_str_or_sym_code (local.get '$to_str_len)) - (then (_if '$is_str '(result i32) - (is_type_code string_tag (local.get '$to_str_len)) - (then (i32.add (i32.const 2) (extract_size_code (local.get '$to_str_len)))) - (else (i32.add (i32.const 1) (extract_size_code (local.get '$to_str_len)))) - )) - (else - (_if '$is_array '(result i32) - (is_type_code array_tag (local.get '$to_str_len)) - (then - (local.set '$running_len_tmp (i32.const 1)) - (local.set '$i_tmp (extract_size_code (local.get '$to_str_len))) - (local.set '$x_tmp (extract_ptr_code (local.get '$to_str_len))) - (block '$b - (_loop '$l - (local.set '$running_len_tmp (i32.add (local.get '$running_len_tmp) (i32.const 1))) - (br_if '$b (i32.eq (local.get '$i_tmp) (i32.const 0))) - (local.set '$running_len_tmp (i32.add (local.get '$running_len_tmp) (call '$str_len (i64.load (local.get '$x_tmp))))) - (local.set '$x_tmp (i32.add (local.get '$x_tmp) (i32.const 8))) - (local.set '$i_tmp (i32.sub (local.get '$i_tmp) (i32.const 1))) - (br '$l) - ) - ) - (local.get '$running_len_tmp) - ) - (else - (_if '$is_env '(result i32) - (is_type_code env_tag (local.get '$to_str_len)) - (then - (local.set '$running_len_tmp (i32.const 0)) - - ; ptr to env - (local.set '$ptr_tmp (extract_ptr_code (local.get '$to_str_len))) - ; ptr to start of array of symbols - (local.set '$x_tmp (extract_ptr_code (i64.load (local.get '$ptr_tmp)))) - ; ptr to start of array of values - (local.set '$y_tmp (extract_ptr_code (i64.load 8 (local.get '$ptr_tmp)))) - ; lenght of both arrays, pulled from array encoding of x - (local.set '$i_tmp (extract_size_code (i64.load (local.get '$ptr_tmp)))) - - (block '$b - (_loop '$l - (local.set '$running_len_tmp (i32.add (local.get '$running_len_tmp) (i32.const 2))) - ; break if 0 length left - (br_if '$b (i32.eq (local.get '$i_tmp) (i32.const 0))) - - (local.set '$running_len_tmp (i32.add (local.get '$running_len_tmp) - (call '$str_len (i64.load (local.get '$x_tmp))))) - (local.set '$running_len_tmp (i32.add (local.get '$running_len_tmp) - (call '$str_len (i64.load (local.get '$y_tmp))))) - (local.set '$running_len_tmp (i32.add (local.get '$running_len_tmp) (i32.const 2))) - - (local.set '$x_tmp (i32.add (local.get '$x_tmp) (i32.const 8))) - (local.set '$y_tmp (i32.add (local.get '$y_tmp) (i32.const 8))) - (local.set '$i_tmp (i32.sub (local.get '$i_tmp) (i32.const 1))) - (br '$l) - ) - ) - ;; deal with upper - (local.set '$item (i64.load 16 (local.get '$ptr_tmp))) - (_if '$is_upper_env - (is_type_code env_tag (local.get '$item)) - (then - (local.set '$running_len_tmp (i32.add (local.get '$running_len_tmp) (i32.const 1))) - (local.set '$running_len_tmp (i32.add (local.get '$running_len_tmp) (call '$str_len (local.get '$item)))) - ) - ) - - (local.get '$running_len_tmp) - ) - (else - (_if '$is_comb '(result i32) - (is_type_code comb_tag (local.get '$to_str_len)) - (then - (i32.const 5) - ) - (else - ;; must be int - (call '$int_digits (extract_int_code (local.get '$to_str_len))) - ) - ) - ) - ) - ) - ) - ) - ) - ) - ) - ) - ) - )))) - ; Utility method, not subject to refcounting - ((k_str_helper func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$str_helper '(param $to_str i64) '(param $buf i32) '(result i32) '(local $len_tmp i32) '(local $buf_tmp i32) '(local $ptr_tmp i32) '(local $x_tmp i32) '(local $y_tmp i32) '(local $i_tmp i32) '(local $item i64) - (_if '$is_true '(result i32) - (i64.eq (i64.const true_val) (local.get '$to_str)) - (then (memory.copy (local.get '$buf) - (i32.const true_loc) - (i32.const true_length)) - (i32.const true_length)) - (else - (_if '$is_false '(result i32) - (i64.eq (i64.const false_val) (local.get '$to_str)) - (then (memory.copy (local.get '$buf) - (i32.const false_loc) - (i32.const false_length)) - (i32.const false_length)) - (else - (_if '$is_str_or_symbol '(result i32) - (is_str_or_sym_code (local.get '$to_str)) - (then (_if '$is_str '(result i32) - (is_type_code string_tag (local.get '$to_str)) - (then - (i32.store8 (local.get '$buf) (i32.const #x22)) - (memory.copy (i32.add (i32.const 1) (local.get '$buf)) - (extract_ptr_code (local.get '$to_str)) - (local.tee '$len_tmp (extract_size_code (local.get '$to_str)))) - (i32.store8 1 (i32.add (local.get '$buf) (local.get '$len_tmp)) (i32.const #x22)) - (i32.add (i32.const 2) (local.get '$len_tmp)) - ) - (else - (i32.store8 (local.get '$buf) (i32.const #x27)) - (memory.copy (i32.add (i32.const 1) (local.get '$buf)) - (extract_ptr_code (local.get '$to_str)) - (local.tee '$len_tmp (extract_size_code (local.get '$to_str)))) - (i32.add (i32.const 1) (local.get '$len_tmp)) - ) - )) - (else - (_if '$is_array '(result i32) - (is_type_code array_tag (local.get '$to_str)) - (then - (local.set '$len_tmp (i32.const 0)) - (local.set '$i_tmp (extract_size_code (local.get '$to_str))) - (local.set '$ptr_tmp (extract_ptr_code (local.get '$to_str))) - (block '$b - (_loop '$l - (i32.store8 (i32.add (local.get '$buf) (local.get '$len_tmp)) (i32.const #x20)) - (local.set '$len_tmp (i32.add (local.get '$len_tmp) (i32.const 1))) - (br_if '$b (i32.eq (local.get '$i_tmp) (i32.const 0))) - (local.set '$len_tmp (i32.add (local.get '$len_tmp) (call '$str_helper (i64.load (local.get '$ptr_tmp)) (i32.add (local.get '$buf) (local.get '$len_tmp))))) - (local.set '$ptr_tmp (i32.add (local.get '$ptr_tmp) (i32.const 8))) - (local.set '$i_tmp (i32.sub (local.get '$i_tmp) (i32.const 1))) - (br '$l) - ) - ) - (i32.store8 (local.get '$buf) (i32.const #x28)) - (i32.store8 (i32.add (local.get '$buf) (local.get '$len_tmp)) (i32.const #x29)) - (i32.add (local.get '$len_tmp) (i32.const 1)) - ) - (else - (_if '$is_env '(result i32) - (is_type_code env_tag (local.get '$to_str)) - (then - (local.set '$len_tmp (i32.const 0)) - - ; ptr to env - (local.set '$ptr_tmp (extract_ptr_code (local.get '$to_str))) - ; ptr to start of array of symbols - (local.set '$x_tmp (extract_ptr_code (i64.load (local.get '$ptr_tmp)))) - ; ptr to start of array of values - (local.set '$y_tmp (extract_ptr_code (i64.load 8 (local.get '$ptr_tmp)))) - ; lenght of both arrays, pulled from array encoding of x - (local.set '$i_tmp (extract_size_code (i64.load (local.get '$ptr_tmp)))) - - (block '$b - (_loop '$l - (i32.store8 (i32.add (local.get '$buf) (local.get '$len_tmp)) (i32.const #x20)) - (local.set '$len_tmp (i32.add (local.get '$len_tmp) (i32.const 1))) - ; break if 0 length left - (br_if '$b (i32.eq (local.get '$i_tmp) (i32.const 0))) - - (local.set '$len_tmp (i32.add (local.get '$len_tmp) (call '$str_helper (i64.load (local.get '$x_tmp)) (i32.add (local.get '$buf) (local.get '$len_tmp))))) - (i32.store8 (i32.add (local.get '$len_tmp) (local.get '$buf)) (i32.const #x3A)) - (local.set '$len_tmp (i32.add (local.get '$len_tmp) (i32.const 1))) - (i32.store8 (i32.add (local.get '$len_tmp) (local.get '$buf)) (i32.const #x20)) - (local.set '$len_tmp (i32.add (local.get '$len_tmp) (i32.const 1))) - (local.set '$len_tmp (i32.add (local.get '$len_tmp) (call '$str_helper (i64.load (local.get '$y_tmp)) (i32.add (local.get '$buf) (local.get '$len_tmp))))) - (i32.store8 (i32.add (local.get '$len_tmp) (local.get '$buf)) (i32.const #x2C)) - (local.set '$len_tmp (i32.add (local.get '$len_tmp) (i32.const 1))) - - (local.set '$x_tmp (i32.add (local.get '$x_tmp) (i32.const 8))) - (local.set '$y_tmp (i32.add (local.get '$y_tmp) (i32.const 8))) - (local.set '$i_tmp (i32.sub (local.get '$i_tmp) (i32.const 1))) - (br '$l) - ) - ) - ;; deal with upper - (local.set '$item (i64.load 16 (local.get '$ptr_tmp))) - (_if '$is_upper_env - (is_type_code env_tag (local.get '$item)) - (then - (i32.store8 -2 (i32.add (local.get '$buf) (local.get '$len_tmp)) (i32.const #x20)) - (i32.store8 -1 (i32.add (local.get '$buf) (local.get '$len_tmp)) (i32.const #x7C)) - (i32.store8 (i32.add (local.get '$len_tmp) (local.get '$buf)) (i32.const #x20)) - (local.set '$len_tmp (i32.add (local.get '$len_tmp) (i32.const 1))) - (local.set '$len_tmp (i32.add (local.get '$len_tmp) (call '$str_helper (local.get '$item) (i32.add (local.get '$buf) (local.get '$len_tmp))))) - ) - ) - (i32.store8 (local.get '$buf) (i32.const #x7B)) - (i32.store8 (i32.add (local.get '$buf) (local.get '$len_tmp)) (i32.const #x7D)) - (local.set '$len_tmp (i32.add (local.get '$len_tmp) (i32.const 1))) - (local.get '$len_tmp) - ) - (else - (_if '$is_comb '(result i32) - (is_type_code comb_tag (local.get '$to_str)) - (then - (i32.store (local.get '$buf) (i32.const #x626D6F63)) - (i32.store8 4 (local.get '$buf) - (i32.add (i32.const #x30) - (i32.wrap_i64 (extract_wrap_code (local.get '$to_str))))) - (i32.const 5) - ) - (else - ;; must be int - (local.set '$to_str (extract_int_code (local.get '$to_str))) - (local.set '$len_tmp (call '$int_digits (local.get '$to_str))) - (local.set '$buf_tmp (i32.add (local.get '$buf) (local.get '$len_tmp))) - - (_if '$is_neg - (i64.lt_s (local.get '$to_str) (i64.const 0)) - (then - (local.set '$to_str (i64.sub (i64.const 0) (local.get '$to_str))) - (i64.store8 (local.get '$buf) (i64.const #x2D)) - ) - ) - - (block '$b - (_loop '$l - (local.set '$buf_tmp (i32.sub (local.get '$buf_tmp) (i32.const 1))) - (i64.store8 (local.get '$buf_tmp) (i64.add (i64.const #x30) (i64.rem_u (local.get '$to_str) (i64.const 10)))) - (local.set '$to_str (i64.div_u (local.get '$to_str) (i64.const 10))) - (br_if '$b (i64.eq (local.get '$to_str) (i64.const 0))) - (br '$l) - ) - ) - - (local.get '$len_tmp) - ) - ) - ) - ) - ) - ) - ) - ) - ) - ) - ) - ) - )))) - ; Utility method, not subject to refcounting - ((k_print func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$print '(param $to_print i64) '(local $iov i32) '(local $data_size i32) - (local.set '$iov (call '$malloc (i32.add (i32.const 8) - (local.tee '$data_size (call '$str_len (local.get '$to_print)))))) - (_drop (call '$str_helper (local.get '$to_print) (i32.add (i32.const 8) (local.get '$iov)))) - (_if '$is_str (is_type_code string_tag (local.get '$to_print)) - (then - (i32.store (local.get '$iov) (i32.add (i32.const 9) (local.get '$iov))) ;; adder of data - (i32.store 4 (local.get '$iov) (i32.sub (local.get '$data_size) (i32.const 2))) ;; len of data - ) - (else - (i32.store (local.get '$iov) (i32.add (i32.const 8) (local.get '$iov))) ;; adder of data - (i32.store 4 (local.get '$iov) (local.get '$data_size)) ;; len of data - ) - ) - (_drop (call '$fd_write - (i32.const 1) ;; file descriptor - (local.get '$iov) ;; *iovs - (i32.const 1) ;; iovs_len - (local.get '$iov) ;; nwritten - )) - (call '$free (local.get '$iov)) - )))) - (_ (true_print "made print")) - ((k_dup func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$dup '(param $rc_bytes i64) '(result i64) '(local $rc_ptr i32) - ;(generate_dup (local.get '$rc_bytes)) - ;(unreachable) - (_if '$is_rc - (i64.ne (i64.const 0) (i64.and (i64.const rc_mask) (local.get '$rc_bytes))) - (then - (local.set '$rc_ptr (i32.sub (extract_ptr_code (local.get '$rc_bytes)) (i32.const 4))) - (i32.store (local.get '$rc_ptr) (i32.add (i32.load (local.get '$rc_ptr)) (i32.const 1))) - ) - ) - (local.get '$rc_bytes) - )))) - ; currenty func 16( 18?! ) in profile - ((k_drop_free func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$drop_free '(param $it i64) '(local $ptr i32) '(local $tmp_ptr i32) '(local $new_val i32) '(local $i i32) '(local $rc_bytes i64) '(local $rc_tmp i32) '(local $rc_ptr i32) - (local.set '$ptr (extract_ptr_code (local.get '$it))) - (_if '$needs_inner_drop - (is_not_type_code string_tag (local.get '$it)) - (then - (_if '$is_array - (is_type_code array_tag (local.get '$it)) - (then - (local.set '$i (extract_size_code (local.get '$it))) - - (_if '$new_max - (i32.gt_u (local.get '$i) (global.get '$num_array_maxsubdrops)) - (then (global.set '$num_array_maxsubdrops (local.get '$i)))) - (global.set '$num_array_subdrops (i32.add (local.get '$i) (global.get '$num_array_subdrops))) - - (local.set '$tmp_ptr (local.get '$ptr)) - (block '$done - (_loop '$l - (br_if '$done (i32.eqz (local.get '$i))) - (generate_drop (i64.load (local.get '$tmp_ptr))) - (local.set '$tmp_ptr (i32.add (local.get '$tmp_ptr) (i32.const 8))) - (local.set '$i (i32.sub (local.get '$i) (i32.const 1))) - (br '$l) - ) - ) - (global.set '$num_array_innerdrops (i32.add (i32.const 1) (global.get '$num_array_innerdrops))) - ) - (else - ; is env ptr - (generate_drop (i64.load 0 (local.get '$ptr))) - (generate_drop (i64.load 8 (local.get '$ptr))) - (generate_drop (i64.load 16 (local.get '$ptr))) - (global.set '$num_env_innerdrops (i32.add (i32.const 1) (global.get '$num_env_innerdrops))) - ) - ) - ) - ) - (call '$free (local.get '$ptr)) - )))) - - ; Utility method, but does refcount - ((k_slice_impl func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$slice_impl '(param $array i64) '(param $s i32) '(param $e i32) '(result i64) '(local $size i32) '(local $new_size i32) '(local $i i32) '(local $ptr i32) '(local $new_ptr i32) '(local $rc_bytes i64) '(local $rc_ptr i32) '(local $rc_tmp i32) - (local.set '$size (extract_size_code (local.get '$array))) - (local.set '$ptr (extract_ptr_code (local.get '$array))) - (_if '$s_lt_0 - (i32.lt_s (local.get '$s) (i32.const 0)) - (then - (local.set '$s (i32.add (i32.const 1) (i32.add (local.get '$s) (local.get '$size)))) - ) - ) - (_if '$e_lt_0 - (i32.lt_s (local.get '$e) (i32.const 0)) - (then - (local.set '$e (i32.add (i32.const 1) (i32.add (local.get '$e) (local.get '$size)))) - ) - ) - - (_if '$s_lt_0 (i32.lt_s (local.get '$s) (i32.const 0)) (then (unreachable))) - (_if '$e_lt_s (i32.lt_s (local.get '$e) (local.get '$s)) (then (unreachable))) - (_if '$e_gt_size (i32.gt_s (local.get '$e) (local.get '$size)) (then (unreachable))) - - (local.set '$new_size (i32.sub (local.get '$e) (local.get '$s))) - (_if '$new_size_0 '(result i64) - (i32.eqz (local.get '$new_size)) - (then - (generate_drop (local.get '$array)) - (_if '$is_array '(result i64) - (is_type_code array_tag (local.get '$array)) - (then (i64.const nil_val)) - (else (i64.const emptystr_val))) - ) - (else - (_if '$is_array '(result i64) - (is_type_code array_tag (local.get '$array)) - (then - (local.set '$new_ptr (call '$malloc (i32.shl (local.get '$new_size) (i32.const 3)))) ; malloc(size*8) - - (local.set '$i (i32.const 0)) - (block '$exit_loop - (_loop '$l - (br_if '$exit_loop (i32.eq (local.get '$i) (local.get '$new_size))) - (i64.store (i32.add (i32.shl (local.get '$i) (i32.const 3)) (local.get '$new_ptr)) - (generate_dup (i64.load (i32.add (i32.shl (i32.add (local.get '$s) (local.get '$i)) (i32.const 3)) - (local.get '$ptr))))) ; n[i] = dup(o[i+s]) - (local.set '$i (i32.add (i32.const 1) (local.get '$i))) - (br '$l) - ) - ) - (generate_drop (local.get '$array)) - (mk_array_code_rc (local.get '$new_size) (local.get '$new_ptr)) - ) - (else - (local.set '$new_ptr (call '$malloc (local.get '$new_size))) ; malloc(size) - (memory.copy (local.get '$new_ptr) - (i32.add (local.get '$ptr) (local.get '$s)) - (local.get '$new_size)) - - (generate_drop (local.get '$array)) - (mk_string_code_rc (local.get '$new_size) (local.get '$new_ptr)) - ) - ) - ) - ))))) - (_ (true_print "made k_slice_impl")) - - ; chose k_slice_impl because it will never be called, so that - ; no function will have a 0 func index and count as falsy - (dyn_start (+ 0 k_slice_impl)) - - (func_id_dynamic_ofset (+ (- 0 dyn_start) (- num_pre_functions 1))) - - (set_len_ptr (concat (local.set '$len (extract_size_code (local.get '$p))) - (local.set '$ptr (extract_ptr_code (local.get '$p))) - )) - (ensure_not_op_n_params_set_ptr_len (lambda (op n) (concat set_len_ptr - (_if '$is_2_params - (op (local.get '$len) (i32.const n)) - (then - (call '$print (i64.const bad_params_number_msg_val)) - (unreachable) - ) - ) - ))) - (drop_p_d (concat - (generate_drop (local.get '$p)) - (generate_drop (local.get '$d)))) - - ((datasi memo k_log_msg_val) (compile-string-val datasi memo "k_log")) - ((k_log func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$log '(param $p i64) '(param $d i64) '(param $s i64) '(result i64) '(local $ptr i32) '(local $len i32) '(local $rc_bytes i64) '(local $rc_ptr i32) '(local $rc_tmp i32) - set_len_ptr - (call '$print (i64.const log_msg_val)) - (call '$print (local.get '$p)) - (call '$print (i64.const newline_msg_val)) - (_if '$no_params '(result i64) - (i32.eqz (local.get '$len)) - (then - (i64.const nil_val) - ) - (else - (generate_dup (i64.load (i32.add (local.get '$ptr) (i32.shl (i32.sub (local.get '$len) (i32.const 1)) (i32.const 3))))) - ) - ) - drop_p_d - )))) - ((func_idx funcs) (array (+ 1 func_idx) (concat funcs (func '$dummy '(result i64) (i64.const 0))))) - ((datasi memo k_error_msg_val) (compile-string-val datasi memo "k_error")) - ((k_error func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$error '(param $p i64) '(param $d i64) '(param $s i64) '(result i64) '(local $rc_bytes i64) '(local $rc_ptr i32) '(local $rc_tmp i32) - (call '$print (i64.const error_msg_val)) - (call '$print (local.get '$p)) - (call '$print (i64.const newline_msg_val)) - drop_p_d - (unreachable) - )))) - ((func_idx funcs) (array (+ 1 func_idx) (concat funcs (func '$dummy '(result i64) (i64.const 0))))) - ((datasi memo k_str_msg_val) (compile-string-val datasi memo "k_str")) - ((k_str func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$str '(param $p i64) '(param $d i64) '(param $s i64) '(result i64) '(local $buf i32) '(local $size i32) '(local $rc_bytes i64) '(local $rc_ptr i32) '(local $rc_tmp i32) - (local.set '$buf (call '$malloc (local.tee '$size (call '$str_len (local.get '$p))))) - (_drop (call '$str_helper (local.get '$p) (local.get '$buf))) - drop_p_d - (mk_string_code_rc (local.get '$size) (local.get '$buf)) - )))) - (_ (true_print "str is " k_str " which might be " (- k_str dyn_start))) - ((func_idx funcs) (array (+ 1 func_idx) (concat funcs (func '$dummy '(result i64) (i64.const 0))))) - - (pred_func (lambda (name type_tag) (func name '(param $p i64) '(param $d i64) '(param $s i64) '(result i64) '(local $ptr i32) '(local $len i32) '(local $rc_bytes i64) '(local $rc_ptr i32) '(local $rc_tmp i32) - (ensure_not_op_n_params_set_ptr_len i32.ne 1) - (typecheck 0 (array '(result i64)) - i64.eq type_tag - (array (then (i64.const true_val))) - (array (else (i64.const false_val))) - ) - drop_p_d - ))) - ((datasi memo k_nil_msg_val) (compile-string-val datasi memo "k_nil")) - ((k_nil? func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func 'nil? '(param $p i64) '(param $d i64) '(param $s i64) '(result i64) '(local $ptr i32) '(local $len i32) '(local $rc_bytes i64) '(local $rc_ptr i32) '(local $rc_tmp i32) - (ensure_not_op_n_params_set_ptr_len i32.ne 1) - (_if '$a_len_lt_b_len '(result i64) - (i64.eq (i64.const nil_val) (i64.load (local.get '$ptr))) - (then (i64.const true_val)) - (else (i64.const false_val)) - ) - drop_p_d - )))) - (_ (true_print "nil? is " k_nil? " which might be " (- k_nil? dyn_start))) - ((func_idx funcs) (array (+ 1 func_idx) (concat funcs (func '$dummy '(result i64) (i64.const 0))))) - ((k_array? func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (pred_func '$array? array_tag)))) - (_ (true_print "array? is " k_array? " which might be " (- k_array? dyn_start))) - ((func_idx funcs) (array (+ 1 func_idx) (concat funcs (func '$dummy '(result i64) (i64.const 0))))) - ((datasi memo k_bool_msg_val) (compile-string-val datasi memo "k_bool")) - ((k_bool? func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (pred_func '$bool? bool_tag)))) - ((func_idx funcs) (array (+ 1 func_idx) (concat funcs (func '$dummy '(result i64) (i64.const 0))))) - ((datasi memo k_env_msg_val) (compile-string-val datasi memo "k_env")) - ((k_env? func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (pred_func '$env? env_tag)))) - ((func_idx funcs) (array (+ 1 func_idx) (concat funcs (func '$dummy '(result i64) (i64.const 0))))) - ((datasi memo k_combiner_msg_val) (compile-string-val datasi memo "k_combiner")) - ((k_combiner? func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (pred_func '$combiner comb_tag)))) - ((func_idx funcs) (array (+ 1 func_idx) (concat funcs (func '$dummy '(result i64) (i64.const 0))))) - ((datasi memo k_string_msg_val) (compile-string-val datasi memo "k_string")) - ((k_string? func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (pred_func '$string? string_tag)))) - ((func_idx funcs) (array (+ 1 func_idx) (concat funcs (func '$dummy '(result i64) (i64.const 0))))) - ((datasi memo k_int_msg_val) (compile-string-val datasi memo "k_int")) - ((k_int? func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (pred_func '$int? int_tag)))) - ((func_idx funcs) (array (+ 1 func_idx) (concat funcs (func '$dummy '(result i64) (i64.const 0))))) - ((datasi memo k_symbol_msg_val) (compile-string-val datasi memo "k_symbol")) - ((k_symbol? func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (pred_func '$symbol? symbol_tag)))) - ((func_idx funcs) (array (+ 1 func_idx) (concat funcs (func '$dummy '(result i64) (i64.const 0))))) - - (_ (true_print "made k_sybmol?")) - - ((k_str_sym_comp func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$str_sym_comp '(param $a i64) '(param $b i64) '(param $lt_val i64) '(param $eq_val i64) '(param $gt_val i64) '(result i64) '(local $result i64) '(local $a_len i32) '(local $b_len i32) '(local $a_ptr i32) '(local $b_ptr i32) - (local.set '$result (local.get '$eq_val)) - (local.set '$a_len (extract_size_code (local.get '$a))) - (local.set '$b_len (extract_size_code (local.get '$b))) - (local.set '$a_ptr (extract_ptr_code (local.get '$a))) - (local.set '$b_ptr (extract_ptr_code (local.get '$b))) - (block '$b - (_if '$a_len_lt_b_len - (i32.lt_s (local.get '$a_len) (local.get '$b_len)) - (then (local.set '$result (local.get '$lt_val)) - (br '$b))) - (_if '$a_len_gt_b_len - (i32.gt_s (local.get '$a_len) (local.get '$b_len)) - (then (local.set '$result (local.get '$gt_val)) - (br '$b))) - - (_loop '$l - (br_if '$b (i32.eqz (local.get '$a_len))) - - (local.set '$a (i64.load8_u (local.get '$a_ptr))) - (local.set '$b (i64.load8_u (local.get '$b_ptr))) - - (_if '$a_lt_b - (i64.lt_s (local.get '$a) (local.get '$b)) - (then (local.set '$result (local.get '$lt_val)) - (br '$b))) - (_if '$a_gt_b - (i64.gt_s (local.get '$a) (local.get '$b)) - (then (local.set '$result (local.get '$gt_val)) - (br '$b))) - - (local.set '$a_len (i32.sub (local.get '$a_len) (i32.const 1))) - (local.set '$a_ptr (i32.add (local.get '$a_ptr) (i32.const 1))) - (local.set '$b_ptr (i32.add (local.get '$b_ptr) (i32.const 1))) - (br '$l) - ) - ) - (local.get '$result) - )))) - (_ (true_print "str_sym_comp is " k_str_sym_comp " which might be " (- k_str_sym_comp dyn_start))) - ((func_idx funcs) (array (+ 1 func_idx) (concat funcs (func '$dummy '(result i64) (i64.const 0))))) - - ((k_comp_helper_helper func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$comp_helper_helper '(param $a i64) '(param $b i64) '(param $lt_val i64) '(param $eq_val i64) '(param $gt_val i64) '(result i64) '(local $result i64) '(local $a_tmp i32) '(local $b_tmp i32) '(local $a_ptr i32) '(local $b_ptr i32) '(local $result_tmp i64) - (block '$blck - ;; INT - (_if '$a_int - (is_type_code int_tag (local.get '$a)) - (then - (_if '$b_int - (is_type_code int_tag (local.get '$b)) - (then - (_if '$a_lt_b - (i64.lt_s (local.get '$a) (local.get '$b)) - (then (local.set '$result (local.get '$lt_val)) - (br '$blck))) - (_if '$a_gt_b - (i64.gt_s (local.get '$a) (local.get '$b)) - (then (local.set '$result (local.get '$gt_val)) - (br '$blck))) - (local.set '$result (local.get '$eq_val)) - (br '$blck) - ) - ) - ; Else, b is not an int, so a < b - (local.set '$result (local.get '$lt_val)) - (br '$blck) - ) - ) - (_if '$b_int - (is_type_code int_tag (local.get '$b)) - (then - (local.set '$result (local.get '$gt_val)) - (br '$blck)) - ) - ;; STRING - (_if '$a_string - (is_type_code string_tag (local.get '$a)) - (then - (_if '$b_string - (is_type_code string_tag (local.get '$b)) - (then - (local.set '$result (call '$str_sym_comp (local.get '$a) (local.get '$b) (local.get '$lt_val) (local.get '$eq_val) (local.get '$gt_val))) - (br '$blck)) - ) - ; else b is not an int or string, so bigger - (local.set '$result (local.get '$lt_val)) - (br '$blck) - ) - ) - (_if '$b_string - (is_type_code string_tag (local.get '$b)) - (then - (local.set '$result (local.get '$gt_val)) - (br '$blck)) - ) - ;; SYMBOL - (_if '$a_symbol - (is_type_code symbol_tag (local.get '$a)) - (then - (_if '$b_symbol - (is_type_code symbol_tag (local.get '$b)) - (then - ; if we're only doing eq or neq, we can compare interned values - (_if '$eq_based_test - (i64.eq (local.get '$lt_val) (local.get '$gt_val)) - (then - (_if '$eq - (i64.eq (local.get '$a) (local.get '$b)) - (then - (local.set '$result (local.get '$eq_val)) - ) - (else - (local.set '$result (local.get '$lt_val)) - ) - ) - ) - (else - (local.set '$result (call '$str_sym_comp (local.get '$a) (local.get '$b) (local.get '$lt_val) (local.get '$eq_val) (local.get '$gt_val))) - ) - ) - - (br '$blck)) - ) - ; else b is not an int or string or symbol, so bigger - (local.set '$result (local.get '$lt_val)) - (br '$blck) - ) - ) - (_if '$b_symbol - (is_type_code symbol_tag (local.get '$b)) - (then - (local.set '$result (local.get '$gt_val)) - (br '$blck)) - ) - ;; ARRAY - (_if '$a_array - (is_type_code array_tag (local.get '$a)) - (then - (_if '$b_array - (is_type_code array_tag (local.get '$b)) - (then - (local.set '$result (local.get '$eq_val)) - (local.set '$a_tmp (extract_size_code (local.get '$a))) - (local.set '$b_tmp (extract_size_code (local.get '$b))) - - (_if '$a_len_lt_b_len - (i32.lt_s (local.get '$a_tmp) (local.get '$b_tmp)) - (then (local.set '$result (local.get '$lt_val)) - (br '$blck))) - (_if '$a_len_gt_b_len - (i32.gt_s (local.get '$a_tmp) (local.get '$b_tmp)) - (then (local.set '$result (local.get '$gt_val)) - (br '$blck))) - - (local.set '$a_ptr (extract_ptr_code (local.get '$a))) - (local.set '$b_ptr (extract_ptr_code (local.get '$b))) - - (_loop '$l - (br_if '$b (i32.eqz (local.get '$a_tmp))) - - (local.set '$result_tmp (call '$comp_helper_helper (i64.load (local.get '$a_ptr)) - (i64.load (local.get '$b_ptr)) - (i64.const -1) (i64.const 0) (i64.const 1))) - - (_if '$a_lt_b - (i64.eq (local.get '$result_tmp) (i64.const -1)) - (then (local.set '$result (local.get '$lt_val)) - (br '$blck))) - (_if '$a_gt_b - (i64.eq (local.get '$result_tmp) (i64.const 1)) - (then (local.set '$result (local.get '$gt_val)) - (br '$blck))) - - (local.set '$a_tmp (i32.sub (local.get '$a_tmp) (i32.const 1))) - (local.set '$a_ptr (i32.add (local.get '$a_ptr) (i32.const 8))) - (local.set '$b_ptr (i32.add (local.get '$b_ptr) (i32.const 8))) - (br '$l) - )) - ) - ; else b is not an int or string or symbol or array, so bigger - (local.set '$result (local.get '$lt_val)) - (br '$blck) - ) - ) - (_if '$b_array - (is_type_code array_tag (local.get '$b)) - (then - (local.set '$result (local.get '$gt_val)) - (br '$blck)) - ) - ;; COMBINER - (_if '$a_comb - (is_type_code comb_tag (local.get '$a)) - (then - (_if '$b_comb - (is_type_code comb_tag (local.get '$b)) - (then - ; compare func indicies first - (local.set '$a_tmp (extract_func_idx_code (local.get '$a))) - (local.set '$b_tmp (extract_func_idx_code (local.get '$b))) - (_if '$a_tmp_lt_b_tmp - (i32.lt_s (local.get '$a_tmp) (local.get '$b_tmp)) - (then - (local.set '$result (local.get '$lt_val)) - (br '$blck)) - ) - (_if '$a_tmp_eq_b_tmp - (i32.gt_s (local.get '$a_tmp) (local.get '$b_tmp)) - (then - (local.set '$result (local.get '$gt_val)) - (br '$blck)) - ) - ; Idx was the same, so recursively comp envs - (local.set '$result (call '$comp_helper_helper (extract_func_env_code (local.get '$a)) - (extract_func_env_code (local.get '$b)) - (local.get '$lt_val) (local.get '$eq_val) (local.get '$gt_val))) - (br '$blck)) - ) - ; else b is not an int or string or symbol or array or combiner, so bigger - (local.set '$result (local.get '$lt_val)) - (br '$blck) - ) - ) - (_if '$b_comb - (is_type_code comb_tag (local.get '$b)) - (then - (local.set '$result (local.get '$gt_val)) - (br '$blck)) - ) - ;; ENV - (_if '$a_env - (is_type_code env_tag (local.get '$a)) - (then - (_if '$b_comb - (is_type_code env_tag (local.get '$b)) - (then - (local.set '$a_ptr (extract_ptr_code (local.get '$a))) - (local.set '$b_ptr (extract_ptr_code (local.get '$b))) - - ; First, compare their symbol arrays - (local.set '$result_tmp (call '$comp_helper_helper (i64.load 0 (local.get '$a_ptr)) - (i64.load 0 (local.get '$b_ptr)) - (i64.const -1) (i64.const 0) (i64.const 1))) - (_if '$a_lt_b - (i64.eq (local.get '$result_tmp) (i64.const -1)) - (then (local.set '$result (local.get '$lt_val)) - (br '$blck))) - (_if '$a_gt_b - (i64.eq (local.get '$result_tmp) (i64.const 1)) - (then (local.set '$result (local.get '$gt_val)) - (br '$blck))) - - ; Second, compare their value arrays - (local.set '$result_tmp (call '$comp_helper_helper (i64.load 8 (local.get '$a_ptr)) - (i64.load 8 (local.get '$b_ptr)) - (i64.const -1) (i64.const 0) (i64.const 1))) - (_if '$a_lt_b - (i64.eq (local.get '$result_tmp) (i64.const -1)) - (then (local.set '$result (local.get '$lt_val)) - (br '$blck))) - (_if '$a_gt_b - (i64.eq (local.get '$result_tmp) (i64.const 1)) - (then (local.set '$result (local.get '$gt_val)) - (br '$blck))) - - ; Finally, just accept the result of recursion - (local.set '$result (call '$comp_helper_helper (i64.load 16 (local.get '$a_ptr)) - (i64.load 16 (local.get '$b_ptr)) - (local.get '$lt_val) (local.get '$eq_val) (local.get '$gt_val))) - - (br '$blck)) - ) - ; else b is bool, so bigger - (local.set '$result (local.get '$lt_val)) - (br '$blck) - ) - ) - (_if '$b_env - (is_type_code env_tag (local.get '$b)) - (then - (local.set '$result (local.get '$gt_val)) - (br '$blck)) - ) - ;; BOOL hehe - (_if '$a_lt_b - (i64.lt_s (local.get '$a) (local.get '$b)) - (then - (local.set '$result (local.get '$lt_val)) - (br '$blck)) - ) - (_if '$a_eq_b - (i64.eq (local.get '$a) (local.get '$b)) - (then - (local.set '$result (local.get '$eq_val)) - (br '$blck)) - ) - (local.set '$result (local.get '$gt_val)) - (br '$blck) - ) - (local.get '$result) - )))) - (_ (true_print "comp_helper_helper is " k_comp_helper_helper " which might be " (- k_comp_helper_helper dyn_start))) - ((func_idx funcs) (array (+ 1 func_idx) (concat funcs (func '$dummy '(result i64) (i64.const 0))))) - - ((k_comp_helper func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$comp_helper '(param $p i64) '(param $d i64) '(param $s i64) '(param $lt_val i64) '(param $eq_val i64) '(param $gt_val i64) '(result i64) '(local $ptr i32) '(local $len i32) '(local $result i64) '(local $a i64) '(local $b i64) '(local $rc_bytes i64) '(local $rc_ptr i32) '(local $rc_tmp i32) - set_len_ptr - (local.set '$result (i64.const true_val)) - (block '$done_block - (_loop '$loop - (br_if '$done_block (i32.le_u (local.get '$len) (i32.const 1))) - (local.set '$a (i64.load (local.get '$ptr))) - (local.set '$ptr (i32.add (local.get '$ptr) (i32.const 8))) - (local.set '$b (i64.load (local.get '$ptr))) - (_if '$was_false - (i64.eq (i64.const false_val) (call '$comp_helper_helper (local.get '$a) (local.get '$b) (local.get '$lt_val) (local.get '$eq_val) (local.get '$gt_val))) - (then - (local.set '$result (i64.const false_val)) - (br '$done_block) - ) - ) - (local.set '$len (i32.sub (local.get '$len) (i32.const 1))) - (br '$loop) - ) - ) - (local.get '$result) - drop_p_d - )))) - (_ (true_print "comp_helper is " k_comp_helper " which might be " (- k_comp_helper dyn_start))) - ((func_idx funcs) (array (+ 1 func_idx) (concat funcs (func '$dummy '(result i64) (i64.const 0))))) - - (_ (true_print "made k_comp_hlper")) - - ((datasi memo k_eq_msg_val) (compile-string-val datasi memo "k_eq")) - ((k_eq func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$eq '(param $p i64) '(param $d i64) '(param $s i64) '(result i64) - (call '$comp_helper (local.get '$p) (local.get '$d) (local.get '$s) (i64.const false_val) (i64.const true_val) (i64.const false_val)) - )))) - (_ (true_print "= is " k_eq " which might be " (- k_eq dyn_start))) - ((func_idx funcs) (array (+ 1 func_idx) (concat funcs (func '$dummy '(result i64) (i64.const 0))))) - ((datasi memo k_neq_msg_val) (compile-string-val datasi memo "k_neq")) - ((k_neq func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$neq '(param $p i64) '(param $d i64) '(param $s i64) '(result i64) - (call '$comp_helper (local.get '$p) (local.get '$d) (local.get '$s) (i64.const true_val) (i64.const false_val) (i64.const true_val)) - )))) - ((func_idx funcs) (array (+ 1 func_idx) (concat funcs (func '$dummy '(result i64) (i64.const 0))))) - ((datasi memo k_geq_msg_val) (compile-string-val datasi memo "k_geq")) - ((k_geq func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$geq '(param $p i64) '(param $d i64) '(param $s i64) '(result i64) - (call '$comp_helper (local.get '$p) (local.get '$d) (local.get '$s) (i64.const false_val) (i64.const true_val) (i64.const true_val)) - )))) - ((func_idx funcs) (array (+ 1 func_idx) (concat funcs (func '$dummy '(result i64) (i64.const 0))))) - ((datasi memo k_gt_msg_val) (compile-string-val datasi memo "k_gt")) - ((k_gt func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$gt '(param $p i64) '(param $d i64) '(param $s i64) '(result i64) - (call '$comp_helper (local.get '$p) (local.get '$d) (local.get '$s) (i64.const false_val) (i64.const false_val) (i64.const true_val)) - )))) - ((func_idx funcs) (array (+ 1 func_idx) (concat funcs (func '$dummy '(result i64) (i64.const 0))))) - ((datasi memo k_leq_msg_val) (compile-string-val datasi memo "k_leq")) - ((k_leq func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$leq '(param $p i64) '(param $d i64) '(param $s i64) '(result i64) - (call '$comp_helper (local.get '$p) (local.get '$d) (local.get '$s) (i64.const true_val) (i64.const true_val) (i64.const false_val)) - )))) - ((func_idx funcs) (array (+ 1 func_idx) (concat funcs (func '$dummy '(result i64) (i64.const 0))))) - ((datasi memo k_lt_msg_val) (compile-string-val datasi memo "k_lt")) - ((k_lt func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$lt '(param $p i64) '(param $d i64) '(param $s i64) '(result i64) - (call '$comp_helper (local.get '$p) (local.get '$d) (local.get '$s) (i64.const true_val) (i64.const false_val) (i64.const false_val)) - )))) - (_ (true_print "< is " k_lt " which might be " (- k_lt dyn_start))) - ((func_idx funcs) (array (+ 1 func_idx) (concat funcs (func '$dummy '(result i64) (i64.const 0))))) - - (math_function (lambda (name sensitive op) - (func name '(param $p i64) '(param $d i64) '(param $s i64) '(result i64) '(local $ptr i32) '(local $len i32) '(local $i i32) '(local $cur i64) '(local $next i64) '(local $rc_bytes i64) '(local $rc_ptr i32) '(local $rc_tmp i32) - (ensure_not_op_n_params_set_ptr_len i32.eq 0) - (local.set '$i (i32.const 1)) - (local.set '$cur (i64.load (local.get '$ptr))) - (_if '$not_num - (is_not_type_code int_tag (local.get '$cur)) - (then (unreachable)) - ) - (block '$b - (_loop '$l - (br_if '$b (i32.eq (local.get '$len) (local.get '$i))) - (local.set '$ptr (i32.add (i32.const 8) (local.get '$ptr))) - (local.set '$next (i64.load (local.get '$ptr))) - (_if '$not_num - (is_not_type_code int_tag (local.get '$next)) - (then (unreachable)) - ) - (local.set '$cur (if sensitive (mk_int_code_i64 (op (extract_int_code (local.get '$cur)) (extract_int_code (local.get '$next)))) - (op (local.get '$cur) (local.get '$next)))) - (local.set '$i (i32.add (local.get '$i) (i32.const 1))) - (br '$l) - ) - ) - drop_p_d - (local.get '$cur) - ) - )) - - ((datasi memo k_mod_msg_val) (compile-string-val datasi memo "k_mod")) - ((k_mod func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (math_function '$mod true i64.rem_s)))) - ((func_idx funcs) (array (+ 1 func_idx) (concat funcs (func '$dummy '(result i64) (i64.const 0))))) - ((datasi memo k_div_msg_val) (compile-string-val datasi memo "k_div")) - ((k_div func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (math_function '$div true i64.div_s)))) - ((func_idx funcs) (array (+ 1 func_idx) (concat funcs (func '$dummy '(result i64) (i64.const 0))))) - ((datasi memo k_mul_msg_val) (compile-string-val datasi memo "k_mul")) - ((k_mul func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (math_function '$mul true i64.mul)))) - ((func_idx funcs) (array (+ 1 func_idx) (concat funcs (func '$dummy '(result i64) (i64.const 0))))) - ((datasi memo k_sub_msg_val) (compile-string-val datasi memo "k_sub")) - ((k_sub func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (math_function '$sub true i64.sub)))) - ((func_idx funcs) (array (+ 1 func_idx) (concat funcs (func '$dummy '(result i64) (i64.const 0))))) - ((datasi memo k_add_msg_val) (compile-string-val datasi memo "k_add")) - ((k_add func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (math_function '$add false i64.add)))) - ((func_idx funcs) (array (+ 1 func_idx) (concat funcs (func '$dummy '(result i64) (i64.const 0))))) - ((datasi memo k_band_msg_val) (compile-string-val datasi memo "k_band")) - ((k_band func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (math_function '$band false i64.and)))) - ((func_idx funcs) (array (+ 1 func_idx) (concat funcs (func '$dummy '(result i64) (i64.const 0))))) - ((datasi memo k_bor_msg_val) (compile-string-val datasi memo "k_bor")) - ((k_bor func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (math_function '$bor false i64.or)))) - ((func_idx funcs) (array (+ 1 func_idx) (concat funcs (func '$dummy '(result i64) (i64.const 0))))) - ((datasi memo k_bxor_msg_val) (compile-string-val datasi memo "k_bxor")) - ((k_bxor func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (math_function '$bxor false i64.xor)))) - ((func_idx funcs) (array (+ 1 func_idx) (concat funcs (func '$dummy '(result i64) (i64.const 0))))) - - ((datasi memo k_bnot_msg_val) (compile-string-val datasi memo "k_bnot")) - ((k_bnot func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$bnot '(param $p i64) '(param $d i64) '(param $s i64) '(result i64) '(local $ptr i32) '(local $len i32) '(local $rc_bytes i64) '(local $rc_ptr i32) '(local $rc_tmp i32) - (ensure_not_op_n_params_set_ptr_len i32.ne 1) - (type_assert 0 int_tag k_bnot_msg_val) - (i64.xor (i64.const int_mask) (i64.load (local.get '$ptr))) - drop_p_d - )))) - ((func_idx funcs) (array (+ 1 func_idx) (concat funcs (func '$dummy '(result i64) (i64.const 0))))) - - ((datasi memo k_ls_msg_val) (compile-string-val datasi memo "k_ls")) - ((k_ls func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$ls '(param $p i64) '(param $d i64) '(param $s i64) '(result i64) '(local $ptr i32) '(local $len i32) '(local $rc_bytes i64) '(local $rc_ptr i32) '(local $rc_tmp i32) - (ensure_not_op_n_params_set_ptr_len i32.ne 2) - (type_assert 0 int_tag k_ls_msg_val) - (type_assert 1 int_tag k_ls_msg_val) - (i64.shl (i64.load 0 (local.get '$ptr)) (extract_int_code (i64.load 8 (local.get '$ptr)))) - drop_p_d - )))) - ((func_idx funcs) (array (+ 1 func_idx) (concat funcs (func '$dummy '(result i64) (i64.const 0))))) - ((datasi memo k_rs_msg_val) (compile-string-val datasi memo "k_rs")) - ((k_rs func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$rs '(param $p i64) '(param $d i64) '(param $s i64) '(result i64) '(local $ptr i32) '(local $len i32) '(local $rc_bytes i64) '(local $rc_ptr i32) '(local $rc_tmp i32) - (ensure_not_op_n_params_set_ptr_len i32.ne 2) - (type_assert 0 int_tag k_rs_msg_val) - (type_assert 1 int_tag k_rs_msg_val) - (i64.and (i64.const int_mask) (i64.shr_s (i64.load 0 (local.get '$ptr)) (extract_int_code (i64.load 8 (local.get '$ptr))))) - drop_p_d - )))) - ((func_idx funcs) (array (+ 1 func_idx) (concat funcs (func '$dummy '(result i64) (i64.const 0))))) - - - ((k_builtin_fib_helper func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$builtin_fib_helper '(param $n i64) '(result i64) - (_if '$eq0 '(result i64) - (i64.eq (i64.const 0) (local.get '$n)) - (then (i64.const (mk_int_value 1))) - (else - (_if '$eq1 '(result i64) - (i64.eq (i64.const (mk_int_value 1)) (local.get '$n)) - (then (i64.const (mk_int_value 1))) - (else - (i64.add (call '$builtin_fib_helper (i64.sub (local.get '$n) (i64.const (mk_int_value 1)))) (call '$builtin_fib_helper (i64.sub (local.get '$n) (i64.const (mk_int_value 2))))) - ) - ) - ) - ) - )))) - ((func_idx funcs) (array (+ 1 func_idx) (concat funcs (func '$dummy '(result i64) (i64.const 0))))) - - ((datasi memo k_builtin_fib_msg_val) (compile-string-val datasi memo "k_builtin_fib")) - ((k_builtin_fib func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$builtin_fib '(param $p i64) '(param $d i64) '(param $s i64) '(result i64) '(local $ptr i32) '(local $len i32) '(local $rc_bytes i64) '(local $rc_ptr i32) '(local $rc_tmp i32) - (ensure_not_op_n_params_set_ptr_len i32.ne 1) - (type_assert 0 int_tag k_builtin_fib_msg_val) - (call '$builtin_fib_helper (i64.load 0 (local.get '$ptr))) - drop_p_d - )))) - ((func_idx funcs) (array (+ 1 func_idx) (concat funcs (func '$dummy '(result i64) (i64.const 0))))) - - (_ (true_print "made k_builtin_fib")) - - ((datasi memo k_concat_msg_val) (compile-string-val datasi memo "k_concat")) - ((k_concat func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$concat '(param $p i64) '(param $d i64) '(param $s i64) '(result i64) '(local $ptr i32) '(local $len i32) '(local $size i32) '(local $i i32) '(local $it i64) '(local $new_ptr i32) '(local $inner_ptr i32) '(local $inner_size i32) '(local $new_ptr_traverse i32) '(local $is_str i32) '(local $rc_bytes i64) '(local $rc_ptr i32) '(local $rc_tmp i32) - set_len_ptr - (local.set '$size (i32.const 0)) - (local.set '$i (i32.const 0)) - (local.set '$is_str (i32.const 0)) - (block '$b - (_loop '$l - (br_if '$b (i32.eq (local.get '$len) (local.get '$i))) - (local.set '$it (i64.load (i32.add (i32.shl (local.get '$i) (i32.const 3)) (local.get '$ptr)))) - (_if '$not_array (is_not_type_code array_tag (local.get '$it)) - (then - (_if '$is_string (is_type_code string_tag (local.get '$it)) - (then - (_if '$is_first (i32.eq (i32.const 0) (local.get '$i)) - (then - (local.set '$is_str (i32.const 1)) - ) - (else - (_if '$mixed (i32.eqz (local.get '$is_str)) - (then (unreachable))) - ) - ) - ) - (else (unreachable)) - ) - ) - (else - (_if '$mixed (local.get '$is_str) - (then (unreachable))) - ) - ) - (local.set '$size (i32.add (local.get '$size) (extract_size_code (local.get '$it)))) - (local.set '$i (i32.add (local.get '$i) (i32.const 1))) - (br '$l) - ) - ) - (_if '$size_0 '(result i64) - (i32.eqz (local.get '$size)) - (then (_if 'ret_emptystr '(result i64) (local.get '$is_str) - (then (i64.const emptystr_val)) - (else (i64.const nil_val)))) - (else - (_if 'doing_str '(result i64) (local.get '$is_str) - (then - (local.set '$new_ptr (call '$malloc (local.get '$size))) ; malloc(size) - (local.set '$new_ptr_traverse (local.get '$new_ptr)) - - (local.set '$i (i32.const 0)) - (block '$exit_outer_loop - (_loop '$outer_loop - (br_if '$exit_outer_loop (i32.eq (local.get '$len) (local.get '$i))) - (local.set '$it (i64.load (i32.add (i32.shl (local.get '$i) (i32.const 3)) (local.get '$ptr)))) - - (local.set '$inner_ptr (extract_ptr_code (local.get '$it))) - (local.set '$inner_size (extract_size_code (local.get '$it))) - - (memory.copy (local.get '$new_ptr_traverse) - (local.get '$inner_ptr) - (local.get '$inner_size)) - - (local.set '$new_ptr_traverse (i32.add (local.get '$new_ptr_traverse) (local.get '$inner_size))) - (local.set '$i (i32.add (local.get '$i) (i32.const 1))) - (br '$outer_loop) - ) - ) - - (mk_string_code_rc (local.get '$size) (local.get '$new_ptr)) - ) - (else - (local.set '$new_ptr (call '$malloc (i32.shl (local.get '$size) (i32.const 3)))) ; malloc(size*8) - (local.set '$new_ptr_traverse (local.get '$new_ptr)) - - (local.set '$i (i32.const 0)) - (block '$exit_outer_loop - (_loop '$outer_loop - (br_if '$exit_outer_loop (i32.eq (local.get '$len) (local.get '$i))) - (local.set '$it (i64.load (i32.add (i32.shl (local.get '$i) (i32.const 3)) (local.get '$ptr)))) - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ; There's some serious optimization we could do here - ; Moving the items from the sub arrays to this one without - ; going through all the dup/drop - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - (local.set '$inner_ptr (extract_ptr_code (local.get '$it))) - (local.set '$inner_size (extract_size_code (local.get '$it))) - - (block '$exit_inner_loop - (_loop '$inner_loop - (br_if '$exit_inner_loop (i32.eqz (local.get '$inner_size))) - (i64.store (local.get '$new_ptr_traverse) - (generate_dup (i64.load (local.get '$inner_ptr)))) - (local.set '$inner_ptr (i32.add (local.get '$inner_ptr) (i32.const 8))) - (local.set '$new_ptr_traverse (i32.add (local.get '$new_ptr_traverse) (i32.const 8))) - (local.set '$inner_size (i32.sub (local.get '$inner_size) (i32.const 1))) - (br '$inner_loop) - ) - ) - (local.set '$i (i32.add (local.get '$i) (i32.const 1))) - (br '$outer_loop) - ) - ) - (mk_array_code_rc (local.get '$size) (local.get '$new_ptr)) - ) - ) - ) - ) - drop_p_d - )))) - (_ (true_print "concat is " k_concat " which might be " (- k_concat dyn_start))) - ((func_idx funcs) (array (+ 1 func_idx) (concat funcs (func '$dummy '(result i64) (i64.const 0))))) - ((datasi memo k_slice_msg_val) (compile-string-val datasi memo "k_slice")) - ((k_slice func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$slice '(param $p i64) '(param $d i64) '(param $s i64) '(result i64) '(local $ptr i32) '(local $len i32) '(local $rc_bytes i64) '(local $rc_ptr i32) '(local $rc_tmp i32) '(local $rc_bytes i64) '(local $rc_ptr i32) '(local $rc_tmp i32) - (ensure_not_op_n_params_set_ptr_len i32.ne 3) - (type_assert 0 (array array_tag string_tag) k_slice_msg_val) - (type_assert 1 int_tag k_slice_msg_val) - (type_assert 2 int_tag k_slice_msg_val) - (call '$slice_impl (generate_dup (i64.load 0 (local.get '$ptr))) - (extract_int_code_i32 (i64.load 8 (local.get '$ptr))) - (extract_int_code_i32 (i64.load 16 (local.get '$ptr)))) - drop_p_d - )))) - (_ (true_print "slice is " k_slice " which might be " (- k_slice dyn_start))) - (_ (true_print "made k_slice")) - ((func_idx funcs) (array (+ 1 func_idx) (concat funcs (func '$dummy '(result i64) (i64.const 0))))) - ((datasi memo k_idx_msg_val) (compile-string-val datasi memo "k_idx")) - ((k_idx func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$idx '(param $p i64) '(param $d i64) '(param $s i64) '(result i64) '(local $ptr i32) '(local $len i32) '(local $array i64) '(local $idx i32) '(local $size i32) '(local $rc_bytes i64) '(local $rc_ptr i32) '(local $rc_tmp i32) - (ensure_not_op_n_params_set_ptr_len i32.ne 2) - (type_assert 0 (array array_tag string_tag) k_idx_msg_val) - (type_assert 1 int_tag k_idx_msg_val) - (local.set '$array (i64.load 0 (local.get '$ptr))) - (local.set '$idx (extract_int_code_i32 (i64.load 8 (local.get '$ptr)))) - (local.set '$size (extract_size_code (local.get '$array))) - - (_if '$i_lt_0 (i32.lt_s (local.get '$idx) (i32.const 0)) (then (unreachable))) - (_if '$i_ge_s (i32.ge_s (local.get '$idx) (local.get '$size)) (then (unreachable))) - - (typecheck 0 (array '(result i64)) - i64.eq array_tag - (array (then - (generate_dup (i64.load (i32.add (extract_ptr_code (local.get '$array)) - (i32.shl (local.get '$idx) (i32.const 3))))) - )) - (array (else (mk_int_code_i64 (i64.load8_u (i32.add (extract_ptr_code (local.get '$array)) - (local.get '$idx)))))) - ) - drop_p_d - )))) - (_ (true_print "idx is " k_idx " which might be " (- k_idx dyn_start))) - ((func_idx funcs) (array (+ 1 func_idx) (concat funcs (func '$dummy '(result i64) (i64.const 0))))) - ((datasi memo k_len_msg_val) (compile-string-val datasi memo "k_len")) - ((k_len func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$len '(param $p i64) '(param $d i64) '(param $s i64) '(result i64) '(local $ptr i32) '(local $len i32) '(local $rc_bytes i64) '(local $rc_ptr i32) '(local $rc_tmp i32) - (ensure_not_op_n_params_set_ptr_len i32.ne 1) - (type_assert 0 (array array_tag string_tag) k_len_msg_val) - (mk_int_code_i32u (extract_size_code (i64.load 0 (local.get '$ptr)))) - drop_p_d - )))) - (_ (true_print "len is " k_len " which might be " (- k_len dyn_start))) - ((func_idx funcs) (array (+ 1 func_idx) (concat funcs (func '$dummy '(result i64) (i64.const 0))))) - ((datasi memo k_array_msg_val) (compile-string-val datasi memo "k_array")) - ((k_array func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$array '(param $p i64) '(param $d i64) '(param $s i64) '(result i64) '(local $rc_bytes i64) '(local $rc_ptr i32) '(local $rc_tmp i32) - (local.get '$p) - (generate_drop (local.get '$d)) - ; s is 0 - )))) - ((func_idx funcs) (array (+ 1 func_idx) (concat funcs (func '$dummy '(result i64) (i64.const 0))))) - - ((datasi memo k_get_msg_val) (compile-string-val datasi memo "k_get-text")) - ((k_get-text func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$get-text '(param $p i64) '(param $d i64) '(param $s i64) '(result i64) '(local $ptr i32) '(local $len i32) '(local $rc_bytes i64) '(local $rc_ptr i32) '(local $rc_tmp i32) - (ensure_not_op_n_params_set_ptr_len i32.ne 1) - (type_assert 0 symbol_tag k_get_msg_val) - ; Does not need to dup, as since it's a symbol it's already interned - ; so this is now an interned string - (toggle_sym_str_code (i64.load (local.get '$ptr))) - drop_p_d - )))) - - ((func_idx funcs) (array (+ 1 func_idx) (concat funcs (func '$dummy '(result i64) (i64.const 0))))) - ((datasi memo k_str_msg_val) (compile-string-val datasi memo "k_str")) - ((k_str-to-symbol func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$str-to-symbol '(param $p i64) '(param $d i64) '(param $s i64) '(result i64) '(local $ptr i32) '(local $len i32) '(local $looking_for i64) '(local $potential i64) '(local $traverse i64) '(local $rc_bytes i64) '(local $rc_ptr i32) '(local $rc_tmp i32) - (ensure_not_op_n_params_set_ptr_len i32.ne 1) - (type_assert 0 string_tag k_str_msg_val) - - (local.set '$looking_for (i64.load (local.get '$ptr))) - (local.set '$traverse (global.get '$symbol_intern)) - (local.set '$potential (i64.const nil_val)) - - (block '$loop_break - (_loop '$loop - (br_if '$loop_break (i64.eq (local.get '$traverse) (i64.const nil_val))) - (local.set '$potential (i64.load 0 (extract_ptr_code (local.get '$traverse)))) - (local.set '$traverse (i64.load 8 (extract_ptr_code (local.get '$traverse)))) - (_if '$found_it - (i64.eq (i64.const 1) - (call '$str_sym_comp (local.get '$looking_for) (local.get '$potential) (i64.const 0) (i64.const 1) (i64.const 0))) - (then - (br '$loop_break) - ) - ) - (local.set '$potential (i64.const nil_val)) - (br '$loop) - ) - ) - (_if '$didnt_find_it - (i64.eq (local.get '$traverse) (i64.const nil_val)) - (then - (local.set '$potential (toggle_sym_str_code_norc (generate_dup (local.get '$looking_for)))) - ;(local.set '$potential (toggle_sym_str_code (generate_dup (local.get '$looking_for)))) - (global.set '$symbol_intern (call '$array2_alloc (local.get '$potential) (global.get '$symbol_intern))) - (global.set '$num_interned_symbols (i32.add (i32.const 1) (global.get '$num_interned_symbols))) - ) - ) - (local.get '$potential) - ;(generate_dup (local.get '$potential)) - drop_p_d - )))) - ((func_idx funcs) (array (+ 1 func_idx) (concat funcs (func '$dummy '(result i64) (i64.const 0))))) - - ((datasi memo k_unwrap_msg_val) (compile-string-val datasi memo "k_unwrap")) - ((k_unwrap func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$unwrap '(param $p i64) '(param $d i64) '(param $s i64) '(result i64) '(local $ptr i32) '(local $len i32) '(local $comb i64) '(local $wrap_level i64) '(local $rc_bytes i64) '(local $rc_ptr i32) '(local $rc_tmp i32) - (ensure_not_op_n_params_set_ptr_len i32.ne 1) - (type_assert 0 comb_tag k_unwrap_msg_val) - (local.set '$comb (i64.load (local.get '$ptr))) - (local.set '$wrap_level (extract_wrap_code (local.get '$comb))) - (_if '$wrap_level_0 - (i64.eqz (local.get '$wrap_level)) - (then (unreachable)) - ) - (generate_dup (set_wrap_code (i64.sub (local.get '$wrap_level) (i64.const 1)) (local.get '$comb))) - drop_p_d - )))) - ((func_idx funcs) (array (+ 1 func_idx) (concat funcs (func '$dummy '(result i64) (i64.const 0))))) - ((datasi memo k_wrap_msg_val) (compile-string-val datasi memo "k_wrap")) - ((k_wrap func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$wrap '(param $p i64) '(param $d i64) '(param $s i64) '(result i64) '(local $ptr i32) '(local $len i32) '(local $comb i64) '(local $wrap_level i64) '(local $rc_bytes i64) '(local $rc_ptr i32) '(local $rc_tmp i32) - (ensure_not_op_n_params_set_ptr_len i32.ne 1) - (type_assert 0 comb_tag k_wrap_msg_val) - (local.set '$comb (i64.load (local.get '$ptr))) - (local.set '$wrap_level (extract_wrap_code (local.get '$comb))) - (_if '$wrap_level_1 - (i64.eq (i64.const 1) (local.get '$wrap_level)) - (then (unreachable)) - ) - (generate_dup (set_wrap_code (i64.add (local.get '$wrap_level) (i64.const 1)) (local.get '$comb))) - drop_p_d - )))) - ((func_idx funcs) (array (+ 1 func_idx) (concat funcs (func '$dummy '(result i64) (i64.const 0))))) - - ((datasi memo k_quote_msg_val) (compile-string-val datasi memo "k_quote")) - ((k_quote func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$quote '(param $p i64) '(param $d i64) '(param $s i64) '(result i64) '(local $ptr i32) '(local $len i32) '(local $comb i64) '(local $wrap_level i64) '(local $rc_bytes i64) '(local $rc_ptr i32) '(local $rc_tmp i32) - (ensure_not_op_n_params_set_ptr_len i32.ne 1) - (generate_dup (i64.load (local.get '$ptr))) - drop_p_d - )))) - ((func_idx funcs) (array (+ 1 func_idx) (concat funcs (func '$dummy '(result i64) (i64.const 0))))) - - (quote_val (mk_comb_val_nil_env (- k_quote dyn_start) 0 0)) - - ((datasi memo k_lapply_msg_val) (compile-string-val datasi memo "k_lapply")) - ((k_lapply func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$lapply '(param $p i64) '(param $d i64) '(param $s i64) '(result i64) '(local $ptr i32) '(local $ptr_b i32) '(local $len i32) '(local $comb i64) '(local $params i64) '(local $wrap_level i64) '(local $inner_env i64) '(local $rc_bytes i64) '(local $rc_ptr i32) '(local $rc_tmp i32) - (ensure_not_op_n_params_set_ptr_len i32.lt_u 2) - (type_assert 0 comb_tag k_lapply_msg_val) - (type_assert 1 array_tag k_lapply_msg_val) - (local.set '$comb (generate_dup (i64.load 0 (local.get '$ptr)))) - (local.set '$params (generate_dup (i64.load 8 (local.get '$ptr)))) - (_if '$needs_dynamic_env - (extract_usede_code (local.get '$comb)) - (then - (_if '$explicit_inner - (i32.eq (i32.const 3) (local.get '$len)) - (then - (type_assert 2 env_tag k_lapply_msg_val) - (generate_drop (local.get '$d)) - (local.set '$inner_env (generate_dup (i64.load 16 (local.get '$ptr)))) - ) - (else - (local.set '$inner_env (local.get '$d)) - ) - ) - ) - (else - (generate_drop (local.get '$d)) - (local.set '$inner_env (i64.const nil_val)) - ) - ) - (generate_drop (local.get '$p)) - (local.set '$wrap_level (extract_wrap_code (local.get '$comb))) - (local.set '$len (extract_size_code (local.get '$params))) - ; if params len == 0, doesn't matter what the wrap level is - (_if '$params_len_ne_0 - (i32.ne (i32.const 0) (local.get '$len)) - (then - (_if '$wrap_level_ne_1 - (i64.ne (i64.const 1) (local.get '$wrap_level)) - (then - (_if '$wrap_level_eq_0 - (i64.eq (i64.const 0) (local.get '$wrap_level)) - (then - (local.set '$ptr (call '$malloc (i32.shl (local.get '$len) (i32.const 3)))) - (local.set '$ptr_b (extract_ptr_code (local.get '$params))) - (_loop '$quote_params - (local.set '$len (i32.sub (local.get '$len) (i32.const 1))) - (i64.store (i32.add (i32.shl (local.get '$len) (i32.const 3)) (local.get '$ptr)) - (call '$array2_alloc (i64.const quote_val) (generate_dup (i64.load (i32.add (i32.shl (local.get '$len) (i32.const 3)) (local.get '$ptr_b)))))) - (br_if '$quote_params (i32.ne (i32.const 0) (local.get '$len))) - ) - (local.set '$len (extract_size_code (local.get '$params))) - (generate_drop (local.get '$params)) - (local.set '$params (mk_array_code_rc (local.get '$len) (local.get '$ptr))) - ) - (else (unreachable)) - ) - ) - ) - ) - ) - - (call_indirect - ;type - k_wrap - ;table - 0 - ;params - (local.get '$params) - ; dynamic env - (local.get '$inner_env) - ; static env - (extract_func_env_code (local.get '$comb)) - ;func_idx - (extract_func_idx_code (local.get '$comb)) - ) - )))) - ((func_idx funcs) (array (+ 1 func_idx) (concat funcs (func '$dummy '(result i64) (i64.const 0))))) - - ((datasi memo k_vapply_msg_val) (compile-string-val datasi memo "k_vapply")) - ((datasi memo k_vapply_1_msg_val) (compile-string-val datasi memo "vapply - we don't yet support compiled (vapply (args..)), is TODO - needs rearranging of eval_helper position etc")) - ((k_vapply func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$vapply '(param $p i64) '(param $d i64) '(param $s i64) '(result i64) '(local $ptr i32) '(local $len i32) '(local $comb i64) '(local $params i64) '(local $wrap_level i64) '(local $inner_env i64) '(local $rc_bytes i64) '(local $rc_ptr i32) '(local $rc_tmp i32) - (ensure_not_op_n_params_set_ptr_len i32.ne 3) - (type_assert 0 comb_tag k_vapply_msg_val) - (type_assert 1 array_tag k_vapply_msg_val) - (local.set '$comb (generate_dup (i64.load 0 (local.get '$ptr)))) - (local.set '$params (generate_dup (i64.load 8 (local.get '$ptr)))) - (_if '$needs_dynamic_env - (extract_usede_code (local.get '$comb)) - (then - (_if '$explicit_inner - (i32.eq (i32.const 3) (local.get '$len)) - (then - (type_assert 2 env_tag k_vapply_msg_val) - (generate_drop (local.get '$d)) - (local.set '$inner_env (generate_dup (i64.load 16 (local.get '$ptr)))) - ) - (else - (local.set '$inner_env (local.get '$d)) - ) - ) - ) - (else - (generate_drop (local.get '$d)) - (local.set '$inner_env (i64.const nil_val)) - ) - ) - (generate_drop (local.get '$p)) - (local.set '$wrap_level (extract_wrap_code (local.get '$comb))) - (_if '$wrap_level_ne_0 - (i64.ne (i64.const 0) (local.get '$wrap_level)) - ; TODO - if wrap_level == 1, eval all parameters - ; that's what the partially evaluated one does. - ; Will require some re-arranging as eval helper etc - ; are currently defined below us - (then (call '$print (i64.const k_vapply_1_msg_val)) - (unreachable)) - ) - - (call_indirect - ;type - k_wrap - ;table - 0 - ;params - (local.get '$params) - ; dynamic env - (local.get '$inner_env) - ; static env - (extract_func_env_code (local.get '$comb)) - ;func_idx - (extract_func_idx_code (local.get '$comb)) - ) - )))) - (_ (true_print "made vapply")) - ((func_idx funcs) (array (+ 1 func_idx) (concat funcs (func '$dummy '(result i64) (i64.const 0))))) - ; *GLOBAL ALERT* - ((k_parse_helper func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$parse_helper '(result i64) '(local $result i64) '(local $tmp i32) '(local $sub_result i64) '(local $asiz i32) '(local $acap i32) '(local $aptr i32) '(local $bptr i32) '(local $bcap i32) '(local $neg_multiplier i64) '(local $radix i64) - (block '$b1 - (block '$b2 - (_loop '$l - (br_if '$b2 (i32.eqz (global.get '$phl))) - (local.set '$tmp (i32.load8_u (global.get '$phs))) - (_if '$whitespace (i32.or (i32.or (i32.eq (i32.const #x9) (local.get '$tmp)) ; tab - (i32.eq (i32.const #xA) (local.get '$tmp))) ; newline - (i32.or (i32.eq (i32.const #xD) (local.get '$tmp)) ; carrige return - (i32.eq (i32.const #x20) (local.get '$tmp)))) ; space - (then - (global.set '$phs (i32.add (global.get '$phs) (i32.const 1))) - (global.set '$phl (i32.sub (global.get '$phl) (i32.const 1))) - (br '$l) - ) - ) - (_if '$comment (i32.eq (i32.const #x3B) (local.get '$tmp)) - (then - (_loop '$li - (global.set '$phs (i32.add (global.get '$phs) (i32.const 1))) - (global.set '$phl (i32.sub (global.get '$phl) (i32.const 1))) - (br_if '$b2 (i32.eqz (global.get '$phl))) - (local.set '$tmp (i32.load8_u (global.get '$phs))) - (br_if '$li (i32.ne (i32.const #xA) (local.get '$tmp))) - ) - (br '$l) - ) - ) - ) - ) - (local.set '$result (i64.const empty_parse_value)) - (_if '$at_least1 - (i32.ge_u (global.get '$phl) (i32.const 1)) - (then - (local.set '$tmp (i32.load8_u (global.get '$phs))) - ; string - (_if '$is_open - (i32.eq (local.get '$tmp) (i32.const #x22)) - (then - (global.set '$phs (i32.add (global.get '$phs) (i32.const 1))) - (global.set '$phl (i32.sub (global.get '$phl) (i32.const 1))) - (local.set '$asiz (i32.const 0)) - (local.set '$bptr (global.get '$phs)) - - ; Count size - (block '$b2 - (_loop '$il - (_if '$doesnt_have_next - (i32.eqz (global.get '$phl)) - (then - (local.set '$result (i64.const error_parse_value)) - (br '$b1) - ) - ) - - (br_if '$b2 (i32.eq (i32.load8_u (global.get '$phs)) (i32.const #x22))) - - (_if '$an_escape - (i32.eq (i32.load8_u (global.get '$phs)) (i32.const #x5C)) - (then - (global.set '$phs (i32.add (global.get '$phs) (i32.const 1))) - (global.set '$phl (i32.sub (global.get '$phl) (i32.const 1))) - (_if '$doesnt_have_next - (i32.eqz (global.get '$phl)) - (then - (local.set '$result (i64.const error_parse_value)) - (br '$b1) - ) - ) - ) - ) - (local.set '$asiz (i32.add (local.get '$asiz) (i32.const 1))) - - (global.set '$phs (i32.add (global.get '$phs) (i32.const 1))) - (global.set '$phl (i32.sub (global.get '$phl) (i32.const 1))) - (br '$il) - ) - ) - - (global.set '$phs (i32.add (global.get '$phs) (i32.const 1))) - (global.set '$phl (i32.sub (global.get '$phl) (i32.const 1))) - - (local.set '$bcap (local.get '$asiz)) - (local.set '$aptr (call '$malloc (local.get '$asiz))) - - ; copy the bytes, implementing the escapes - (block '$b2 - (_loop '$il - (br_if '$b2 (i32.eqz (local.get '$bcap))) - - (_if '$an_escape - (i32.eq (i32.load8_u (local.get '$bptr)) (i32.const #x5C)) - (then - (_if '$escaped_slash - (i32.eq (i32.load8_u 1 (local.get '$bptr)) (i32.const #x5C)) - (then - (i32.store8 (local.get '$aptr) (i32.const #x5C)) - ) - (else - (_if '$escaped_quote - (i32.eq (i32.load8_u 1 (local.get '$bptr)) (i32.const #x22)) - (then - (i32.store8 (local.get '$aptr) (i32.const #x22)) - ) - (else - (_if '$escaped_newline - (i32.eq (i32.load8_u 1 (local.get '$bptr)) (i32.const #x6E)) - (then - (i32.store8 (local.get '$aptr) (i32.const #x0A)) - ) - (else - (_if '$escaped_tab - (i32.eq (i32.load8_u 1 (local.get '$bptr)) (i32.const #x74)) - (then - (i32.store8 (local.get '$aptr) (i32.const #x09)) - ) - (else - (global.set '$phl (i32.add (global.get '$phl) (i32.sub (global.get '$phs) (local.get '$bptr)))) - (global.set '$phs (local.get '$bptr)) - (local.set '$result (i64.const error_parse_value)) - (br '$b1) - ) - ) - ) - ) - ) - ) - ) - ) - (local.set '$bptr (i32.add (local.get '$bptr) (i32.const 2))) - ) - (else - (i32.store8 (local.get '$aptr) (i32.load8_u (local.get '$bptr))) - (local.set '$bptr (i32.add (local.get '$bptr) (i32.const 1))) - ) - ) - (local.set '$bcap (i32.sub (local.get '$bcap) (i32.const 1))) - (local.set '$aptr (i32.add (local.get '$aptr) (i32.const 1))) - (br '$il) - ) - ) - (local.set '$aptr (i32.sub (local.get '$aptr) (local.get '$asiz))) - - (local.set '$result (mk_string_code_rc (local.get '$asiz) (local.get '$aptr))) - (br '$b1) - ) - ) - - ; negative int - (local.set '$neg_multiplier (i64.const 1)) - (_if '$is_dash_and_more - (i32.and (i32.eq (local.get '$tmp) (i32.const #x2D)) (i32.ge_u (global.get '$phl) (i32.const 2))) - (then - (_if '$next_is_letter - (i32.and (i32.ge_u (i32.load8_u 1 (global.get '$phs)) (i32.const #x30)) (i32.le_u (i32.load8_u 1 (global.get '$phs)) (i32.const #x39))) - (then - (global.set '$phs (i32.add (global.get '$phs) (i32.const 1))) - (global.set '$phl (i32.sub (global.get '$phl) (i32.const 1))) - (local.set '$tmp (i32.load8_u (global.get '$phs))) - (local.set '$neg_multiplier (i64.const -1)) - ) - ) - ) - ) - ; int - (local.set '$radix (i64.const 10)) - (_if '$is_zero_through_nine - (i32.and (i32.ge_u (local.get '$tmp) (i32.const #x30)) (i32.le_u (local.get '$tmp) (i32.const #x39))) - (then - (local.set '$result (i64.const 0)) - (_loop '$il - (_if '$is_zero_through_nine_inner - (i32.and (i32.ge_u (local.get '$tmp) (i32.const #x30)) (i32.le_u (local.get '$tmp) (i32.const #x39))) - (then - (local.set '$tmp (i32.sub (local.get '$tmp) (i32.const #x30))) - ) - (else - (local.set '$tmp (i32.sub (local.get '$tmp) (i32.const #x37))) - ) - ) - (local.set '$result (i64.add (i64.mul (local.get '$radix) (local.get '$result)) (i64.extend_i32_u (local.get '$tmp)))) - (global.set '$phs (i32.add (global.get '$phs) (i32.const 1))) - (global.set '$phl (i32.sub (global.get '$phl) (i32.const 1))) - (_if '$at_least1 - (i32.ge_u (global.get '$phl) (i32.const 1)) - (then - (local.set '$tmp (i32.load8_u (global.get '$phs))) - (_if '$is_hex_and_more - (i32.and (i32.eq (local.get '$tmp) (i32.const #x78)) (i32.ge_u (global.get '$phl) (i32.const 2))) - (then - (global.set '$phs (i32.add (global.get '$phs) (i32.const 1))) - (global.set '$phl (i32.sub (global.get '$phl) (i32.const 1))) - (local.set '$tmp (i32.load8_u (global.get '$phs))) - (local.set '$radix (i64.const 16)) - ) - (else - (_if '$is_hex_and_more - (i32.and (i32.eq (local.get '$tmp) (i32.const #x62)) (i32.ge_u (global.get '$phl) (i32.const 2))) - (then - (global.set '$phs (i32.add (global.get '$phs) (i32.const 1))) - (global.set '$phl (i32.sub (global.get '$phl) (i32.const 1))) - (local.set '$tmp (i32.load8_u (global.get '$phs))) - (local.set '$radix (i64.const 2)) - ) - ) - ) - ) - (br_if '$il (i32.or (i32.and (i32.ge_u (local.get '$tmp) (i32.const #x30)) (i32.le_u (local.get '$tmp) (i32.const #x39))) - (i32.and (i32.ge_u (local.get '$tmp) (i32.const #x41)) (i32.le_u (local.get '$tmp) (i32.const #x46))))) - ) - ) - ) - (local.set '$result (mk_int_code_i64 (i64.mul (local.get '$neg_multiplier) (local.get '$result)))) - (br '$b1) - ) - ) - - ; []? - ; ' - (_if '$is_quote - (i32.eq (local.get '$tmp) (i32.const #x27)) - (then - (global.set '$phs (i32.add (global.get '$phs) (i32.const 1))) - (global.set '$phl (i32.sub (global.get '$phl) (i32.const 1))) - (local.set '$sub_result (call '$parse_helper)) - (_if '$ended - (i64.eq (i64.const close_peren_value) (local.get '$sub_result)) - (then - (local.set '$result (i64.const error_parse_value)) - (br '$b1) - ) - ) - (_if '$error - (i32.or (i64.eq (i64.const error_parse_value) (local.get '$sub_result)) - (i64.eq (i64.const empty_parse_value) (local.get '$sub_result))) - (then - (local.set '$result (local.get '$sub_result)) - (br '$b1) - ) - ) - (local.set '$result (call '$array2_alloc (i64.const quote_sym_val) (local.get '$sub_result))) - (br '$b1) - ) - ) - (_if '$is_unquote - (i32.eq (local.get '$tmp) (i32.const #x2C)) - (then - (global.set '$phs (i32.add (global.get '$phs) (i32.const 1))) - (global.set '$phl (i32.sub (global.get '$phl) (i32.const 1))) - (local.set '$sub_result (call '$parse_helper)) - (_if '$ended - (i64.eq (i64.const close_peren_value) (local.get '$sub_result)) - (then - (local.set '$result (i64.const error_parse_value)) - (br '$b1) - ) - ) - (_if '$error - (i32.or (i64.eq (i64.const error_parse_value) (local.get '$sub_result)) - (i64.eq (i64.const empty_parse_value) (local.get '$sub_result))) - (then - (local.set '$result (local.get '$sub_result)) - (br '$b1) - ) - ) - (local.set '$result (call '$array2_alloc (i64.const unquote_sym_val) (local.get '$sub_result))) - (br '$b1) - ) - ) - - ; symbol - (_if '$is_dash_and_more - ; 21 ! - ; 22 " X - ; 23-26 #-& - ; 27 ' X - ; 28-29 (-) X - ; 2A-2F *-/ - ; 30-39 0-9 / - ; 3A : - ; 3B ; - ; 3C-40 <-@ - ; 41-5A A-Z - ; 5B-60 [-` - ; 61-7A a-z - ; 7B-7E {-~ - (i32.or (i32.or (i32.eq (local.get '$tmp) (i32.const #x21)) - (i32.and (i32.ge_u (local.get '$tmp) (i32.const #x23)) (i32.le_u (local.get '$tmp) (i32.const #x26)))) - (i32.or (i32.and (i32.ge_u (local.get '$tmp) (i32.const #x2A)) (i32.le_u (local.get '$tmp) (i32.const #x2F))) - (i32.or (i32.eq (local.get '$tmp) (i32.const #x3A)) - (i32.and (i32.ge_u (local.get '$tmp) (i32.const #x3C)) (i32.le_u (local.get '$tmp) (i32.const #x7E)))))) - (then - (local.set '$asiz (i32.const 0)) - (local.set '$bptr (global.get '$phs)) - (block '$loop_break - (_loop '$il - (global.set '$phs (i32.add (global.get '$phs) (i32.const 1))) - (global.set '$phl (i32.sub (global.get '$phl) (i32.const 1))) - (local.set '$asiz (i32.add (local.get '$asiz) (i32.const 1))) - (_if '$doesnt_have_next - (i32.eqz (global.get '$phl)) - (then (br '$loop_break)) - ) - (local.set '$tmp (i32.load8_u (global.get '$phs))) - (br_if '$il (i32.or (i32.or (i32.eq (local.get '$tmp) (i32.const #x21)) - (i32.and (i32.ge_u (local.get '$tmp) (i32.const #x23)) (i32.le_u (local.get '$tmp) (i32.const #x26)))) - (i32.or (i32.and (i32.ge_u (local.get '$tmp) (i32.const #x2A)) (i32.le_u (local.get '$tmp) (i32.const #x3A))) - (i32.and (i32.ge_u (local.get '$tmp) (i32.const #x3C)) (i32.le_u (local.get '$tmp) (i32.const #x7E)))))) - ) - ) - (_if '$is_true1 - (i32.eq (local.get '$asiz) (i32.const 4)) - (then - (_if '$is_true2 - (i32.eq (i32.load (local.get '$bptr)) (i32.const #x65757274)) - (then - (local.set '$result (i64.const true_val)) - (br '$b1) - ) - ) - ) - ) - (_if '$is_false1 - (i32.eq (local.get '$asiz) (i32.const 5)) - (then - (_if '$is_false2 - (i32.and (i32.eq (i32.load (local.get '$bptr)) (i32.const #x736C6166)) (i32.eq (i32.load8_u 4 (local.get '$bptr)) (i32.const #x65))) - (then - (local.set '$result (i64.const false_val)) - (br '$b1) - ) - ) - ) - ) - (local.set '$aptr (call '$malloc (local.get '$asiz))) - (memory.copy (local.get '$aptr) - (local.get '$bptr) - (local.get '$asiz)) - - ; Inefficient hack - (local.set '$result (call '$str-to-symbol - ;params - (call '$array1_alloc (mk_string_code_rc (local.get '$asiz) (local.get '$aptr))) - ; dynamic env - (i64.const nil_val) - ; static env - (i64.const nil_val) - )) - (br '$b1) - ) - ) - - ; lists (arrays)! - (_if '$is_open - (i32.eq (local.get '$tmp) (i32.const #x28)) - (then - (global.set '$phs (i32.add (global.get '$phs) (i32.const 1))) - (global.set '$phl (i32.sub (global.get '$phl) (i32.const 1))) - (local.set '$asiz (i32.const 0)) - (local.set '$acap (i32.const 4)) - (local.set '$aptr (call '$malloc (i32.const (* 4 8)))) - (_loop '$il - (local.set '$sub_result (call '$parse_helper)) - (_if '$ended - (i64.eq (i64.const close_peren_value) (local.get '$sub_result)) - (then - (_if '$nil - (i32.eqz (local.get '$asiz)) - (then - (call '$free (local.get '$aptr)) - (local.set '$result (i64.const nil_val)) - ) - (else - (local.set '$result (mk_array_code_rc (local.get '$asiz) (local.get '$aptr))) - ) - ) - (br '$b1) - ) - ) - (_if '$error - (i32.or (i64.eq (i64.const error_parse_value) (local.get '$sub_result)) - (i64.eq (i64.const empty_parse_value) (local.get '$sub_result))) - (then - (local.set '$result (local.get '$sub_result)) - (br '$b1) - ) - ) - (_if '$need_to_grow - (i32.eq (local.get '$asiz) (local.get '$acap)) - (then - (local.set '$bcap (i32.shl (local.get '$acap) (i32.const 1))) - (local.set '$bptr (call '$malloc (i32.shl (local.get '$bcap) (i32.const 3)))) - (local.set '$asiz (i32.const 0)) - (_loop '$iil - (i64.store (i32.add (local.get '$bptr) (i32.shl (local.get '$asiz) (i32.const 3))) - (i64.load (i32.add (local.get '$aptr) (i32.shl (local.get '$asiz) (i32.const 3))))) - (local.set '$asiz (i32.add (local.get '$asiz) (i32.const 1))) - (br_if '$iil (i32.lt_u (local.get '$asiz) (local.get '$acap))) - ) - (local.set '$acap (local.get '$bcap)) - (call '$free (local.get '$aptr)) - (local.set '$aptr (local.get '$bptr)) - ) - ) - (i64.store (i32.add (local.get '$aptr) (i32.shl (local.get '$asiz) (i32.const 3))) - (local.get '$sub_result)) - (local.set '$asiz (i32.add (local.get '$asiz) (i32.const 1))) - (br '$il) - ) - ) - ) - (_if '$is_close - (i32.eq (local.get '$tmp) (i32.const #x29)) - (then - (local.set '$result (i64.const close_peren_value)) - (global.set '$phs (i32.add (global.get '$phs) (i32.const 1))) - (global.set '$phl (i32.sub (global.get '$phl) (i32.const 1))) - (br '$b1) - ) - ) - ) - ) - ) - (local.get '$result) - )))) - ((func_idx funcs) (array (+ 1 func_idx) (concat funcs (func '$dummy '(result i64) (i64.const 0))))) - ((datasi memo k_read_msg_val) (compile-string-val datasi memo "k_read")) - ((k_read-string func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$read-string '(param $p i64) '(param $d i64) '(param $s i64) '(result i64) '(local $ptr i32) '(local $len i32) '(local $str i64) '(local $result i64) '(local $tmp_result i64) '(local $tmp_offset i32) '(local $rc_bytes i64) '(local $rc_ptr i32) '(local $rc_tmp i32) - (ensure_not_op_n_params_set_ptr_len i32.ne 1) - (type_assert 0 string_tag k_read_msg_val) - (local.set '$str (i64.load (local.get '$ptr))) - ;(call '$print (i64.const pre_parse_val)) - (global.set '$phl (extract_size_code (local.get '$str))) - (global.set '$phs (extract_ptr_code (local.get '$str))) - (local.set '$result (call '$parse_helper)) - ;(call '$print (i64.const post_parse_val)) - (_if '$was_empty_parse - (i32.or (i64.eq (i64.const error_parse_value) (local.get '$result)) - (i32.or (i64.eq (i64.const empty_parse_value) (local.get '$result)) - (i64.eq (i64.const close_peren_value) (local.get '$result)))) - (then - (call '$print (i64.const couldnt_parse_1_msg_val)) - (call '$print (local.get '$str)) - (call '$print (i64.const couldnt_parse_2_msg_val)) - (call '$print (mk_int_code_i64 (i64.add (i64.const 1) (i64.sub (i64.shr_u (local.get '$str) (i64.const 32)) (i64.extend_i32_u (global.get '$phl)))))) - (call '$print (i64.const newline_msg_val)) - (unreachable) - ) - ) - (_if '$remaining - (i32.ne (i32.const 0) (global.get '$phl)) - (then - (local.set '$tmp_offset (global.get '$phl)) - (local.set '$tmp_result (call '$parse_helper)) - (_if '$wasnt_empty_parse - (i64.ne (i64.const empty_parse_value) (local.get '$tmp_result)) - (then - (call '$print (i64.const parse_remaining_msg_val)) - (call '$print (mk_int_code_i64 (i64.sub (i64.shr_u (local.get '$str) (i64.const 32)) (i64.extend_i32_u (local.get '$tmp_offset))))) - (call '$print (i64.const newline_msg_val)) - (unreachable) - ) - ) - ) - ) - (local.get '$result) - drop_p_d - )))) - ((func_idx funcs) (array (+ 1 func_idx) (concat funcs (func '$dummy '(result i64) (i64.const 0))))) - - (_ (true_print "made parse/read")) - - - (front_half_stack_code (lambda (call_val env_val) (_if '$debug_level (i32.ne (i32.const -1) (global.get '$debug_depth)) (then (global.set '$stack_trace (call '$array3_alloc call_val - env_val - (generate_dup (global.get '$stack_trace)))))))) - (back_half_stack_code (concat (_if '$debug_level (i32.ne (i32.const -1) (global.get '$debug_depth)) (then - (i64.load 16 (extract_ptr_code (global.get '$stack_trace))) - (generate_drop (global.get '$stack_trace)) - (global.set '$stack_trace))))) - ;(front_half_stack_code (lambda (call_val env_val) (array))) - ;(back_half_stack_code (array)) - - ((datasi memo k_call_zero_len_msg_val) (compile-string-val datasi memo "tried to eval a 0-length call")) - ((datasi memo k_call_not_a_function_msg_val) (compile-string-val datasi memo "tried to eval a call to not a function ")) - - ; Helper method, doesn't refcount consume parameters - ; but does properly refcount internally / dup returns - ((k_eval_helper func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$eval_helper '(param $it i64) '(param $env i64) '(result i64) '(local $len i32) '(local $ptr i32) '(local $current_env i64) '(local $res i64) '(local $env_ptr i32) '(local $tmp_ptr i32) '(local $i i32) '(local $comb i64) '(local $params i64) '(local $wrap i32) '(local $tmp i64) '(local $rc_bytes i64) '(local $rc_ptr i32) '(local $rc_tmp i32) - - - (global.set '$num_all_evals (i32.add (i32.const 1) (global.get '$num_all_evals))) - ; The cool thing about Vau calculus / Kernel / Kraken - ; is that everything is a value that evaluates to itself except symbols - ; and arrays. - (_if '$is_value '(result i64) - (value_test (local.get '$it)) - (then - ; it's a value, we can just return it! - (generate_dup (local.get '$it)) - ) - (else - (_if '$is_symbol '(result i64) - (is_type_code symbol_tag (local.get '$it)) - (then - ;(call '$print (local.get '$it)) - ; look it up in the environment - ; Env object is - ; each being the full 64 bit objects. - (local.set '$current_env (local.get '$env)) - ;(call '$print (local.get '$current_env)) - ;(call '$print (i64.const newline_msg_val)) - - (block '$outer_loop_break - (_loop '$outer_loop - (local.set '$env_ptr (extract_ptr_code (local.get '$current_env))) - - (local.set '$len (extract_size_code (i64.load 0 (local.get '$env_ptr)))) - (local.set '$ptr (extract_ptr_code (i64.load 0 (local.get '$env_ptr)))) - (local.set '$i (i32.const 0)) - - (block '$inner_loop_break - (_loop '$inner_loop - (br_if '$inner_loop_break (i32.eqz (local.get '$len))) - (_if '$found_it - (i64.eq (local.get '$it) (i64.load (local.get '$ptr))) - (then - (local.set '$res (generate_dup (i64.load (i32.add (extract_ptr_code (i64.load 8 (local.get '$env_ptr))) - (i32.shl (local.get '$i) (i32.const 3)))))) - (br '$outer_loop_break) - ) - ) - (local.set '$len (i32.sub (local.get '$len) (i32.const 1))) - (local.set '$ptr (i32.add (local.get '$ptr) (i32.const 8))) - (local.set '$i (i32.add (local.get '$i) (i32.const 1))) - (br '$inner_loop) - ) - ) - ; try in upper - (local.set '$current_env (i64.load 16 (local.get '$env_ptr))) - ;(call '$print (mk_int_code_i64 (local.get '$current_env))) - ;(call '$print (i64.const newline_msg_val)) - (br_if '$outer_loop (i64.ne (i64.const nil_val) (local.get '$current_env))) - ) - ; Ended at upper case - (call '$print (i64.const hit_upper_in_eval_msg_val)) - (call '$print (local.get '$it)) - (call '$print (i64.const newline_msg_val)) - (local.set '$res (call (+ 4 func_idx) (call '$array1_alloc (generate_dup (local.get '$it))) (generate_dup (local.get '$env)) (i64.const nil_val))) - ) - (local.get '$res) - ) - (else - (local.set '$len (extract_size_code (local.get '$it))) - (local.set '$ptr (extract_ptr_code (local.get '$it))) - (_if '$zero_length - (i32.eqz (local.get '$len)) - (then (call '$print (i64.const k_call_zero_len_msg_val)) - (unreachable))) - ; its a call, evaluate combiner first then - ;(call '$print (i64.const pre_inner_eval_val)) - (local.set '$comb (call '$eval_helper (i64.load 0 (local.get '$ptr)) (local.get '$env))) - ;(call '$print (i64.const post_inner_eval_val)) - ; check to make sure it's a combiner - (_if '$isnt_function - (is_not_type_code comb_tag (local.get '$comb)) - (then (call '$print (i64.const k_call_not_a_function_msg_val)) - (call '$print (mk_int_code_i64 (local.get '$comb))) - (call '$print (local.get '$comb)) - ; this has problems with redebug for some reason - (local.set '$res (call (+ 4 func_idx) (call '$array1_alloc (generate_dup (local.get '$it))) (generate_dup (local.get '$env)) (i64.const nil_val))) - ) - ) - (local.set '$wrap (i32.wrap_i64 (extract_wrap_code (local.get '$comb)))) - (local.set '$params (call '$slice_impl (generate_dup (local.get '$it)) (i32.const 1) (local.get '$len))) - - ; Pure benchmarking - (_if '$is_wrap_one - (i32.eq (i32.const 1) (local.get '$wrap)) - (then (global.set '$num_interp_done (i32.add (i32.const 1) (global.get '$num_interp_done)))) - (else - (_if '$is_wrap_zero - (i32.eqz (local.get '$wrap)) - (then (global.set '$num_interp_dzero (i32.add (i32.const 1) (global.get '$num_interp_dzero)))) - (else (unreachable))))) - - ; we'll reuse len and ptr now for params - (local.set '$len (extract_size_code (local.get '$params))) - (local.set '$ptr (extract_ptr_code (local.get '$params))) - ; then evaluate parameters wrap times (only 0 or 1 right now) - (block '$wrap_loop_break - (_loop '$wrap_loop - (br_if '$wrap_loop_break (i32.eqz (local.get '$wrap))) - - (local.set '$i (i32.const 0)) - (block '$inner_eval_loop_break - (_loop '$inner_eval_loop - (br_if '$inner_eval_loop_break (i32.eq (local.get '$len) (local.get '$i))) - - (local.set '$tmp_ptr (i32.add (local.get '$ptr) (i32.shl (local.get '$i) (i32.const 3)))) - (local.set '$tmp (call '$eval_helper (i64.load (local.get '$tmp_ptr)) (local.get '$env))) - (generate_drop (i64.load (local.get '$tmp_ptr))) - (i64.store (local.get '$tmp_ptr) (local.get '$tmp)) - - (local.set '$i (i32.add (local.get '$i) (i32.const 1))) - (br '$inner_eval_loop) - ) - ) - (local.set '$wrap (i32.sub (local.get '$wrap) (i32.const 1))) - (br '$wrap_loop) - ) - ) - (front_half_stack_code (generate_dup (local.get '$it)) (generate_dup (local.get '$env))) - ; Also, this really should tail-call when we support it - (call_indirect - ;type - k_wrap - ;table - 0 - ;params - (local.get '$params) - ; dynamic env - (_if '$needs_dynamic_env '(result i64) - (extract_usede_code (local.get '$comb)) - (then (generate_dup (local.get '$env))) - (else (i64.const nil_val))) - ; static env - (extract_func_env_code (local.get '$comb)) - ;func_idx - (extract_func_idx_code (local.get '$comb)) - ) - back_half_stack_code - ) - ) - ) - ) - - )))) - ((func_idx funcs) (array (+ 1 func_idx) (concat funcs (func '$dummy '(result i64) (i64.const 0))))) - ((datasi memo k_eval_msg_val) (compile-string-val datasi memo "k_eval")) - ((k_eval func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$eval '(param $p i64) '(param $d i64) '(param $s i64) '(result i64) '(local $len i32) '(local $ptr i32) '(local $rc_bytes i64) '(local $rc_ptr i32) '(local $rc_tmp i32) - - (ensure_not_op_n_params_set_ptr_len i32.lt_u 1) - (global.set '$num_evals (i32.add (i32.const 1) (global.get '$num_evals))) - (_if '$using_d_env '(result i64) - (i32.eq (i32.const 1) (local.get '$len)) - (then - (call '$eval_helper (i64.load 0 (local.get '$ptr)) (local.get '$d)) - ) - (else - (type_assert 1 env_tag k_eval_msg_val) - (call '$eval_helper (i64.load 0 (local.get '$ptr)) (i64.load 8 (local.get '$ptr))) - ) - ) - drop_p_d - )))) - ((func_idx funcs) (array (+ 1 func_idx) (concat funcs (func '$dummy '(result i64) (i64.const 0))))) - (_ (true_print "made eval")) - - ((datasi memo k_debug_parameters_msg_val) (compile-string-val datasi memo "parameters to debug were ")) - ((datasi memo k_debug_prompt_msg_val) (compile-string-val datasi memo "debug_prompt > ")) - ((datasi memo k_debug_exit_msg_val) (compile-string-val datasi memo "exit")) - ((datasi memo k_debug_abort_msg_val) (compile-string-val datasi memo "abort\n")) - ((datasi memo k_debug_redebug_msg_val) (compile-string-val datasi memo "redebug\n")) - ((datasi memo k_debug_print_st_msg_val) (compile-string-val datasi memo "print_st\n")) - ((datasi memo k_debug_help_msg_val) (compile-string-val datasi memo "help\n")) - ((datasi memo k_debug_help_info_msg_val) (compile-string-val datasi memo "commands: help, print_st, print_envs, print_all, redebug, or (exit )\n")) - ((datasi memo k_debug_print_envs_msg_val) (compile-string-val datasi memo "print_envs\n")) - ((datasi memo k_debug_print_all_msg_val) (compile-string-val datasi memo "print_all\n")) - ((datasi memo k_debug_msg_val) (compile-string-val datasi memo "k_debug")) - ((k_debug func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$debug '(param $p i64) '(param $d i64) '(param $s i64) '(result i64) '(local $len i32) '(local $buf i32) '(local $str i64) '(local $tmp_read i64) '(local $tmp_evaled i64) '(local $to_ret i64) '(local $tmp_ptr i32) '(local $rc_bytes i64) '(local $rc_ptr i32) '(local $rc_tmp i32) - (global.set '$debug_depth (i32.add (global.get '$debug_depth) (i32.const 1))) - (call '$print (i64.const k_debug_parameters_msg_val)) - (call '$print (local.get '$p)) - (call '$print (i64.const newline_msg_val)) - - (block '$varadic_loop_exit - (_loop '$varadic_loop - (call '$print (i64.const k_debug_prompt_msg_val)) - - (local.set '$len (i32.const 100)) - (i32.store 4 (i32.const iov_tmp) (local.get '$len)) - (i32.store 0 (i32.const iov_tmp) (local.tee '$buf (call '$malloc (local.get '$len)))) - (_drop (call '$fd_read - (i32.const 0) ;; file descriptor - (i32.const iov_tmp) ;; *iovs - (i32.const 1) ;; iovs_len - (i32.const (+ 8 iov_tmp)) ;; nwritten - )) - - (local.set '$str (mk_string_code_rc (i32.load 8 (i32.const iov_tmp)) (local.get '$buf))) - - (local.set '$tmp_evaled (i64.const 0)) - (_if '$print_help (i64.eq (i64.const 1) (call '$str_sym_comp (i64.const k_debug_help_msg_val) (local.get '$str) (i64.const 0) (i64.const 1) (i64.const 0))) - (then - (call '$print (i64.const k_debug_help_info_msg_val)) - (generate_drop (local.get '$str)) - (br '$varadic_loop) - ) - ) - (_if '$print_st (i64.eq (i64.const 1) (call '$str_sym_comp (i64.const k_debug_print_st_msg_val) (local.get '$str) (i64.const 0) (i64.const 1) (i64.const 0))) - (then - (local.set '$tmp_read (global.get '$stack_trace)) - (block '$print_loop_exit - (_loop '$print_loop - (br_if '$print_loop_exit (i64.eq (i64.const nil_val) (local.get '$tmp_read))) - (call '$print (local.get '$tmp_evaled)) - (local.set '$tmp_evaled (i64.add (local.get '$tmp_evaled) (i64.const 2))) - (call '$print (i64.const space_msg_val)) - (call '$print (i64.load 0 (extract_ptr_code (local.get '$tmp_read)))) - (call '$print (i64.const newline_msg_val)) - (local.set '$tmp_read (i64.load 16 (extract_ptr_code (local.get '$tmp_read)))) - (br '$print_loop) - ) - ) - (generate_drop (local.get '$str)) - (br '$varadic_loop) - ) - ) - (_if '$print_envs (i64.eq (i64.const 1) (call '$str_sym_comp (i64.const k_debug_print_envs_msg_val) (local.get '$str) (i64.const 0) (i64.const 1) (i64.const 0))) - (then - (local.set '$tmp_read (global.get '$stack_trace)) - (block '$print_loop_exit - (_loop '$print_loop - (br_if '$print_loop_exit (i64.eq (i64.const nil_val) (local.get '$tmp_read))) - (call '$print (local.get '$tmp_evaled)) - (call '$print (i64.const space_msg_val)) - (call '$print (i64.load 8 (extract_ptr_code (local.get '$tmp_read)))) - (local.set '$tmp_evaled (i64.add (local.get '$tmp_evaled) (i64.const 2))) - (call '$print (i64.const newline_msg_val)) - (local.set '$tmp_read (i64.load 16 (extract_ptr_code (local.get '$tmp_read)))) - (br '$print_loop) - ) - ) - (generate_drop (local.get '$str)) - (br '$varadic_loop) - ) - ) - (_if '$print_all (i64.eq (i64.const 1) (call '$str_sym_comp (i64.const k_debug_print_all_msg_val) (local.get '$str) (i64.const 0) (i64.const 1) (i64.const 0))) - (then - (local.set '$tmp_read (global.get '$stack_trace)) - (block '$print_loop_exit - (_loop '$print_loop - (br_if '$print_loop_exit (i64.eq (i64.const nil_val) (local.get '$tmp_read))) - (call '$print (local.get '$tmp_evaled)) - (local.set '$tmp_evaled (i64.add (local.get '$tmp_evaled) (i64.const 2))) - (call '$print (i64.const space_msg_val)) - (call '$print (i64.load 0 (extract_ptr_code (local.get '$tmp_read)))) - (call '$print (i64.const space_msg_val)) - (call '$print (i64.load 8 (extract_ptr_code (local.get '$tmp_read)))) - (call '$print (i64.const newline_msg_val)) - (local.set '$tmp_read (i64.load 16 (extract_ptr_code (local.get '$tmp_read)))) - (br '$print_loop) - ) - ) - (generate_drop (local.get '$str)) - (br '$varadic_loop) - ) - ) - (_if '$abort (i64.eq (i64.const 1) (call '$str_sym_comp (i64.const k_debug_abort_msg_val) (local.get '$str) (i64.const 0) (i64.const 1) (i64.const 0))) - (then - (generate_drop (local.get '$str)) - (unreachable) - ) - ) - - (_if '$redebug (i64.eq (i64.const 1) (call '$str_sym_comp (i64.const k_debug_redebug_msg_val) (local.get '$str) (i64.const 0) (i64.const 1) (i64.const 0))) - (then - (generate_drop (local.get '$str)) - (global.get '$debug_func_to_call) - (global.get '$debug_params_to_call) - (global.get '$debug_env_to_call) - - (local.set '$tmp_evaled (call_indirect - ;type - k_log - ;table - 0 - ;params - (generate_dup (global.get '$debug_params_to_call)) - ;top_env - (generate_dup (global.get '$debug_env_to_call)) - ; static env - (extract_func_env_code (generate_dup (global.get '$debug_func_to_call))) - ;func_idx - (extract_func_idx_code (global.get '$debug_func_to_call)) - )) - - (call '$print (local.get '$tmp_evaled)) - (generate_drop (local.get '$tmp_evaled)) - (call '$print (i64.const newline_msg_val)) - - (global.set '$debug_env_to_call) - (global.set '$debug_params_to_call) - (global.set '$debug_func_to_call) - (br '$varadic_loop) - ) - ) - - - ;(call '$print (i64.const pre_read_val)) - (local.set '$tmp_read (call '$read-string (call '$array1_alloc (local.get '$str)) (i64.const nil_val) (i64.const nil_val))) - ;(call '$print (i64.const post_read_val)) - ;(call '$print (local.get '$tmp_read)) - ;(call '$print (i64.const post_read_val)) - (_if '$arr (is_type_code array_tag (local.get '$tmp_read)) - (then - (_if '$arr (i32.ge_u (i32.const 2) (extract_size_code (local.get '$tmp_read))) - (then - (_if '$exit (i64.eq (i64.const 1) (call '$str_sym_comp (i64.const k_debug_exit_msg_val) - (i64.load 0 (extract_ptr_code (local.get '$tmp_read))) - (i64.const 0) (i64.const 1) (i64.const 0))) - (then - (local.set '$to_ret (call '$eval_helper (i64.load 8 (extract_ptr_code (local.get '$tmp_read))) (local.get '$d))) - (generate_drop (local.get '$tmp_read)) - (br '$varadic_loop_exit) - ) - ) - ) - ) - ) - ) - ;(call '$print (i64.const pre_eval_val)) - (local.set '$tmp_evaled (call '$eval_helper (local.get '$tmp_read) (local.get '$d))) - ;(call '$print (i64.const post_eval_val)) - (call '$print (local.get '$tmp_evaled)) - (generate_drop (local.get '$tmp_read)) - (generate_drop (local.get '$tmp_evaled)) - (call '$print (i64.const newline_msg_val)) - (br '$varadic_loop) - ) - ) - (global.set '$debug_depth (i32.sub (global.get '$debug_depth) (i32.const 1))) - drop_p_d - (local.get '$to_ret) - )))) - ((func_idx funcs) (array (+ 1 func_idx) (concat funcs (func '$dummy '(result i64) (i64.const 0))))) - - (_ (true_print "made debug")) - - ((datasi memo k_vau_helper_msg_val) (compile-string-val datasi memo "k_vau_helper")) - ((k_vau_helper func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$vau_helper '(param $p i64) '(param $d i64) '(param $s i64) '(result i64) '(local $len i32) '(local $ptr i32) '(local $i_se i64) '(local $i_des i64) '(local $i_params i64) '(local $i_is_varadic i64) '(local $min_num_params i32) '(local $i_body i64) '(local $new_env i64) '(local $rc_bytes i64) '(local $rc_ptr i32) '(local $rc_tmp i32) - - ; get env ptr - (local.set '$ptr (extract_ptr_code (local.get '$s))) - ; get value array ptr - (local.set '$ptr (extract_ptr_code (i64.load 8 (local.get '$ptr)))) - - - (local.set '$i_se (generate_dup (i64.load 0 (local.get '$ptr)))) - (local.set '$i_des (i64.load 8 (local.get '$ptr))) - (local.set '$i_params (generate_dup (i64.load 16 (local.get '$ptr)))) - (local.set '$i_is_varadic (i64.load 24 (local.get '$ptr))) - (local.set '$i_body (generate_dup (i64.load 32 (local.get '$ptr)))) - - - ; reusing len for i_params - (local.set '$len (extract_size_code (local.get '$i_params))) - (local.set '$ptr (extract_ptr_code (local.get '$i_params))) - - ; each branch consumes i_params, p, d, and i_se - (_if '$varadic - (i64.eq (local.get '$i_is_varadic) (i64.const true_val)) - (then - (_if '$using_d_env - (i64.ne (local.get '$i_des) (i64.const nil_val)) - (then - (local.set '$min_num_params (i32.sub (local.get '$len) (i32.const 2))) - (_if '$wrong_no_params - ; with both de and varadic, needed params is at least two less than the length of our params - (i32.lt_u (extract_size_code (local.get '$p)) (local.get '$min_num_params)) - (then (call '$print (i64.const bad_params_number_msg_val)) - (unreachable))) - - (local.set '$new_env (call '$env_alloc - (local.get '$i_params) - (call '$concat (call '$array3_alloc (call '$slice_impl (generate_dup (local.get '$p)) - (i32.const 0) - (local.get '$min_num_params)) - (call '$array1_alloc (call '$slice_impl (local.get '$p) - (local.get '$min_num_params) - (i32.const -1))) - (call '$array1_alloc (local.get '$d))) - (i64.const nil_val) - (i64.const nil_val)) - (local.get '$i_se))) - ) - (else - (local.set '$min_num_params (i32.sub (local.get '$len) (i32.const 1))) - (_if '$wrong_no_params - (i32.lt_u (extract_size_code (local.get '$p)) (local.get '$min_num_params)) - (then (call '$print (i64.const bad_params_number_msg_val)) - (unreachable))) - - (local.set '$new_env (call '$env_alloc - (local.get '$i_params) - (call '$concat (call '$array2_alloc (call '$slice_impl (generate_dup (local.get '$p)) - (i32.const 0) - (local.get '$min_num_params)) - (call '$array1_alloc (call '$slice_impl (local.get '$p) - (local.get '$min_num_params) - (i32.const -1)))) - (i64.const nil_val) - (i64.const nil_val)) - (local.get '$i_se))) - (generate_drop (local.get '$d)) - ) - ) - ) - (else - (_if '$using_d_env - (i64.ne (local.get '$i_des) (i64.const nil_val)) - (then - (local.set '$min_num_params (i32.sub (local.get '$len) (i32.const 1))) - (_if '$wrong_no_params - (i32.ne (extract_size_code (local.get '$p)) (local.get '$min_num_params)) - (then (call '$print (i64.const bad_params_number_msg_val)) - (unreachable))) - - (local.set '$new_env (call '$env_alloc - (local.get '$i_params) - (call '$concat (call '$array2_alloc (local.get '$p) - (call '$array1_alloc (local.get '$d))) - (i64.const nil_val) - (i64.const nil_val)) - (local.get '$i_se))) - ) - (else - (local.set '$min_num_params (local.get '$len)) - (_if '$wrong_no_params - (i32.ne (extract_size_code (local.get '$p)) (local.get '$min_num_params)) - (then (call '$print (i64.const bad_params_number_msg_val)) - (unreachable))) - - (local.set '$new_env (call '$env_alloc - (local.get '$i_params) - (local.get '$p) - (local.get '$i_se))) - (generate_drop (local.get '$d)) - ) - ) - ) - ) - - (call '$eval_helper (local.get '$i_body) (local.get '$new_env)) - - (generate_drop (local.get '$i_body)) - (generate_drop (local.get '$new_env)) - (generate_drop (local.get '$s)) - )))) - ((func_idx funcs) (array (+ 1 func_idx) (concat funcs (func '$dummy '(result i64) (i64.const 0))))) - - ((datasi memo k_env_symbol_val) (compile-symbol-val datasi memo 'env_symbol)) - ((datasi memo k_des_symbol_val) (compile-symbol-val datasi memo 'des_symbol)) - ((datasi memo k_param_symbol_val) (compile-symbol-val datasi memo 'param_symbol)) - ((datasi memo k_varadic_symbol_val) (compile-symbol-val datasi memo 'varadic_symbol)) - ((datasi memo k_body_symbol_val) (compile-symbol-val datasi memo 'body_symbol)) - ((datasi memo k_and_symbol_val) (compile-symbol-val datasi memo '&)) - - ((k_env_dparam_body_array_loc k_env_dparam_body_array_len datasi) (alloc_data (concat (i64_le_hexify k_env_symbol_val) - (i64_le_hexify k_des_symbol_val) - (i64_le_hexify k_param_symbol_val) - (i64_le_hexify k_varadic_symbol_val) - (i64_le_hexify k_body_symbol_val) - ) datasi)) - (k_env_dparam_body_array_val (mk_array_value 5 k_env_dparam_body_array_loc)) - - (_ (true_print "about to make vau")) - - ((datasi memo k_vau_msg_val) (compile-string-val datasi memo "k_vau")) - ((k_vau func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$vau '(param $p i64) '(param $d i64) '(param $s i64) '(result i64) '(local $len i32) '(local $ptr i32) '(local $i i32) '(local $des i64) '(local $params i64) '(local $is_varadic i64) '(local $body i64) '(local $tmp i64) '(local $rc_bytes i64) '(local $rc_ptr i32) '(local $rc_tmp i32) - - (local.set '$len (extract_size_code (local.get '$p))) - (local.set '$ptr (extract_ptr_code (local.get '$p))) - - (_if '$using_d_env - (i32.eq (i32.const 3) (local.get '$len)) - (then - (local.set '$des (generate_dup (i64.load 0 (local.get '$ptr)))) - (local.set '$params (generate_dup (i64.load 8 (local.get '$ptr)))) - (local.set '$body (generate_dup (i64.load 16 (local.get '$ptr)))) - ) - (else - (local.set '$des (i64.const nil_val)) - (local.set '$params (generate_dup (i64.load 0 (local.get '$ptr)))) - (local.set '$body (generate_dup (i64.load 8 (local.get '$ptr)))) - ) - ) - - (local.set '$is_varadic (i64.const false_val)) - (local.set '$len (extract_size_code (local.get '$params))) - (local.set '$ptr (extract_ptr_code (local.get '$params))) - (local.set '$i (i32.const 0)) - (block '$varadic_break - (_loop '$varadic_loop - (br_if '$varadic_break (i32.eq (local.get '$i) (local.get '$len))) - (_if 'this_varadic - (i64.eq (i64.const 1) - (call '$str_sym_comp (i64.const k_and_symbol_val) (i64.load (local.get '$ptr)) (i64.const 0) (i64.const 1) (i64.const 0))) - (then - (local.set '$is_varadic (i64.const true_val)) - - (local.set '$tmp (call '$array1_alloc (generate_dup (i64.load 8 (local.get '$ptr))))) - (local.set '$params (call '$concat (call '$array2_alloc (call '$slice_impl (local.get '$params) (i32.const 0) (local.get '$i)) - (local.get '$tmp)) - (i64.const nil_val) - (i64.const nil_val))) - - (br '$varadic_break) - ) - ) - (local.set '$ptr (i32.add (local.get '$ptr) (i32.const 8))) - (local.set '$i (i32.add (local.get '$i) (i32.const 1))) - (br '$varadic_loop) - ) - ) - (_if '$using_d_env - (i64.ne (local.get '$des) (i64.const nil_val)) - (then - (local.set '$params (call '$concat (call '$array2_alloc (local.get '$params) (call '$array1_alloc (generate_dup (local.get '$des)))) - (i64.const nil_val) - (i64.const nil_val))) - ) - ) - - ; |0001 - (mk_comb_val_code_rc_wrap0 (- k_vau_helper dyn_start) - (call '$env_alloc (i64.const k_env_dparam_body_array_val) - (call '$array5_alloc (local.get '$d) - (local.get '$des) - (local.get '$params) - (local.get '$is_varadic) - (local.get '$body)) - (i64.const nil_val)) - (i64.ne (local.get '$des) (i64.const nil_val))) - - (generate_drop (local.get '$p)) - )))) - ((func_idx funcs) (array (+ 1 func_idx) (concat funcs (func '$dummy '(result i64) (i64.const 0))))) - (_ (true_print "made vau")) - ((datasi memo k_cond_msg_val) (compile-string-val datasi memo "k_cond")) - ((k_cond func_idx funcs) (array func_idx (+ 1 func_idx) (concat funcs (func '$cond '(param $p i64) '(param $d i64) '(param $s i64) '(result i64) '(local $len i32) '(local $ptr i32) '(local $tmp i64) '(local $rc_bytes i64) '(local $rc_ptr i32) '(local $rc_tmp i32) - set_len_ptr - ;yall - (block '$cond_loop_break_ok - (block '$cond_loop_break_err - (_loop '$cond_loop - (br_if '$cond_loop_break_err (i32.le_s (local.get '$len) (i32.const 1))) - - (local.set '$tmp (call '$eval_helper (i64.load 0 (local.get '$ptr)) (local.get '$d))) - (_if 'cond_truthy - (truthy_test (local.get '$tmp)) - (then - (generate_drop (local.get '$tmp)) - (local.set '$tmp (call '$eval_helper (i64.load 8 (local.get '$ptr)) (local.get '$d))) - (br '$cond_loop_break_ok) - ) - (else (generate_drop (local.get '$tmp))) - ) - (local.set '$len (i32.sub (local.get '$len) (i32.const 2))) - (local.set '$ptr (i32.add (local.get '$ptr) (i32.const 16))) - (br '$cond_loop) - ) - ) - (call '$print (i64.const no_true_cond_msg_val)) - (unreachable) - ) - (local.get '$tmp) - drop_p_d - )))) - ((func_idx funcs) (array (+ 1 func_idx) (concat funcs (func '$dummy '(result i64) (i64.const 0))))) - - (get_passthrough (dlambda (hash (datasi funcs memo env pectx inline_locals)) (dlet ((r (get-value-or-false memo hash))) - (if r (array r nil nil (array datasi funcs memo env pectx inline_locals)) #f)))) - - - ; This is the second run at this, and is a little interesting - ; It can return a value OR code OR an error string. An error string should be propegated, - ; unless it was expected as a possiblity, which can happen when compling a call that may or - ; may not be a Vau. When it recurses, if the thing you're currently compiling could be a value - ; but your recursive calls return code, you will likely have to swap back to code. - - ; ctx is (datasi funcs memo env pectx inline_locals) - ; return is (value? code? error? (datasi funcs memo env pectx inline_locals)) - - (let_like_inline_closure (lambda (func_value containing_env_idx) (and (comb? func_value) - (not (.comb_varadic func_value)) - (= containing_env_idx (.marked_env_id (.comb_env func_value))) - (= nil (.comb_des func_value))))) - (is_prim_function_call (lambda (c s) (and (marked_array? c) (not (.marked_array_is_val c)) (<= 2 (len (.marked_array_values c))) - (prim_comb? (idx (.marked_array_values c) 0)) (= s (.prim_comb_sym (idx (.marked_array_values c) 0)))))) - - ; Ok, we're pulling out the call stuff out of compile - ; Wrapped vs unwrapped - ; Y combinator elimination - ; Eta reduction? - ; tail call elimination - ; dynamic call unval-partial-eval branch - ; - ; Rembember to account for (dont_compile dont_lazy_env dont_y_comb dont_prim_inline dont_closure_inline) - - ; (... ) - - ; call-info will be a fairly simple pre-order traversal (looking at caller before params) - ; infer-type has to walk though cond in pairs, special handle the (and ) case, and adjust parameters for veval - ; perceus is weird, as it has to look at the head to determine how to order/combine the children, as well as an extra sub-data for the call itself (though I guess this is just part of the node data) - - ; Starting with only dynamic call unval - ; TODO: tce-data - - (call-info (rec-lambda call-info (c env pectx) (cond - ((val? c) (array nil nil pectx)) - ((and (marked_symbol? c) (.marked_symbol_is_val c)) (array nil nil pectx)) - ((marked_symbol? c) (array nil nil pectx)) - ((marked_env? c) (array nil nil pectx)) - ((prim_comb? c) (array nil nil pectx)) - ((and (marked_array? c) (.marked_array_is_val c)) (array nil nil pectx)) - ((comb? c) (array nil nil pectx)) - - ((and (marked_array? c) (let_like_inline_closure (idx (.marked_array_values c) 0) (.marked_env_id env))) (dlet ( - (func_param_values (.marked_array_values c)) - (func (idx func_param_values 0)) - ; TODO: pull errors out of here - ;(param_data (map (lambda (x) (call-info x env)) (slice func_param_values 1 -1))) - ; TODO: pull errors out of here - ; mk tmp env - ;(body_data (call-info (.comb_body func tmp_env))) - ) (array nil nil pectx))) ;(array nil (cons body_data param_data)))) - - ((is_prim_function_call c 'veval) (dlet ( - (func_param_values (.marked_array_values c)) - (num_params (- (len func_param_values) 1)) - (params (slice func_param_values 1 -1)) - ; These can't be fatal either - ;(_ (if (!= 2 num_params) (error "call to veval has != 2 params!"))) - ;(_ (if (not (marked_env? (idx params 1))) (error "call to veval has not marked_env second param"))) - - ; TODO: pull errors out of here - ;(sub_data (array nil (call-info (idx params 0) (idx params 1)) nil)) - ) (array nil nil pectx))) ;(array nil sub_data))) - - (true (dlet ( - ; obv need to handle possible dynamic calls with an additional unval side, but also be careful of infinite recursion (as we had happen on compile before) - ; due to the interaction of partial eval and unval (previously in compile) here - ; might need to check for (is_prim_function_call c 'vcond) for recursion? - - ; the basic check is is this dynamic or not, and if so (and thus we don't know the wrap level) - ; we need to - ; if not dynamic, just recurse as normal - ; assert wrap-level == 0 or == -1 - - (func_param_values (.marked_array_values c)) - (func (idx func_param_values 0)) - ; ; TODO: pull errors out of here - ; (sub_data (map (lambda (x) (call-info x env)) func_param_values)) - ; ; TODO: pull errors out of here - ; (our_data (cond ((and (comb? func) ( = (.comb_wrap_level func) 0)) nil) - ; ((and (comb? func) (!= (.comb_wrap_level func) 1)) (error "bad wrap level call-info")) ; this is a tad tricky - I wanted to just have error here, but - ; ; *concievably this is the result of wrongly evaluted code based on this - ; ; very method of prediction. Instead, we need to error here, - ; ; and have that count as erroing out of the compile. - ; ; How best should we do that, I wonder? - ; ((prim_comb? func) nil) - ; (true (dlet ( - ; ((ok x) (try_unval x (lambda (_) nil))) - ; (err (if (not ok) "couldn't unval in compile" err)) - ; ((pectx e pex) (mif err (array pectx err nil)) - ; ; x only_head env env_stack pectx indent force - ; (partial_eval_helper x false env (array nil nil) pectx 1 false)))) - ; ) nil) - ; )) - ;) (array our_data sub_data)) - ) (array nil nil pectx))) ;(array nil sub_data))) - ))) - - ; type is a bit generic, both the runtime types + length of arrays - ; - ; (array maybe_rc ) - ; - ; there are three interesting things to say about types - ; the x=type guarentee map (x has this type. i.e, constants, being after an assertion, being inside a cond branch with a true->x=type assertion - ; the x=type assertion map (x needs to have this type, else trap. Comes from calling a function with a typed parameter) - ; the true->x=type structure (if a particular value is true, than it implies that x=type. Happens based on cond branches with type/len/equality checks in contitional) - - ; call - ; -y=true->(x=type...) structure - ; -type guarentee map - ; return - ; -value type (or false) - ; -return value=true ->(x=type...) - ; -type assertion map - ; -extra data that should be passed back in (sub_results) - ; - ; - ; the cache data structure is just what it returned. Sub-calls should pass in the extra data indexed appropriately - (type_data_nil nil) - (analysis_nil nil) - (get-list-or (lambda (d k o) (dlet ((x (get-list d k))) - (mif x (idx x 1) - o)))) - (is_markable (lambda (x) (or (and (marked_symbol? x) (not (.marked_symbol_is_val x))) - (and (marked_array? x) (not (.marked_array_is_val x))) - ))) - (is_markable_idx (lambda (c i) (and (marked_array? c) (< i (len (.marked_array_values c))) (is_markable (idx (.marked_array_values c) i))))) - (mark (lambda (x) (or (and (marked_symbol? x) (not (.marked_symbol_is_val x)) (.marked_symbol_value x)) - (and (marked_array? x) (not (.marked_array_is_val x)) (.hash x)) - ))) - (mark_idx (lambda (c i) (and (marked_array? c) (< i (len (.marked_array_values c))) (mark (idx (.marked_array_values c) i))))) - (combine-list (lambda (mf a b) (dlet ( - ;(_ (true_print "going to combine " a " and " b)) - (r (cond ((= false a) b) - ((= false b) a) - (true (dlet ( - (total (concat a b)) - ;(_ (true_print " total is " total)) - ) (foldl (lambda (acc i) (dlet ( - ;(_ (true_print "looking at " i)) - ;(_ (true_print " which is " (idx total i))) - (r (concat acc - (foldl (dlambda (o_combined j) (mif (= nil o_combined) - nil - (dlet ( - (combined (idx o_combined 0)) - ;(_ (true_print " inner looking at " j)) - ;(_ (true_print " which is " (idx total j))) - ;(_ (true_print " combined currently is " combined)) - (r (mif (= (idx combined 0) (idx (idx total j) 0)) - (mif (> i j ) - (array) - (array (array (idx combined 0) - (mf (idx combined 1) (idx (idx total j) 1))))) - (array combined))) - ;(_ (true_print " r was " r)) - ) r))) - (array (idx total i)) - (range 0 (len total))))) - ;(_ (true_print "did " i " was " r)) - ) r) - ) - (array) - (range 0 (len total))))))) - ;(_ (true_print "combining " a " and " b " type maps gave us " r)) - ) r))) - (combine-type (lambda (a b) (dlet ( - ;(_ (true_print "combinging types " a " and " b)) - (r (cond ((= false a) b) - ((= false b) a) - ((and (idx a 0) (idx b 0) - (!= (idx a 0) (idx b 0))) (error "merge inequlivant types " a b)) - ((and (idx a 2) (idx b 2) - (!= (idx a 2) (idx b 2))) (error "merge inequlivant tlen " a b)) - (true (array (or (idx a 0) (idx b 0)) (and (idx a 1) (idx b 1)) (or (idx a 2) (idx b 2)))) - )) - ;(_ (true_print "combined em to " r)) - ) r))) - (infer_types (rec-lambda infer_types (c env_id implies guarentees) (cond - ((and (val? c) (int? (.val c))) (array (array 'int false false) false empty_dict-list type_data_nil)) - ((and (val? c) (= true (.val c))) (array (array 'bool false false) false empty_dict-list type_data_nil)) - ((and (val? c) (= false (.val c))) (array (array 'bool false false) false empty_dict-list type_data_nil)) - ((and (val? c) (str? (.val c))) (array (array 'str false false (len (.val c))) false empty_dict-list type_data_nil)) - ((and (marked_symbol? c) (.marked_symbol_is_val c)) (array (array 'sym false false) false empty_dict-list type_data_nil)) - ((marked_symbol? c) (array (get-list-or guarentees (.marked_symbol_value c) false) (get-list-or implies (.marked_symbol_value c) false) empty_dict-list type_data_nil)) - ((marked_env? c) (array (array 'env true false) false empty_dict-list type_data_nil)) - ((comb? c) (array (array 'comb true false) false empty_dict-list type_data_nil)) - ((prim_comb? c) (array (array 'prim_comb false) false empty_dict-list type_data_nil)) - ((and (marked_array? c) (.marked_array_is_val c)) (array (array 'arr false (len (.marked_array_values c))) false empty_dict-list type_data_nil)) - ; The type predicates (ADD ASSERTS TO THESE) - ((and (is_prim_function_call c 'array?) (is_markable_idx c 1)) (array (array 'bool false false) (put-list empty_dict-list (mark_idx c 1) (array 'arr true false)) empty_dict-list (map (lambda (x) (infer_types x env_id implies guarentees)) (.marked_array_values c)))) - ((and (is_prim_function_call c 'nil?) (is_markable_idx c 1)) (array (array 'bool false false) (put-list empty_dict-list (mark_idx c 1) (array 'arr true 0)) empty_dict-list (map (lambda (x) (infer_types x env_id implies guarentees)) (.marked_array_values c)))) - ((and (is_prim_function_call c 'bool?) (is_markable_idx c 1)) (array (array 'bool false false) (put-list empty_dict-list (mark_idx c 1) (array 'bool false false)) empty_dict-list (map (lambda (x) (infer_types x env_id implies guarentees)) (.marked_array_values c)))) - ((and (is_prim_function_call c 'env?) (is_markable_idx c 1)) (array (array 'bool false false) (put-list empty_dict-list (mark_idx c 1) (array 'env true false)) empty_dict-list (map (lambda (x) (infer_types x env_id implies guarentees)) (.marked_array_values c)))) - ((and (is_prim_function_call c 'combiner?) (is_markable_idx c 1)) (array (array 'bool false false) (put-list empty_dict-list (mark_idx c 1) (array 'comb true false)) empty_dict-list (map (lambda (x) (infer_types x env_id implies guarentees)) (.marked_array_values c)))) - ((and (is_prim_function_call c 'string?) (is_markable_idx c 1)) (array (array 'bool false false) (put-list empty_dict-list (mark_idx c 1) (array 'str true false)) empty_dict-list (map (lambda (x) (infer_types x env_id implies guarentees)) (.marked_array_values c)))) - ((and (is_prim_function_call c 'int?) (is_markable_idx c 1)) (array (array 'bool false false) (put-list empty_dict-list (mark_idx c 1) (array 'int false false)) empty_dict-list (map (lambda (x) (infer_types x env_id implies guarentees)) (.marked_array_values c)))) - ((and (is_prim_function_call c 'symbol?) (is_markable_idx c 1)) (array (array 'bool false false) (put-list empty_dict-list (mark_idx c 1) (array 'sym false false)) empty_dict-list (map (lambda (x) (infer_types x env_id implies guarentees)) (.marked_array_values c)))) - ; len case - ; either (= (len markable) number) or (= number (len markable)) - ((and (is_prim_function_call c '=) (= 3 (len (.marked_array_values c)))) (dlet ( - ((mi ni) (cond ((and (marked_array? (idx (.marked_array_values c) 1)) (is_prim_function_call (idx (.marked_array_values c) 1) 'len) (is_markable_idx (idx (.marked_array_values c) 1) 1) - (val? (idx (.marked_array_values c) 2)) (int? (.val (idx (.marked_array_values c) 2)))) (array 1 2)) - ((and (marked_array? (idx (.marked_array_values c) 2)) (is_prim_function_call (idx (.marked_array_values c) 2) 'len) (is_markable_idx (idx (.marked_array_values c) 2) 1) - (val? (idx (.marked_array_values c) 1)) (int? (.val (idx (.marked_array_values c) 1)))) (array 2 1)) - (true (array false false)))) - ) (array (array 'bool false false) - (mif mi (put-list empty_dict-list (mark_idx (idx (.marked_array_values c) mi) 1) (array false true (.val (idx (.marked_array_values c) ni)))) - false) - empty_dict-list - (map (lambda (x) (infer_types x env_id implies guarentees)) (.marked_array_values c))))) - - ; let case - ((and (marked_array? c) ;(>= 2 (len (.marked_array_values c))) - (let_like_inline_closure (idx (.marked_array_values c) 0) env_id)) (dlet ( - ; map recurse over arguments - ;(_ (true_print "entering let")) - (func (idx (.marked_array_values c) 0)) - (params (.comb_params func)) - (func_sub (infer_types func env_id implies guarentees)) - ;( _ (true_print "Pre let sub collection, implies is " implies " and guarentees is " guarentees)) - ;( _ (true_print " and params are " params)) - ( (sub_implies sub_guarentees psub_data) (foldl (dlambda ((sub_implies sub_guarentees running_sub_data) i) (dlet ((psym (idx params (- i 1))) - ((ttyp timpl assertions sub_sub_data) (infer_types (idx (.marked_array_values c) i) env_id implies guarentees)) - ) (array ;(combine-list (lambda (a b) (combine-list combine-type a b)) (put-list empty_dict-list psym timpl) sub_implies) - ;(combine-list combine-type (put-list empty_dict-list psym ttyp) sub_guarentees) - (put-list sub_implies psym timpl) - (put-list sub_guarentees psym ttyp) - (concat running_sub_data (array (array ttyp timpl assertions sub_sub_data)))))) - (array implies guarentees - ;(array func_sub) - (array) - ) (range 1 (len (.marked_array_values c))))) - ;( _ (true_print "based on inline (let) case " params " we have sub_implies " sub_implies " and sub_guarentees " sub_guarentees) ) - ((ttyp timpl assertion inl_subdata) (infer_types (.comb_body func) (.comb_id func) sub_implies sub_guarentees)) - ; remove the implication if it's about something that only exists inside the inlined function (a parameter) - ; TODO: does this have to check for env_symbol? - (timpl (mif (and timpl (in_array (idx timpl 0) params)) false timpl)) - ;( _ (true_print "final result of inline " params " is type " ttyp " and impl " timpl)) - ;(_ (true_print "exiting let")) - ) (array ttyp timpl empty_dict-list (concat (array (array ttyp timpl assertion inl_subdata)) psub_data)))) - ; cond case - ; start simply by making this only an 'and'-style recognizer - ; if (vcond p b true p) (or (vcond p b true false)) combine b's implies with p's implies - ((is_prim_function_call c 'vcond) (dlet ( - - (func_param_values (.marked_array_values c)) - (num_params (- (len func_param_values) 1)) - (params (slice func_param_values 1 -1)) - (func (idx func_param_values 0)) - ((impls sub_data) (foldl (dlambda ((impls sub_data) i) (dlet ( - ((ptyp pimpl p_assertion p_subdata) (infer_types (idx params (+ (* 2 i) 0)) env_id implies guarentees)) - ;(_ (true_print "about to combine pimpl and guarentees in cond, they are " pimpl "and " guarentees)) - ((btyp bimpl b_assertion b_subdata) (infer_types (idx params (+ (* 2 i) 1)) env_id implies (combine-list combine-type pimpl guarentees))) - ;(_ (true_print "about to combine pimpl and bimpl in cond, they are " pimpl " and " bimpl)) - (combined_impl (combine-list combine-type pimpl bimpl)) - ;(_ (true_print "combined is " combined_impl)) - ) (array (concat impls (array combined_impl)) (concat sub_data (array (array ptyp pimpl p_assertion p_subdata) (array btyp bimpl b_assertion b_subdata)))))) - (array (array) (array (infer_types func env_id implies guarentees))) - (range 0 (/ num_params 2)) - )) - - ) (mif (and (= 5 (len (.marked_array_values c))) (val? (idx (.marked_array_values c) 3)) (= true (.val (idx (.marked_array_values c) 3))) - (or (and (val? (idx (.marked_array_values c) 4)) (= false (.val (idx (.marked_array_values c) 4)))) - (= (.hash (idx (.marked_array_values c) 1)) (.hash (idx (.marked_array_values c) 4))))) - (array false (idx impls 0) empty_dict-list sub_data) - (array false false empty_dict-list sub_data)))) - - ((is_prim_function_call c 'veval) (dlet ( - (func_param_values (.marked_array_values c)) - (num_params (- (len func_param_values) 1)) - (params (slice func_param_values 1 -1)) - (_ (if (!= 2 num_params) (error "call to veval has != 2 params!"))) - (_ (if (not (marked_env? (idx params 1))) (error "call to veval has not marked_env second param"))) - - (new_env_id (.marked_env_id (idx params 1))) - - (sub_data (array (infer_types func env_id implies guarentees) - (infer_types (idx params 0) new_env_id empty_dict-list empty_dict-list) - (infer_types (idx params 1) env_id implies guarentees))) - ) (array btyp false empty_dict-list sub_data))) - - ; generic combiner calls - recurse into all - ((and (marked_array? c) (not (.marked_array_is_val c))) (dlet ( - ; this will have to gather assertions in the future - ;(_ (true_print " doing infer-types for random call ")) - (sub_results (map (lambda (x) (infer_types x env_id implies guarentees)) (.marked_array_values c))) - ;(_ (true_print " done infer-types for random call ")) - ; I belive this .hash doesn't do anything - ) (array (get-list-or guarentees (.hash c) false) false empty_dict-list sub_results))) - - ; fallthrough - (true (array false false empty_dict-list type_data_nil)) - ))) - (cached_infer_types_idx (lambda (c env_id cache i) (dlet ( - ;(_ (true_print "doing infer-types-idx for " (true_str_strip c))) - ;(_ (true_print "doing infer-types-idx i " i)) - ;(_ (true_print "doing infer-types-idx with " cache)) - ;(_ (true_print "doing infer-types-idx, cache is real? " (mif cache true false))) - ( r (mif cache (idx (idx cache 3) i) (infer_types (idx (.marked_array_values c) i) env_id empty_dict-list empty_dict-list))) - ;(_ (true_print "done infer-types-idx")) - ) r))) - (just_type (lambda (analysis_data) (idx (idx analysis_data 0) 0))) - (word_value_type? (lambda (x) (or (= 'int (idx x 0)) (= 'bool (idx x 0)) (= 'sym (idx x 0))))) - - ; - ; Used map - ; -------- - ; - ; Ok, we start at a function, and initialize our map with all of our parameters mapped to false. - ; we then traverse *backwards (only comes into play for calls, everything is a call wooo)* - ; dynamic calls are rough and we have to assume they eat everything through the env. - ; vcond has to be handled specially, starting at then end of each arm, joining with below at the - ; end of the predicate, then going backwards through the predicate. - ; - ; Later we'll look at tracking individual indexes inside of arrays - this is based on - ; type inference and very much can be path-dependent. (array destructuring should probs happen in - ; the branch where we first have the full array type+length guarenteed?) - ; - ; all uses of used_data_nil need to be re-examined - - ; psudo_perceus takes in a used_map (after-node) and an env_id (for inlining checks) and returns a used_map (before-node) and (sub_results + used_map_after_node, if it would change it) - - ; used map also needs to track env_ids for env values that are partial? - - (used_data_nil nil) - (empty_use_map false) ; used_map is (true/false>/true(for all) upper) or false - (push_used_map (lambda (used_map params) (array (foldl (lambda (m s) (put-list m s false)) empty_dict-list params) used_map))) - (pop_used_map (lambda (used_map) (idx used_map 1))) - (set_used_map (rec-lambda set_used_map (used_map s) (mif (and used_map (!= true (idx used_map 0))) - (mif (get-list (idx used_map 0) s) - (array (put-list (idx used_map 0) s true) (idx used_map 1)) - (array (idx used_map 0) (set_used_map (idx used_map 1) s))) - used_map))) - (set_all_used_map (rec-lambda set_all_used_map (used_map) (mif used_map - (array true (set_all_used_map (idx used_map 1))) - used_map))) - (get_used_map (rec-lambda get_used_map (used_map s) (mif used_map - (mif (= true (idx used_map 0)) - true - (dlet ((r (get-list (idx used_map 0) s))) - (mif r (idx r 1) - (get_used_map (idx used_map 1) s)))) - ; we treat not-found as true, as it must be inside an env, and persistent env's are cached and "used" till the end of the scope - true))) - (combine_used_maps (rec-lambda combine_used_maps (a b) (cond ((not a) b) - ((not b) a) - ((or (= true (idx a 0)) - (= true (idx b 0))) (array true (combine_used_maps (idx a 1) (idx b 1)))) - (true (array (foldl (lambda (a x) (mif (idx x 1) (put-list a (idx x 0) true) - a)) - (idx a 0) (idx b 0)) - (combine_used_maps (idx a 1) (idx b 1))))))) - - (pseudo_perceus (rec-lambda pseudo_perceus (c env_id knot_memo used_map_after) (dlet ( - ;(_ (true_print "pseudo_perceus " (true_str_strip c) " " used_map_after)) - ) (cond - ((val? c) (array used_map_after (array used_map_after))) - ((prim_comb? c) (array used_map_after (array used_map_after))) - ((and (marked_symbol? c) (.marked_symbol_is_val c)) (array used_map_after (array used_map_after))) - ((and (marked_array? c) (.marked_array_is_val c)) (array used_map_after (array used_map_after))) - ; this triggers the env access code, which will - ; traverse and realize every env until it reaches the right one, - ; which will thus consume *everything* - ((and (marked_env? c) (not (marked_env_real? c))) (array (set_all_used_map used_map_after) (array used_map_after))) - ((and (marked_env? c) (marked_env_real? c)) (array used_map_after (array used_map_after))) - ; just fixed symbol lookup to use outer_s_env instead of s_env - ; for lookups that aren't expanded out (level <= inline_level), - ; so it doesn't reify envs. This symbol *might* be outside of the current - ; env chain though, so the set used shouldn't change it if the symbol's not - ; in the current map - ; ALSO - symbol sub_data stores if this is the owning sink of the symbol (based on if it wasn't used after) - ((and (marked_symbol? c) (not (.marked_symbol_is_val c))) (array (set_used_map used_map_after (.marked_symbol_value c)) (array (not (get_used_map used_map_after (.marked_symbol_value c))) used_map_after))) - ; comb value just does its env - ((comb? c) (pseudo_perceus (.comb_env c) env_id knot_memo used_map_after)) - - ((is_prim_function_call c 'veval) (dlet ( - (func_param_values (.marked_array_values c)) - (num_params (- (len func_param_values) 1)) - (params (slice func_param_values 1 -1)) - (_ (if (!= 2 num_params) (error "call to veval has != 2 params!"))) - (_ (if (not (marked_env? (idx params 1))) (error "call to veval has not marked_env second param"))) - - (new_env_id (.marked_env_id (idx params 1))) - (body_data (pseudo_perceus (idx params 0) new_env_id knot_memo empty_use_map)) - ((used_map_pre_env env_sub_data) (pseudo_perceus (idx params 1) env_id knot_memo used_map_after)) - - ) (array used_map_pre_env (array (array used_map_pre_env used_data_nil) body_data (array used_map_pre_env env_sub_data) used_map_after)))) - - ; cond case - ((is_prim_function_call c 'vcond) (dlet ( - (func_param_values (.marked_array_values c)) - (num_params (- (len func_param_values) 1)) - (params (slice func_param_values 1 -1)) - ((used_map_pre sub_data) (foldl (dlambda ((sub_used_map_after sub_data) i) (dlet ( - ((used_map_pre_body_arm body_arm_sub_data) (pseudo_perceus (idx params (+ (* 2 i) 1)) env_id knot_memo used_map_after)) - (used_map_post_pred (combine_used_maps sub_used_map_after used_map_pre_body_arm)) - ((used_map_pre_pred pred_sub_data) (pseudo_perceus (idx params (+ (* 2 i) 0)) env_id knot_memo used_map_post_pred)) - ) (array used_map_pre_pred (concat (array (array used_map_pre_pred pred_sub_data) (array used_map_pre_body_arm body_arm_sub_data)) sub_data)))) - (array used_map_after (array used_map_after)) - (reverse_e (range 0 (/ num_params 2))) - )) - ) (array used_map_pre (cons (array used_data_nil used_map_pre) sub_data)))) - - ; generic combiner calls - recurse into all - - - ; generic call taxonomy - ; unknown - ; may take in reified env, set all to used, then do params (note will be generated as a branch, but the union of the branch will still be everything), then do func code - ; known-val or Y-combiner knot tying - ; takes in env, inlined - add all parameters to map as unused, recurse, then remove off extra env back to the smaller (but maybe modified env), then backwards through params - ; takes in env, not inlined - same as unknown - ; doesn't take in env - call itself won't do anything, move backwards through params and then func - ; - ; call needs an extra sub_data, which is before the call happens - nice to have for regular calls, key for inlined calls (with the full, un-trimmed pre-env) - ; return pre_func, (func_data, param_1_data, param_2_data, param_3_data, (pre_call maybe_inline_subdata), post_call) - - ; Ok, so three real cases, might-take-env, inline, and doesn't-take-env - - ; YES remember to check for implicits on prim comb calls - (comb_takes_de? (lambda (x l) ... - ; YES remember to check for Y-combiner recursion knot tying - (and (!= nil (.marked_array_this_rec_stop c)) (get_passthrough (idx (.marked_array_this_rec_stop c) 0) ctx)) - ; YES remember to check for let-like inlining (and (marked_array? c) (let_like_inline_closure (idx (.marked_array_values c) 0) env_id)) - ; YES remember to properly handle crazy stuff like inlining inside of veval (does that mean we have to re-pick up inside veval after all?) - ; TODO: properly handle param usage based on wrap level if unknown (based on call-info) - ; remember to think (/modify appropriately) about TCE - I think it's fine to have it act like a normal call? - ((and (marked_array? c) (not (.marked_array_is_val c))) (dlet ( - ; check func first for val or not & if val if it uses de (comb that uses de, prim_comb that takes it) - ; if not, then full white-out first/'last' at call - ; then backwards through parameters - ; then backwards through func if not val - (func_param_values (.marked_array_values c)) - (num_params (- (len func_param_values) 1)) - (params (slice func_param_values 1 -1)) - (func (idx func_param_values 0)) - ((used_map_pre_call full_used_map_pre_call maybe_inline_subdata do_func) (cond ((let_like_inline_closure func env_id) (dlet ( - (inl_used_map_after (push_used_map used_map_after (.comb_params func))) - ((full_pre_inl_used_map inl_subdata) (pseudo_perceus (.comb_body func) - (.comb_id func) - knot_memo - inl_used_map_after)) - ) (array (pop_used_map full_pre_inl_used_map) - full_pre_inl_used_map - (array inl_subdata inl_used_map_after) - false))) - ((or (and (or (prim_comb? func) (comb? func)) (not (comb_takes_de? func num_params))) - (and (!= nil (.marked_array_this_rec_stop c)) - (get-value-or-false knot_memo (idx (.marked_array_this_rec_stop c) 0)) - (extract_func_usesde (get-value-or-false knot_memo (idx (.marked_array_this_rec_stop c) 0))))) - (array used_map_after used_map_after used_data_nil false)) - (true (dlet ((whiteout (set_all_used_map used_map_after))) (array whiteout whiteout used_data_nil true))) - )) - ((used_map_pre_params sub_results) (foldl (dlambda ((used_map_after_param sub_data) param) (dlet ( - ((used_map_pre_param param_sub_data) (pseudo_perceus param env_id knot_memo used_map_after_param)) - ) (array used_map_pre_param (cons (array used_map_pre_param param_sub_data) sub_data)))) - (array used_map_pre_call (array (array full_used_map_pre_call maybe_inline_subdata 'thats_subdata) used_map_after)) - (reverse_e params))) - ((used_map_pre_func func_sub_data) (mif do_func - (pseudo_perceus func env_id knot_memo used_map_pre_params) - (array used_map_pre_params used_data_nil))) - ) (array used_map_pre_func (cons (array used_map_pre_func func_sub_data) sub_results)))) - - ; fallthrough - (true (array (error "Shouldn't happen, missing case for pseudo_perceus: " (true_str_strip c)))) - )))) - (cached_pseudo_perceus_sym_borrowed (lambda (used_map_sub_data) (idx used_map_sub_data 0))) - (pseudo_perceus_just_sub_idx (lambda (used_map_sub_data i) (dlet ( - ;(_ (true_print "doing cached-pseudo-perceus-idx for " (true_str_strip c))) - ;(_ (true_print "doing cached-pseudo-perceus-idx i " i " " used_map_sub_data)) - ( r (mif used_map_sub_data (idx (idx used_map_sub_data i) 1) (error "pseudo perceus wasn't cached"))) - ;(_ (true_print "done cached-pseudo-perceus-idx")) - ) r))) - (pseudo_perceus_just_inline_data (lambda (used_map_sub_data) (idx (pseudo_perceus_just_sub_idx used_map_sub_data -2) 0))) - - (borrow_nil nil) - (borrow? (rec-lambda borrow? (c b env_id used_map_sub_data) (dlet ( - ;(_ (true_print "doing borrow? " b " for " (true_str_strip c))) - (r - (cond - ((val? c) (array b borrow_nil)) - ((prim_comb? c) (array b borrow_nil)) - ((and (marked_symbol? c) (.marked_symbol_is_val c)) (array b borrow_nil)) - ((and (marked_array? c) (.marked_array_is_val c)) (array b borrow_nil)) - ; no matter if env is real or not, it's borrowed, - ; as it will be cached for the length of the function - ((marked_env? c) (array b borrow_nil)) ; I feel like all of these value ones but esp this one should be true instead of b? must-be-borrowed - ((and (marked_symbol? c) (not (.marked_symbol_is_val c))) (array (and b (not (cached_pseudo_perceus_sym_borrowed used_map_sub_data))) borrow_nil)) - ; comb value just does its env - ((comb? c) (borrow? (.comb_env c) b env_id used_map_sub_data)) - - ; an array idx can be borrowed if its array can - ((is_prim_function_call c 'idx) (dlet ( - ((array_borrowed array_sub_data) (borrow? (idx (.marked_array_values c) 1) b env_id (pseudo_perceus_just_sub_idx used_map_sub_data 1))) - (idx_data (borrow? (idx (.marked_array_values c) 2) true env_id (pseudo_perceus_just_sub_idx used_map_sub_data 2))) - ) (array array_borrowed (array borrow_nil (array array_borrowed array_sub_data) idx_data)))) - - ; len returns an int, so it can be anything, - ; and we'd like to borrow it's array (or string) - ((is_prim_function_call c 'len) (array b (array borrow_nil (borrow? (idx (.marked_array_values c) 1) true env_id (pseudo_perceus_just_sub_idx used_map_sub_data 1))))) - ((is_prim_function_call c 'concat) (array false (map (lambda (i) (borrow? (idx (.marked_array_values c) i) true env_id (pseudo_perceus_just_sub_idx used_map_sub_data i))) (range 0 (len (.marked_array_values c)))))) - ((is_prim_function_call c '=) (array b (map (lambda (i) (borrow? (idx (.marked_array_values c) i) true env_id (pseudo_perceus_just_sub_idx used_map_sub_data i))) (range 0 (len (.marked_array_values c)))))) - ; + and - are kinda hacks until we're sure that both - ; if it konws that a param is a non-rc it won't dup it - ; assertions, flowing from these very opreations, - ; make the pram an int (and non-rc) - ((is_prim_function_call c '+) (array b (map (lambda (i) (borrow? (idx (.marked_array_values c) i) true env_id (pseudo_perceus_just_sub_idx used_map_sub_data i))) (range 0 (len (.marked_array_values c)))))) - ((is_prim_function_call c '-) (array b (map (lambda (i) (borrow? (idx (.marked_array_values c) i) true env_id (pseudo_perceus_just_sub_idx used_map_sub_data i))) (range 0 (len (.marked_array_values c)))))) - ((is_prim_function_call c 'array?) (array b (map (lambda (i) (borrow? (idx (.marked_array_values c) i) true env_id (pseudo_perceus_just_sub_idx used_map_sub_data i))) (range 0 (len (.marked_array_values c)))))) - ((is_prim_function_call c 'array) (array false (map (lambda (i) (borrow? (idx (.marked_array_values c) i) false env_id (pseudo_perceus_just_sub_idx used_map_sub_data i))) (range 0 (len (.marked_array_values c)))))) - - ((is_prim_function_call c 'veval) (dlet ( - (func_param_values (.marked_array_values c)) - (num_params (- (len func_param_values) 1)) - (params (slice func_param_values 1 -1)) - (_ (if (!= 2 num_params) (error "call to veval has != 2 params!"))) - (_ (if (not (marked_env? (idx params 1))) (error "call to veval has not marked_env second param"))) - - (new_env_id (.marked_env_id (idx params 1))) - ((body_borrowed body_sub_data) (borrow? (idx params 0) b new_env_id (pseudo_perceus_just_sub_idx used_map_sub_data 1))) - ((env_borrowed env_sub_data) (borrow? (idx params 1) true env_id (pseudo_perceus_just_sub_idx used_map_sub_data 2))) - ) (array body_borrowed (array borrow_nil (array body_borrowed body_sub_data) (array env_borrowed env_sub_data))))) - - ; cond case - ((is_prim_function_call c 'vcond) (dlet ( - (func_param_values (.marked_array_values c)) - (num_params (- (len func_param_values) 1)) - (params (slice func_param_values 1 -1)) - ((borrowed sub_data) (foldl (dlambda ((borrowed sub_data) i) (dlet ( - (pred_data (borrow? (idx params (+ (* 2 i) 0)) true env_id (pseudo_perceus_just_sub_idx used_map_sub_data (+ (* 2 i) 1)))) - ((arm_borrowed arm_sub_data) (borrow? (idx params (+ (* 2 i) 1)) b env_id (pseudo_perceus_just_sub_idx used_map_sub_data (+ (* 2 i) 2)))) - ) (array (and borrowed arm_borrowed) (concat (array pred_data (array arm_borrowed arm_sub_data)) sub_data)))) - (array b (array)) - (range 0 (/ num_params 2)) - )) - ) (array borrowed sub_data))) - - ; call taxonomy a bit simpler this time - if it's not already special cased, it's either an inline or it's owned - ; This also has to be adjusted based on possibly dynamic calls with unknown wrap level - ((and (marked_array? c) (not (.marked_array_is_val c))) (dlet ( - (func_param_values (.marked_array_values c)) - (num_params (- (len func_param_values) 1)) - (params (slice func_param_values 1 -1)) - (func (idx func_param_values 0)) - ;(_ (true_print "doing a borrow call")) - - ) (mif (let_like_inline_closure func env_id) - (dlet ( - ;(_ (true_print " doing a borrow inline!")) - (body (borrow? (.comb_body func) b (.comb_id func) (pseudo_perceus_just_inline_data used_map_sub_data))) - ;(_ (true_print " did body!")) - ; TODO: - ; Check perceus to see if params are ever used, if not, get rid early - - (param_subs (map (lambda (i) (borrow? (idx (.marked_array_values c) i) false env_id (pseudo_perceus_just_sub_idx used_map_sub_data i))) (range 1 (len (.marked_array_values c))))) - ;(_ (true_print " did params")) - ) (array (idx body 0) (cons body param_subs))) - (array false (map (lambda (i) (borrow? (idx (.marked_array_values c) i) false env_id (pseudo_perceus_just_sub_idx used_map_sub_data i))) (range 0 (len (.marked_array_values c)))))))) - - ; fallthrough - (true (array (error "Shouldn't happen, missing case for borrow? " (true_str_strip c)))) - )) - ;(_ (true_print "done borrow!")) - ) r))) - - (function-analysis (lambda (c memo pectx) (dlet ( - - ((wrap_level env_id de? se variadic params body) (.comb c)) - (full_params (concat params (mif de? (array de?) (array)))) - - (inner_env (make_tmp_inner_env params de? se env_id)) - - ((call_info call_err pectx) (call-info body inner_env pectx)) - (analysis_err call_err) - - (inner_type_data (infer_types body env_id empty_dict-list empty_dict-list)) - ((used_map_before used_map_sub_data) (pseudo_perceus body env_id memo (push_used_map empty_use_map full_params))) - ((borrowed borrow_sub_data) (borrow? body false env_id used_map_sub_data)) - (_ (mif borrowed (error "body hast to be borrowed? " borrowed " " (true_str_strip body)))) - - (inner_analysis_data (array inner_type_data used_map_sub_data call_info)) - - ) (array inner_analysis_data analysis_err pectx)))) - - (cached_analysis_idx (lambda (c env_id cache i) (dlet ( - ;(_ (true_print "doing infer-types-idx for " (true_str_strip c))) - ;(_ (true_print "doing infer-types-idx i " i)) - ;(_ (true_print "doing infer-types-idx with " cache)) - (_ (true_print "doing infer-types-idx, cache is real? " (mif cache true false))) - - ( t (cached_infer_types_idx c env_id (mif cache (idx cache 0) type_data_nil) i)) - ;( t (cached_infer_types_idx c env_id (idx cache 0) i)) - ;( p (mif cache (pseudo_perceus_just_sub_idx (idx cache 1) i) nil)) - ( p nil ) - ( c nil ) - - ;(_ (true_print "done infer-types-idx")) - ) (array t p c)))) - - - (compile-inner (rec-lambda compile-inner (ctx c need_value inside_veval outer_s_env_access_code s_env_access_code inline_level tce_data analysis_data) (cond - ((val? c) (dlet ((v (.val c))) - (cond ((int? v) (array (mk_int_value v) nil nil ctx)) - ((= true v) (array true_val nil nil ctx)) - ((= false v) (array false_val nil nil ctx)) - ((str? v) (dlet ( ((datasi funcs memo env pectx inline_locals) ctx) - ((datasi memo str_val) (compile-string-val datasi memo v)) - ) (array str_val nil nil (array datasi funcs memo env pectx inline_locals)))) - (true (error (str "Can't compile impossible value " v)))))) - ((marked_symbol? c) (cond ((.marked_symbol_is_val c) (dlet ( ((datasi funcs memo env pectx inline_locals) ctx) - ((datasi memo symbol_val) (compile-symbol-val datasi memo (.marked_symbol_value c))) - ) (array symbol_val nil nil (array datasi funcs memo env pectx inline_locals)))) - - - (true (dlet ( ((datasi funcs memo env pectx inline_locals) ctx) - ; not a recoverable error, so just do here - (_ (if (= nil env) (error "nil env when trying to compile a non-value symbol"))) - - - (lookup_helper (rec-lambda lookup-recurse (dict key i code level) (cond - ((and (= i (- (len dict) 1)) (= nil (idx dict i))) (array nil (str "for code-symbol lookup, couldn't find " key))) - ((= i (- (len dict) 1)) (lookup-recurse (.env_marked (idx dict i)) key 0 (mif (or inside_veval (> level inline_level)) (i64.load 16 (extract_ptr_code code)) code) (+ level 1))) - ((= key (idx (idx dict i) 0)) (if (and (not inside_veval) (<= level inline_level)) (dlet ((s (mif (!= inline_level level) - (str-to-symbol (concat (str (- inline_level - level)) - (get-text key))) - key)) - ) (array (local.get s) nil)) - (array (i64.load (* 8 i) (extract_ptr_code (i64.load 8 (extract_ptr_code code)))) nil))) - (true (lookup-recurse dict key (+ i 1) code level))))) - - - ((val err) (lookup_helper (.env_marked env) (.marked_symbol_value c) 0 (mif inside_veval s_env_access_code outer_s_env_access_code) 0)) - (err (mif err (str "got " err ", started searching in " (str_strip env)) (if need_value (str "needed value, but non val symbol " (.marked_symbol_value c)) nil))) - (result (mif val (generate_dup val))) - ) (array nil result err (array datasi funcs memo env pectx inline_locals)))))) - - - - ((marked_array? c) (if (.marked_array_is_val c) (or (get_passthrough (.hash c) ctx) - (dlet ((actual_len (len (.marked_array_values c)))) - (if (= 0 actual_len) (array nil_val nil nil ctx) - (dlet ( ((comp_values err ctx) (foldr (dlambda (x (a err ctx)) (dlet (((v c e ctx) (compile-inner ctx x need_value inside_veval outer_s_env_access_code s_env_access_code inline_level nil analysis_nil))) - (array (cons (mod_fval_to_wrap v) a) (or (mif err err false) (mif e e false) (mif c (str "got code " c) false)) ctx))) (array (array) nil ctx) (.marked_array_values c))) - ) (mif err (array nil nil (str err ", from an array value compile " (str_strip c)) ctx) (dlet ( - ((datasi funcs memo env pectx inline_locals) ctx) - ((c_loc c_len datasi) (alloc_data (apply concat (map i64_le_hexify comp_values)) datasi)) - (result (mk_array_value actual_len c_loc)) - (memo (put memo (.hash c) result)) - ) (array result nil nil (array datasi funcs memo env pectx inline_locals)))))))) - - ; This is the other half of where we notice & tie up recursion based on partial eval's noted rec-stops - ; Other half is below in comb compilation - (or (and (not dont_y_comb) (!= nil (.marked_array_this_rec_stop c)) (get_passthrough (idx (.marked_array_this_rec_stop c) 0) ctx)) - (if need_value (array nil nil (str "errr, needed value and was call " (str_strip c)) ctx) - (if (= 0 (len (.marked_array_values c))) (array nil nil (str "errr, empty call array" (str_strip c)) ctx) - (dlet ( - - ; This can weirdly cause infinate recursion on the compile side, if partial_eval - ; returns something that, when compiled, will cause partial eval to return that thing again. - ; Partial eval won't recurse infinately, since it has memo, but it can return something of that - ; shape in that case which will cause compile to keep stepping. - - ((datasi funcs memo env pectx inline_locals) ctx) - - (func_param_values (.marked_array_values c)) - (num_params (- (len func_param_values) 1)) - (params (slice func_param_values 1 -1)) - (func_value (idx func_param_values 0)) - (_ (true_print "about to get cached_infer_types_idx for call before checking for 'idx")) - ;(_ (true_print " cache is " type_data)) - (parameter_subs (map (lambda (i) (cached_analysis_idx c (.marked_env_id env) analysis_data i)) (range 1 (len func_param_values)))) - (parameter_types (map just_type parameter_subs)) - ; used_data HERE - - ;(_ (true_print "parameter types " parameter_types)) - ;(_ (true_print "parameter subs " parameter_subs)) - - (compile_params (lambda (unval_and_eval ctx cond_tce) - (foldr (dlambda (x (a err ctx i)) (dlet ( - - ;(_ (true_print "compile param with unval?" unval_and_eval " " (true_str_strip x))) - - ((datasi funcs memo env pectx inline_locals) ctx) - ((x err ctx) (mif err (array nil err ctx) - (if (not unval_and_eval) (array x err ctx) - (dlet ( - ((ok x) (try_unval x (lambda (_) nil))) - (err (if (not ok) "couldn't unval in compile" err)) - - ((pectx e pex) (cond ((!= nil err) (array pectx err nil)) - (true (partial_eval_helper x false env (array nil nil) pectx 1 false)))) - - (ctx (array datasi funcs memo env pectx inline_locals)) - - ) (array (mif e x pex) err ctx))))) - ((datasi funcs memo env pectx inline_locals) ctx) - (memo (put memo (.hash c) 'RECURSE_FAIL)) - (ctx (array datasi funcs memo env pectx inline_locals)) - ;(_ (true_print "matching up compile-inner " (true_str_strip x) " with " (idx parameter_subs i))) - ((val code err ctx) (mif err (array nil nil err ctx) - (compile-inner ctx x false inside_veval outer_s_env_access_code s_env_access_code inline_level - ; 0 b/c foldr - ; count from end - (mif (and (= 0 (% i 2)) cond_tce) - tce_data - nil) - ; if we're unvaling, our old cache for type data is bad - ; TODO - we should be able to recover for this - (mif unval_and_eval analysis_nil - (idx parameter_subs (- num_params i 1))) - ))) - ((datasi funcs memo env pectx inline_locals) ctx) - (memo (put memo (.hash c) 'RECURSE_OK)) - ) (array (cons (mif val (i64.const (mod_fval_to_wrap val)) code) a) err ctx (+ i 1)))) - - (array (array) nil ctx 0) params))) - (wrap_param_codes (lambda (param_codes) (concat (call '$malloc (i32.const (* 8 (len param_codes)))) - ;(apply concat param_codes) - (flat_map (lambda (i) (concat (local.tee '$param_ptr) - (i64.store (* i 8) (local.get '$param_ptr) (idx param_codes i)))) - (range 0 (len param_codes))) - (local.set '$param_ptr) - ))) - - - (wrap_level (if (or (comb? func_value) (prim_comb? func_value)) (.any_comb_wrap_level func_value) nil)) - ; I don't think it makes any sense for a function literal to have wrap > 0 - (_ (if (and (!= nil wrap_level) (> wrap_level 0)) (error "call to function literal has wrap >0"))) - - ;; Test for the function being a constant to inline - ;; Namely, vcond (also veval!) - (single_num_type_check (lambda (code) (concat (local.set '$prim_tmp_a code) - (_if '$not_num - (is_not_type_code int_tag (local.get '$prim_tmp_a)) - (then (local.set '$prim_tmp_a (call '$debug (call '$array1_alloc (local.get '$prim_tmp_a)) (i64.const nil_val) (i64.const nil_val)))) - ) - (local.get '$prim_tmp_a)))) - (gen_numeric_impl (lambda (operation) - (dlet (((param_codes err ctx _) (compile_params false ctx false))) - (mif err (array nil nil (str err " from function params in call to comb " (str_strip c)) ctx) - (array nil (foldl (lambda (running_code val_code) (operation running_code - (single_num_type_check val_code))) - (single_num_type_check (idx param_codes 0)) - (slice param_codes 1 -1)) nil ctx))) - )) - - (gen_pred_impl (lambda (tag needs_drop) - (dlet (((param_codes err ctx _) (compile_params false ctx false)) - (_ (true_print "doing an array? inline!")) - ) - (mif err (array nil nil (str err " from function params in call to comb " (str_strip c)) ctx) - (array nil (concat - (idx param_codes 0) - (local.set '$prim_tmp_a) - (_if '$is_pred '(result i64) - (i64.eq (i64.const tag) (i64.and (i64.const type_mask) (local.get '$prim_tmp_a))) - (then (i64.const true_val)) - (else (i64.const false_val)) - ) - (mif needs_drop (generate_drop (local.get '$prim_tmp_a)) (array)) - ) nil ctx))) - )) - (gen_cmp_impl (lambda (lt_case eq_case gt_case) - (dlet (((param_codes err ctx _) (compile_params false ctx false))) - (mif err (array nil nil (str err " from function params in call to comb " (str_strip c)) ctx) - (array nil - (concat - (apply concat param_codes) - (i64.const true_val) - (flat_map (lambda (i) (concat - (local.set '$prim_tmp_a) - (local.set '$prim_tmp_b) - (local.set '$prim_tmp_c) - (call '$comp_helper_helper (local.get '$prim_tmp_c) - (local.get '$prim_tmp_b) - (i64.const lt_case) - (i64.const eq_case) - (i64.const gt_case)) - (local.set '$prim_tmp_a (i64.and (local.get '$prim_tmp_a))) - (local.get '$prim_tmp_c) - (local.get '$prim_tmp_a) - )) - (range 1 num_params)) - (_drop) (_drop) (local.get '$prim_tmp_a) - ) - nil ctx))) - )) - ) (cond - ((and (prim_comb? func_value) (= (.prim_comb_sym func_value) 'veval)) (dlet ( - - (_ (if (!= 2 (len params)) (error "call to veval has != 2 params!"))) - ((datasi funcs memo env pectx inline_locals) ctx) - ((val code err (datasi funcs memo ienv pectx inline_locals)) (compile-inner (array datasi funcs memo (idx params 1) pectx inline_locals) (idx params 0) false true (local.get '$s_env) (local.get '$s_env) 0 nil analysis_nil)) - (ctx (array datasi funcs memo env pectx inline_locals)) - ; If it's actual code, we have to set and reset s_env - ((code env_err ctx) (mif code (dlet ( - ((env_val env_code env_err ctx) (compile-inner ctx (idx params 1) false inside_veval outer_s_env_access_code s_env_access_code inline_level nil analysis_nil)) - (full_code (concat (local.get '$s_env) - (local.set '$s_env (mif env_val (i64.const env_val) env_code)) - code - (local.set '$tmp) - ; DROP s_env??? - (local.set '$s_env) - (local.get '$tmp))) - ) (array full_code env_err ctx)) - (array code nil ctx))) - ) (array (mod_fval_to_wrap val) code (mif err err env_err) ctx))) - - ((and (prim_comb? func_value) (= (.prim_comb_sym func_value) 'vcond)) - (dlet ( - ((param_codes err ctx _) (compile_params false ctx true)) - ) - (mif err (array nil nil (str err " from function params in call to comb " (str_strip c)) ctx) - (array nil ((rec-lambda recurse (codes i) (cond - ((< i (- (len codes) 1)) (_if '_cond_flat '(result i64) - (truthy_test (idx codes i)) - (then (idx codes (+ i 1))) - (else (recurse codes (+ i 2))) - )) - ((= i (- (len codes) 1)) (error "compiling bad length comb")) - (true (unreachable)) - )) param_codes 0) err ctx)))) - - - ((and (not dont_prim_inline) (prim_comb? func_value) (= (.prim_comb_sym func_value) '+)) (gen_numeric_impl i64.add)) - ((and (not dont_prim_inline) (prim_comb? func_value) (= (.prim_comb_sym func_value) '-)) (gen_numeric_impl i64.sub)) - ((and (not dont_prim_inline) (prim_comb? func_value) (= (.prim_comb_sym func_value) '=)) (mif (any_in_array word_value_type? parameter_types) - (dlet (((param_codes err ctx _) (compile_params false ctx false))) - (mif err (array nil nil (str err " from function params in call to comb " (str_strip c)) ctx) - (dlet ( - (_ (true_print "Doing the better = " parameter_types)) - (word_value_idx (any_in_array word_value_type? parameter_types)) - (pparameter_types (reverse_e (concat (slice parameter_types 0 word_value_idx) - (slice parameter_types (+ 1 word_value_idx) -1) - (array (idx parameter_types word_value_idx))))) - (_ (true_print "made reverse")) - (eq_code - (_if '$eq_result '(result i64) - (concat - (apply concat (concat (slice param_codes 0 word_value_idx) - (slice param_codes (+ 1 word_value_idx) -1) - (array (idx param_codes word_value_idx)))) - (local.set '$prim_tmp_a) - (local.set '$prim_tmp_b) - (local.set '$prim_tmp_d (i64.eq (local.get '$prim_tmp_a) (local.get '$prim_tmp_b))) - (mif (word_value_type? (idx pparameter_types 1)) (array) (generate_drop (local.get '$prim_tmp_b))) - (flat_map (lambda (i) (concat - (local.set '$prim_tmp_b) - (local.set '$prim_tmp_d (i64.and (local.get '$prim_tmp_d) (i64.eq (local.get '$prim_tmp_a) (local.get '$prim_tmp_b)))) - (mif (word_value_type? (idx pparameter_types i)) (array) (generate_drop (local.get '$prim_tmp_b))) - )) - (range 2 num_params)) - (local.get '$prim_tmp_d) - ) - (then (i64.const true_val)) - (else (i64.const false_val))) - ) - (_ (true_print "made eq_code")) - ) (array nil eq_code nil ctx)))) - (dlet ((_ (true_print "missed better = " parameter_types))) (gen_cmp_impl false_val true_val false_val)))) - - ((and (not dont_prim_inline) (prim_comb? func_value) (= (.prim_comb_sym func_value) 'array?) (= 1 num_params)) (gen_pred_impl array_tag true)) - - ; inline array pretty much always - array does nothing but return it's parameter array anyway! - ((and (not dont_prim_inline) (prim_comb? func_value) (= (.prim_comb_sym func_value) 'array)) (dlet ( - (_ (true_print "inlining array ARRAY!!!")) - ((param_codes err ctx _) (compile_params false ctx false)) - (code (mif err nil - (concat (wrap_param_codes param_codes) - (mk_array_code_rc_const_len (len param_codes) (local.get '$param_ptr))))) - ) (array nil code err ctx))) - - ; inline idx if we have the type+len of array and idx is a constant - ((and (not dont_prim_inline) (prim_comb? func_value) (= (.prim_comb_sym func_value) 'idx) (= 2 num_params) - (idx parameter_types 0) (= 'arr (idx (idx parameter_types 0) 0)) (idx (idx parameter_types 0) 2) - (idx parameter_types 1) (= 'int (idx (idx parameter_types 1) 0))) - (val? (idx params 1)) (dlet ( - (_ (true_print "inlining idx IDX!!")) - ((param_codes err ctx _) (compile_params false ctx false)) - (array_len (idx (idx parameter_types 0) 2)) - (index (.val (idx params 1))) - (index (mif (< index 0) (+ index array_len) index)) - ((code err) (mif (and (>= index 0) (< index array_len)) - (array (concat (local.set '$prim_tmp_a (idx param_codes 0)) - (generate_dup (i64.load (* 8 index) (extract_ptr_code (local.get '$prim_tmp_a)))) - (generate_drop (local.get '$prim_tmp_a))) - nil) - (array nil (true_str "bad constant offset into typed array")))) - ) (array nil code err ctx))) - ; inline len if we have the type of array - ((and (not dont_prim_inline) (prim_comb? func_value) (= (.prim_comb_sym func_value) 'len) (= 1 num_params) - (idx parameter_types 0) (= 'arr (idx (idx parameter_types 0) 0))) (dlet ( - (_ (true_print "inlining len LEN!!!")) - ((param_codes err ctx _) (compile_params false ctx false)) - (code (mif err nil - (concat (local.set '$prim_tmp_a (idx param_codes 0)) - (extract_size_code_to_int (local.get '$prim_tmp_a)) - (generate_drop (local.get '$prim_tmp_a))))) - ) (array nil code err ctx))) - - - - ; User inline - ((and (not dont_closure_inline) (let_like_inline_closure func_value (.marked_env_id env))) (dlet ( - ; To inline, we add all of the parameters + inline_level + 1 to the current functions additional symbols - ; as well as a new se + inline_level + 1 symbol - ; fill them with the result of evaling the parameters now - ; inline the body's compiled code, called with an updated s_env_access_code - ; drop all of the parameters - ;(_ (true_print "INLINEING")) - (_ (true_print "INLINEING " (.comb_params func_value))) - (new_inline_level (+ inline_level 1)) - (comb_params (.comb_params func_value)) - (additional_param_symbols (map (lambda (x) (str-to-symbol (concat (str new_inline_level) (get-text x)))) comb_params)) - (new_s_env_symbol (str-to-symbol (concat "$" (str new_inline_level) "_inline_se"))) - (additional_symbols (cons new_s_env_symbol additional_param_symbols)) - (_ (true_print "additional symbols " additional_symbols)) - - ((param_codes first_params_err ctx _) (compile_params false ctx false)) - - (inner_env (make_tmp_inner_env comb_params (.comb_des func_value) (.comb_env func_value) (.comb_id func_value))) - ((params_vec _ _ ctx) (compile-inner ctx (marked_array true false nil (map (lambda (k) (marked_symbol nil k)) comb_params) nil) true false outer_s_env_access_code s_env_access_code 0 nil analysis_nil)) - (new_get_s_env_code (_if '$have_s_env '(result i64) - (i64.ne (i64.const nil_val) (local.get new_s_env_symbol)) - (then (local.get new_s_env_symbol)) - (else (local.tee new_s_env_symbol (call '$env_alloc (i64.const params_vec) - - (local.set '$tmp_ptr (call '$malloc (i32.const (* 8 (len additional_param_symbols))))) - (flat_map (lambda (i) (i64.store (* i 8) (local.get '$tmp_ptr) - (generate_dup (local.get (idx additional_param_symbols i))))) - (range 0 (len additional_param_symbols))) - (mk_array_code_rc_const_len (len additional_param_symbols) (local.get '$tmp_ptr)) - (generate_dup s_env_access_code))) - ))) - ((datasi funcs memo env pectx inline_locals) ctx) - (_ (true_print "Doing inline compile-inner " comb_params)) - ((inner_value inner_code err ctx) (compile-inner (array datasi funcs memo inner_env pectx inline_locals) - (.comb_body func_value) false false outer_s_env_access_code new_get_s_env_code new_inline_level tce_data - (cached_analysis_idx c (.comb_id func_value) analysis_data 0) - )) - (_ (true_print "Done inline compile-inner " comb_params)) - (inner_code (mif inner_value (i64.const inner_value) inner_code)) - (result_code (concat - (apply concat param_codes) - (flat_map (lambda (i) (local.set (idx additional_param_symbols i))) (range (- (len additional_param_symbols) 1) -1)) - (local.set new_s_env_symbol (i64.const nil_val)) - inner_code - (flat_map (lambda (i) (generate_drop (local.get (idx additional_param_symbols i)))) (range (- (len additional_param_symbols) 1) -1)) - (generate_drop (local.get new_s_env_symbol)) - (local.set new_s_env_symbol (i64.const nil_val)) - )) - ; Don't overwrite env with what was our inner env! Env is returned as part of context to our caller! - ((datasi funcs memo _was_inner_env pectx inline_locals) ctx) - (final_result (array nil result_code (mif first_params_err first_params_err err) (array datasi funcs memo env pectx (concat inline_locals additional_symbols)))) - (_ (true_print "DONE INLINEING " (.comb_params func_value))) - - ) final_result)) - ; Normal call - ; - static call (based on getting func_val) - ; +statically knowable params - ; * s_de/s_no_de & s_wrap=1/s_wrap=2 - ; +dynamic params - ; * s_de/s_no_de & s_wrap=1/s_wrap=2 - ; - dynamic call (got func_code) - ; + d_de/d_no_de & d_wrap=1/d_wrap=2 - (true (dlet ( - ((param_codes first_params_err ctx _) (compile_params false ctx false)) - ((func_val func_code func_err ctx) (compile-inner ctx func_value false inside_veval outer_s_env_access_code s_env_access_code inline_level nil analysis_nil)) - ((unval_param_codes err ctx _) (compile_params true ctx false)) - ; Generates *tons* of text, needs to be different. Made a 200KB binary 80MB - ;((bad_unval_params_msg_val _ _ ctx) (compile-inner ctx (marked_val (str "error was with unval-evaling parameters of " (true_str_strip c) " " err)) true inside_veval outer_s_env_access_code s_env_access_code inline_level analysis_nil)) - ((bad_unval_params_msg_val _ _ ctx) (compile-inner ctx (marked_val "error was with unval-evaling parameters of ") true inside_veval outer_s_env_access_code s_env_access_code inline_level nil analysis_nil)) - (wrap_0_inner_code (apply concat param_codes)) - (wrap_0_param_code (wrap_param_codes param_codes)) - (wrap_1_inner_code - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ; Since we're not sure if it's going to be a vau or not, - ; this code might not be compilable, so we gracefully handle - ; compiler errors and instead emit code that throws the error if this - ; spot is ever reached at runtime. - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - (mif err (concat (call '$print (i64.const bad_not_vau_msg_val)) - (call '$print (i64.const bad_unval_params_msg_val)) - (unreachable)) - (apply concat unval_param_codes))) - (wrap_1_param_code (mif err wrap_1_inner_code - (wrap_param_codes unval_param_codes))) - (wrap_x_param_code (concat - ; TODO: Handle other wrap levels - (call '$print (i64.const weird_wrap_msg_val)) - (unreachable))) - - ((source_code ctx) (mif (.marked_array_source c) (dlet (((code _ _ ctx) (compile-inner ctx (.marked_array_source c) true inside_veval outer_s_env_access_code s_env_access_code inline_level nil analysis_nil)) - ) (array code ctx)) - (array bad_source_code_msg_val ctx))) - (_ (mif (nil? source_code) (error "nil source codepost compile! pre was " (.marked_array_source c)))) - ;((source_code ctx) (mif (nil? source_code) (array bad_source_code_msg_val ctx) (array source_code ctx))) - ((result_code ctx) (mif func_val - (dlet ( - (unwrapped (extract_unwrapped func_val)) - (func_idx (- (extract_func_idx func_val) func_id_dynamic_ofset (- 0 num_pre_functions) 1)) - (wrap_level (extract_func_wrap func_val)) - (needs_denv (extract_func_usesde func_val)) - ((tce_idx tce_full_params) (mif tce_data tce_data (array nil nil))) - (tce_able (and unwrapped (= tce_idx (extract_func_idx func_val)))) - (s_env_val (extract_func_env func_val)) - ((datasi funcs memo env pectx inline_locals) ctx) - (ctx (mif tce_able - (dlet ( - (inline_locals (mif (in_array '___TCE___ inline_locals) - inline_locals - (cons '___TCE___ inline_locals))) - (ctx (array datasi funcs memo env pectx inline_locals)) - ) ctx) - ctx)) - ) - (array (concat - (front_half_stack_code (i64.const source_code) (generate_dup s_env_access_code)) - ;params - (mif unwrapped - ; unwrapped, can call directly with parameters on wasm stack - (concat - (cond ((= 0 wrap_level) wrap_0_inner_code) - ((= 1 wrap_level) wrap_1_inner_code) - (true wrap_x_param_code)) - ;dynamic env (is caller's static env) - ; hay, we can do this statically! the static version of the dynamic check - (mif needs_denv - (generate_dup s_env_access_code) - (array)) - (mif tce_able - (concat - (generate_drop (local.get '$s_env)) - (local.set '$s_env (i64.const nil_val)) - (generate_drop (local.get '$outer_s_env)) - (local.set '$outer_s_env (i64.const s_env_val)) - (flat_map (lambda (i) (mif (= i '___TCE___) (array) - (concat (generate_drop (local.get i)) - (local.set i (i64.const nil_val))))) - inline_locals) - (flat_map (lambda (i) (concat (generate_drop (local.get i)) (local.set i))) (reverse_e tce_full_params)) - (br '___TCE___) - (dlet ((_ (true_print "HAYO TCEEE"))) nil) - ) - (concat - ; static env - (i64.const s_env_val) - (call func_idx))) - ) - ; Needs wrapper, must create param array - (concat - (cond ((= 0 wrap_level) wrap_0_param_code) - ((= 1 wrap_level) wrap_1_param_code) - (true wrap_x_param_code)) - (mk_array_code_rc_const_len num_params (local.get '$param_ptr)) - ;dynamic env (is caller's static env) - ; hay, we can do this statically! the static version of the dynamic check - (mif needs_denv - (generate_dup s_env_access_code) - (i64.const nil_val)) - ; static env - (i64.const s_env_val) - (call func_idx) - ) - ) - back_half_stack_code - ) ctx)) - (array (concat - func_code - (local.tee '$tmp) - (_if '$is_wrap_0 - (is_wrap_code 0 (local.get '$tmp)) - (then - (global.set '$num_compiled_dzero (i32.add (i32.const 1) (global.get '$num_compiled_dzero))) - wrap_0_param_code - ) - (else - (_if '$is_wrap_1 - (is_wrap_code 1 (local.get '$tmp)) - (then - (global.set '$num_compiled_done (i32.add (i32.const 1) (global.get '$num_compiled_done))) - wrap_1_param_code - ) - (else wrap_x_param_code) - ) - ) - ) - (front_half_stack_code (i64.const source_code) (generate_dup s_env_access_code)) - (local.set '$tmp) - (call_indirect - ;type - k_vau - ;table - 0 - ;params - (mk_array_code_rc_const_len num_params (local.get '$param_ptr)) - ;dynamic env (is caller's static env) - (_if '$needs_dynamic_env '(result i64) - (needes_de_code (local.get '$tmp)) - (then (generate_dup s_env_access_code)) - (else (i64.const nil_val))) - ; static env - (extract_func_env_code (local.get '$tmp)) - ;func_idx - (extract_func_idx_code (local.get '$tmp)) - ) - back_half_stack_code - ) ctx))) - ) (array nil result_code (mif func_err func_err first_params_err) ctx))) - ))))))) - - ((marked_env? c) (or (get_passthrough (.hash c) ctx) (dlet ((e (.env_marked c)) - - ;(_ (true_print "gonna compile a marked_env")) - - (generate_env_access (dlambda ((datasi funcs memo env pectx inline_locals) env_id reason) ((rec-lambda recurse (code this_env) - (cond - ((= env_id (.marked_env_id this_env)) (array nil (generate_dup code) nil (array datasi funcs memo env pectx inline_locals))) - ((= nil (.marked_env_upper this_env)) (array nil nil (str "bad env, upper is nil and we haven't found " env_id ", (this is *possiblely* because we're not recreating val/notval chains?) maxing out at " (str_strip this_env) ", having started at " (str_strip env) ", we're generating because " reason) (array datasi funcs memo env pectx))) - (true (recurse (i64.load 16 (extract_ptr_code code)) (.marked_env_upper this_env))) - ) - ) s_env_access_code env))) - - ) (if (not (marked_env_real? c)) (begin (print_strip "env wasn't real: " (marked_env_real? c) ", so generating access (env was) " c) - (if need_value (array nil nil (str "marked env not real, though we need_value: " (str_strip c)) ctx) - (generate_env_access ctx (.marked_env_id c) "it wasn't real: " (str_strip c)))) - (dlet ( - ;(_ (true_print "gonna compile kvs vvs")) - - - ((kvs vvs ctx) (foldr (dlambda ((k v) (ka va ctx)) (dlet (((kv _ _ ctx) (compile-inner ctx (marked_symbol nil k) true inside_veval outer_s_env_access_code s_env_access_code inline_level nil analysis_nil)) - ((vv code err ctx) (compile-inner ctx v need_value inside_veval outer_s_env_access_code s_env_access_code inline_level nil analysis_nil)) - ) - (if (= false ka) (array false va ctx) - (if (or (= nil vv) (!= nil err)) (array false (str "vv was " vv " err is " err " and we needed_value? " need_value " based on v " (str_strip v)) ctx) - (array (cons kv ka) (cons (mod_fval_to_wrap vv) va) ctx))))) - (array (array) (array) ctx) - (slice e 0 -2))) - ;(_ (true_print "gonna compile upper_value")) - ((uv ucode err ctx) (mif (idx e -1) (compile-inner ctx (idx e -1) need_value inside_veval outer_s_env_access_code s_env_access_code inline_level nil analysis_nil) - (array nil_val nil nil ctx))) - ) (mif (or (= false kvs) (= nil uv) (!= nil err)) - (begin (true_print "kvs " kvs " vvs " vvs " uv " uv " or err " err " based off of " (true_str_strip c)) - (error "I DON'T LIKE IT - IMPOSSIBLE?") - (if need_value - (array nil nil (str "had to generate env access (course " need_value ") for " (str_strip c) "vvs is " vvs " err was " err) ctx) - (generate_env_access ctx (.marked_env_id c) (str " vvs " vvs " uv " uv " or err " err " based off of " (str_strip c))))) - (dlet ( - ((datasi funcs memo env pectx inline_locals) ctx) - ;(_ (true_print "about to kvs_array")) - ((kvs_array datasi) (if (= 0 (len kvs)) (array nil_val datasi) - (dlet (((kvs_loc kvs_len datasi) (alloc_data (apply concat (map i64_le_hexify kvs)) datasi))) - (array (mk_array_value (len kvs) kvs_loc) datasi)))) - ;(_ (true_print "about to vvs_array")) - ((vvs_array datasi) (if (= 0 (len vvs)) (array nil_val datasi) - (dlet (((vvs_loc vvs_len datasi) (alloc_data (apply concat (map i64_le_hexify vvs)) datasi))) - (array (mk_array_value (len vvs) vvs_loc) datasi)))) - ;(_ (true_print "about to all_hex")) - (all_hex (map i64_le_hexify (array kvs_array vvs_array uv))) - ;(_ (true_print "all_hexed")) - ((c_loc c_len datasi) (alloc_data (apply concat all_hex) datasi)) - ;(_ (true_print "alloced")) - (result (mk_env_value c_loc)) - ;(_ (true_print "made result " result)) - (memo (put memo (.hash c) result)) - ) (array result nil nil (array datasi funcs memo env pectx inline_locals))))))))) - - ((prim_comb? c) (cond ((= 'vau (.prim_comb_sym c)) (array (mk_comb_val_nil_env (- k_vau dyn_start) 1 (.prim_comb_wrap_level c)) nil nil ctx)) - ((= 'cond (.prim_comb_sym c)) (array (mk_comb_val_nil_env (- k_cond dyn_start) 1 (.prim_comb_wrap_level c)) nil nil ctx)) - ((= 'eval (.prim_comb_sym c)) (array (mk_comb_val_nil_env (- k_eval dyn_start) 1 (.prim_comb_wrap_level c)) nil nil ctx)) - ((= 'read-string (.prim_comb_sym c)) (array (mk_comb_val_nil_env (- k_read-string dyn_start) 0 (.prim_comb_wrap_level c)) nil nil ctx)) - ((= 'log (.prim_comb_sym c)) (array (mk_comb_val_nil_env (- k_log dyn_start) 0 (.prim_comb_wrap_level c)) nil nil ctx)) - ((= 'debug (.prim_comb_sym c)) (array (mk_comb_val_nil_env (- k_debug dyn_start) 1 (.prim_comb_wrap_level c)) nil nil ctx)) - ((= 'error (.prim_comb_sym c)) (array (mk_comb_val_nil_env (- k_error dyn_start) 0 (.prim_comb_wrap_level c)) nil nil ctx)) - ((= 'str (.prim_comb_sym c)) (array (mk_comb_val_nil_env (- k_str dyn_start) 0 (.prim_comb_wrap_level c)) nil nil ctx)) - ((= '>= (.prim_comb_sym c)) (array (mk_comb_val_nil_env (- k_geq dyn_start) 0 (.prim_comb_wrap_level c)) nil nil ctx)) - ((= '> (.prim_comb_sym c)) (array (mk_comb_val_nil_env (- k_gt dyn_start) 0 (.prim_comb_wrap_level c)) nil nil ctx)) - ((= '<= (.prim_comb_sym c)) (array (mk_comb_val_nil_env (- k_leq dyn_start) 0 (.prim_comb_wrap_level c)) nil nil ctx)) - ((= '< (.prim_comb_sym c)) (array (mk_comb_val_nil_env (- k_lt dyn_start) 0 (.prim_comb_wrap_level c)) nil nil ctx)) - ((= '!= (.prim_comb_sym c)) (array (mk_comb_val_nil_env (- k_neq dyn_start) 0 (.prim_comb_wrap_level c)) nil nil ctx)) - ((= '= (.prim_comb_sym c)) (array (mk_comb_val_nil_env (- k_eq dyn_start) 0 (.prim_comb_wrap_level c)) nil nil ctx)) - ((= '% (.prim_comb_sym c)) (array (mk_comb_val_nil_env (- k_mod dyn_start) 0 (.prim_comb_wrap_level c)) nil nil ctx)) - ((= '/ (.prim_comb_sym c)) (array (mk_comb_val_nil_env (- k_div dyn_start) 0 (.prim_comb_wrap_level c)) nil nil ctx)) - ((= '* (.prim_comb_sym c)) (array (mk_comb_val_nil_env (- k_mul dyn_start) 0 (.prim_comb_wrap_level c)) nil nil ctx)) - ((= '+ (.prim_comb_sym c)) (array (mk_comb_val_nil_env (- k_add dyn_start) 0 (.prim_comb_wrap_level c)) nil nil ctx)) - ((= '- (.prim_comb_sym c)) (array (mk_comb_val_nil_env (- k_sub dyn_start) 0 (.prim_comb_wrap_level c)) nil nil ctx)) - ((= 'band (.prim_comb_sym c)) (array (mk_comb_val_nil_env (- k_band dyn_start) 0 (.prim_comb_wrap_level c)) nil nil ctx)) - ((= 'bor (.prim_comb_sym c)) (array (mk_comb_val_nil_env (- k_bor dyn_start) 0 (.prim_comb_wrap_level c)) nil nil ctx)) - ((= 'bxor (.prim_comb_sym c)) (array (mk_comb_val_nil_env (- k_bxor dyn_start) 0 (.prim_comb_wrap_level c)) nil nil ctx)) - ((= 'bnot (.prim_comb_sym c)) (array (mk_comb_val_nil_env (- k_bnot dyn_start) 0 (.prim_comb_wrap_level c)) nil nil ctx)) - ((= '<< (.prim_comb_sym c)) (array (mk_comb_val_nil_env (- k_ls dyn_start) 0 (.prim_comb_wrap_level c)) nil nil ctx)) - ((= '>> (.prim_comb_sym c)) (array (mk_comb_val_nil_env (- k_rs dyn_start) 0 (.prim_comb_wrap_level c)) nil nil ctx)) - ((= 'builtin_fib (.prim_comb_sym c)) (array (mk_comb_val_nil_env (- k_builtin_fib dyn_start) 0 (.prim_comb_wrap_level c)) nil nil ctx)) - ((= 'array (.prim_comb_sym c)) (array (mk_comb_val_nil_env (- k_array dyn_start) 0 (.prim_comb_wrap_level c)) nil nil ctx)) - ((= 'concat (.prim_comb_sym c)) (array (mk_comb_val_nil_env (- k_concat dyn_start) 0 (.prim_comb_wrap_level c)) nil nil ctx)) - ((= 'slice (.prim_comb_sym c)) (array (mk_comb_val_nil_env (- k_slice dyn_start) 0 (.prim_comb_wrap_level c)) nil nil ctx)) - ((= 'idx (.prim_comb_sym c)) (array (mk_comb_val_nil_env (- k_idx dyn_start) 0 (.prim_comb_wrap_level c)) nil nil ctx)) - ((= 'len (.prim_comb_sym c)) (array (mk_comb_val_nil_env (- k_len dyn_start) 0 (.prim_comb_wrap_level c)) nil nil ctx)) - ((= 'array? (.prim_comb_sym c)) (array (mk_comb_val_nil_env (- k_array? dyn_start) 0 (.prim_comb_wrap_level c)) nil nil ctx)) - ((= 'get-text (.prim_comb_sym c)) (array (mk_comb_val_nil_env (- k_get-text dyn_start) 0 (.prim_comb_wrap_level c)) nil nil ctx)) - ((= 'str-to-symbol (.prim_comb_sym c)) (array (mk_comb_val_nil_env (- k_str-to-symbol dyn_start) 0 (.prim_comb_wrap_level c)) nil nil ctx)) - ((= 'bool? (.prim_comb_sym c)) (array (mk_comb_val_nil_env (- k_bool? dyn_start) 0 (.prim_comb_wrap_level c)) nil nil ctx)) - ((= 'nil? (.prim_comb_sym c)) (array (mk_comb_val_nil_env (- k_nil? dyn_start) 0 (.prim_comb_wrap_level c)) nil nil ctx)) - ((= 'env? (.prim_comb_sym c)) (array (mk_comb_val_nil_env (- k_env? dyn_start) 0 (.prim_comb_wrap_level c)) nil nil ctx)) - ((= 'combiner? (.prim_comb_sym c)) (array (mk_comb_val_nil_env (- k_combiner? dyn_start) 0 (.prim_comb_wrap_level c)) nil nil ctx)) - ((= 'string? (.prim_comb_sym c)) (array (mk_comb_val_nil_env (- k_string? dyn_start) 0 (.prim_comb_wrap_level c)) nil nil ctx)) - ((= 'int? (.prim_comb_sym c)) (array (mk_comb_val_nil_env (- k_int? dyn_start) 0 (.prim_comb_wrap_level c)) nil nil ctx)) - ((= 'symbol? (.prim_comb_sym c)) (array (mk_comb_val_nil_env (- k_symbol? dyn_start) 0 (.prim_comb_wrap_level c)) nil nil ctx)) - ((= 'unwrap (.prim_comb_sym c)) (array (mk_comb_val_nil_env (- k_unwrap dyn_start) 0 (.prim_comb_wrap_level c)) nil nil ctx)) - ((= 'vapply (.prim_comb_sym c)) (array (mk_comb_val_nil_env (- k_vapply dyn_start) 1 (.prim_comb_wrap_level c)) nil nil ctx)) - ((= 'lapply (.prim_comb_sym c)) (array (mk_comb_val_nil_env (- k_lapply dyn_start) 1 (.prim_comb_wrap_level c)) nil nil ctx)) - ((= 'wrap (.prim_comb_sym c)) (array (mk_comb_val_nil_env (- k_wrap dyn_start) 0 (.prim_comb_wrap_level c)) nil nil ctx)) - (error (str "Can't compile prim comb " (.prim_comb_sym c) " right now")))) - - - - ((comb? c) (dlet ( - ((wrap_level env_id de? se variadic params body) (.comb c)) - (_ (mif (> wrap_level 1) (error "wrap level TOO DARN HIGH"))) - - ; note that this is just the hash of the func, not the env - (old_hash (.hash c)) - (maybe_func (get_passthrough old_hash ctx)) - ((datasi funcs memo env pectx inline_locals) ctx) - ((pectx err evaled_body) (mif (or maybe_func dont_partial_eval) - (array pectx "don't pe" body) - (dlet ((inner_env (make_tmp_inner_env params de? env env_id))) - (partial_eval_helper body false inner_env (array nil (array inner_env)) pectx 1 false)))) - (body (mif err body evaled_body)) - (c (comb_w_body c body)) - (new_hash (.hash c)) - (ctx (array datasi funcs memo env pectx inline_locals)) - - ; Let's look and see if we can eta-reduce! - ; This is done here during code gen (when you would expect it earlier, like as part of partial eval) - ; because we currently only "tie the knot" for Y combinator based recursion here - ; at compile time (indeed, part of that happens in the block down below where we put our func value into memo before compiling), - ; and so we can only tell here weather or not it will be safe to remove the level of lazyness (because we get a func value back instead of code) - ; and perform the eta reduction. - - ((env_val env_code env_err ctx) (if (and need_value (not (marked_env_real? se))) - (array nil nil "Env wasn't real when compiling comb, but need value" ctx) - (compile-inner ctx se need_value inside_veval outer_s_env_access_code s_env_access_code inline_level nil analysis_nil))) - (_ (if (not (or (= nil env_val) (int? env_val))) (error "BADBADBADenv_val"))) - - ) (mif (and - (not dont_y_comb) - variadic - (= 1 (len params)) - (marked_array? body) - (= 4 (len (.marked_array_values body))) - (prim_comb? (idx (.marked_array_values body) 0)) - (= 'lapply (.prim_comb_sym (idx (.marked_array_values body) 0))) - (int? (get-value-or-false memo (.hash (idx (.marked_array_values body) 1)))) - (marked_symbol? (idx (.marked_array_values body) 2)) - (not (.marked_symbol_is_val (idx (.marked_array_values body) 2))) - (= (idx params 0) (.marked_symbol_value (idx (.marked_array_values body) 2))) - (marked_symbol? (idx (.marked_array_values body) 3)) - (not (.marked_symbol_is_val (idx (.marked_array_values body) 3))) - (= de? (.marked_symbol_value (idx (.marked_array_values body) 3))) - env_val - ) - (array (combine_env_comb_val env_val (set_wrap_val wrap_level (get-value-or-false memo (.hash (idx (.marked_array_values body) 1))))) nil err ctx) - (dlet ( - - (maybe_func (or (get_passthrough old_hash ctx) (get_passthrough new_hash ctx))) - ((func_value _ func_err ctx) (mif maybe_func maybe_func - (dlet ( - - (full_params (concat params (mif de? (array de?) (array)))) - (normal_params_length (if variadic (- (len params) 1) (len params))) - - ((datasi funcs memo env pectx outer_inline_locals) ctx) - (old_funcs funcs) - (funcs (concat funcs (array nil))) - (our_wrap_func_idx (+ (len funcs) func_id_dynamic_ofset)) - (funcs (concat funcs (array nil))) - (our_func_idx (+ (len funcs) func_id_dynamic_ofset)) - (calculate_func_val (lambda (wrap) (mk_comb_val_nil_env our_func_idx (mif de? 1 0) wrap))) - (func_value (calculate_func_val wrap_level)) - ; if variadic, we just use the wrapper func and don't expect callers to know that we're varidic - (func_value (mif variadic (mod_fval_to_wrap func_value) func_value)) - ; Put our eventual func_value in the memo before we actually compile for recursion etc - (memo (put (put memo new_hash func_value) old_hash func_value)) - - ((inner_analysis_data analysis_err pectx) (function-analysis c memo pectx)) - (ctx (array datasi funcs memo env pectx outer_inline_locals)) - ; EARLY QUIT IF Analysis Error - ) (mif analysis_err (array nil nil analysis_err ctx) (dlet ( - (new_inline_locals (array)) - (ctx (array datasi funcs memo env pectx new_inline_locals)) - - - (new_tce_data (array our_func_idx full_params)) - (inner_env (make_tmp_inner_env params de? se env_id)) - - ((params_vec _ _ ctx) (compile-inner ctx (marked_array true false nil (map (lambda (k) (marked_symbol nil k)) full_params) nil) true false outer_s_env_access_code s_env_access_code 0 nil analysis_nil)) - (basic_get_s_env_code (local.get '$s_env)) - (generate_get_s_env_code (local.tee '$s_env (call '$env_alloc (i64.const params_vec) - - (local.set '$tmp_ptr (call '$malloc (i32.const (* 8 (len full_params))))) - (flat_map (lambda (i) (i64.store (* i 8) (local.get '$tmp_ptr) - (generate_dup (local.get (idx full_params i))))) - (range 0 (len full_params))) - (mk_array_code_rc_const_len (len full_params) (local.get '$tmp_ptr)) - - (generate_dup (local.get '$outer_s_env))))) - (lazy_get_s_env_code (_if '$have_s_env '(result i64) - (i64.ne (i64.const nil_val) (local.get '$s_env)) - (then basic_get_s_env_code) - (else generate_get_s_env_code - ;(call '$print (i64.const params_vec)) - ;(call '$print (i64.const newline_msg_val)) - ;(local.set '$outer_s_env (i64.const nil_val)) - ))) - (new_get_s_env_code (if dont_lazy_env basic_get_s_env_code lazy_get_s_env_code)) - ((datasi funcs memo env pectx inline_locals) ctx) - (inner_ctx (array datasi funcs memo inner_env pectx inline_locals)) - - ((inner_value inner_code err ctx) (compile-inner inner_ctx body false false (local.get '$outer_s_env) new_get_s_env_code 0 new_tce_data inner_analysis_data)) - (_ (true_print "Done compile_body func def compile-inner " full_params)) - ; Don't overwrite env with what was our inner env! Env is returned as part of context to our caller! - ((datasi funcs memo _was_inner_env pectx inline_locals) ctx) - (ctx (array datasi funcs memo env pectx inline_locals)) - - - (inner_code (mif inner_value (i64.const (mod_fval_to_wrap inner_value)) inner_code)) - (wrapper_func (func '$wrapper_func '(param $params i64) '(param $d_env i64) '(param $outer_s_env i64) '(result i64) '(local $param_ptr i32) '(local $rc_bytes i64) '(local $rc_ptr i32) '(local $rc_tmp i32) - (_if '$params_len_good - (if variadic (i32.lt_u (extract_size_code (local.get '$params)) (i32.const (- (len params) 1))) - (i32.ne (extract_size_code (local.get '$params)) (i32.const (len params)))) - (then - (generate_drop (local.get '$params)) - (generate_drop (local.get '$outer_s_env)) - (generate_drop (local.get '$d_env)) - (call '$print (i64.const bad_params_number_msg_val)) - (unreachable) - ) - ) - (call (+ (len old_funcs) 1 num_pre_functions) - (local.set '$param_ptr (extract_ptr_code (local.get '$params))) - (flat_map (lambda (i) (generate_dup (i64.load (* i 8) (local.get '$param_ptr)))) (range 0 normal_params_length)) - (if variadic - (call '$slice_impl (local.get '$params) (i32.const (- (len params) 1)) (i32.const -1)) - (generate_drop (local.get '$params))) - (mif de? - (local.get '$d_env) - (generate_drop (local.get '$d_env))) - (local.get '$outer_s_env)) - )) - ((datasi funcs memo env pectx inline_locals) ctx) - (parameter_symbols (map (lambda (k) (array 'param k 'i64)) full_params)) - (our_inline_locals (map (lambda (k) (array 'local k 'i64)) (filter (lambda (x) (!= '___TCE___ x)) inline_locals))) - - (our_func (apply func (concat (array '$userfunc) parameter_symbols (array '(param $outer_s_env i64) '(result i64) '(local $param_ptr i32) '(local $s_env i64) '(local $tmp_ptr i32) '(local $tmp i64) '(local $prim_tmp_a i64) '(local $prim_tmp_b i64) '(local $prim_tmp_c i64) '(local $prim_tmp_d i32) '(local $rc_bytes i64) '(local $rc_ptr i32) '(local $rc_tmp i32)) our_inline_locals (array - - ;(local.set '$s_env (i64.const nil_val)) - (if dont_lazy_env (_drop generate_get_s_env_code) - (local.set '$s_env (i64.const nil_val))) - (mif (in_array '___TCE___ inline_locals) - (concat - (_loop '___TCE___ - inner_code - (local.set '$tmp) - ) - (local.get '$tmp) - ) - inner_code - ) - - (generate_drop (local.get '$s_env)) - (generate_drop (local.get '$outer_s_env)) - (flat_map (lambda (k) (generate_drop (local.get k))) full_params) - )))) - ; replace our placeholder with the real one - (funcs (concat old_funcs wrapper_func our_func (drop funcs (+ 2 (len old_funcs))))) - - ) (array func_value nil err (array datasi funcs memo env pectx outer_inline_locals))) - )))) - (_ (print_strip "returning " func_value " for " c)) - (_ (if (and (not func_err) (not (int? func_value))) (error "BADBADBADfunc"))) - - (full_result (cond - ((!= nil func_err) (array nil nil (str func_err ", from compiling comb body") ctx)) - ((!= nil env_err) (array nil nil (str env_err ", from compiling env") ctx)) - ((!= nil env_val) (array (combine_env_comb_val env_val func_value) nil nil ctx)) - (true (array nil (combine_env_code_comb_val_code env_code (mod_fval_to_wrap func_value)) nil ctx)))) - ) full_result - )))) - - (true (error (str "Can't compile-inner impossible " c))) - ))) - (_ (true_print "Made compile-inner closure")) - - ;(_ (println "compiling partial evaled " (str_strip marked_code))) - ;(_ (true_print "compiling partial evaled " (true_str_strip marked_code))) - ;(_ (true_print "compiling partial evaled ")) - (ctx (array datasi funcs memo root_marked_env pectx (array))) - - (_ (true_print "About to compile a bunch of symbols & strings")) - - ((run_val _ _ ctx) (compile-inner ctx (marked_symbol nil 'run) true false (array) (array) 0 nil analysis_nil)) - ((exit_val _ _ ctx) (compile-inner ctx (marked_symbol nil 'exit) true false (array) (array) 0 nil analysis_nil)) - ((args_val _ _ ctx) (compile-inner ctx (marked_symbol nil 'args) true false (array) (array) 0 nil analysis_nil)) - ((read_val _ _ ctx) (compile-inner ctx (marked_symbol nil 'read) true false (array) (array) 0 nil analysis_nil)) - ((write_val _ _ ctx) (compile-inner ctx (marked_symbol nil 'write) true false (array) (array) 0 nil analysis_nil)) - ((open_val _ _ ctx) (compile-inner ctx (marked_symbol nil 'open) true false (array) (array) 0 nil analysis_nil)) - ((monad_error_msg_val _ _ ctx) (compile-inner ctx (marked_val "Not a legal monad ( ['args ] / ['read fd len ] / ['write fd data ] / ['open fd path ] / ['exit exit_code] / ['run ])") true false (array) (array) 0 nil analysis_nil)) - ((bad_args_val _ _ ctx) (compile-inner ctx (marked_val "") true false (array) (array) 0 nil analysis_nil)) - ((bad_read_val _ _ ctx) (compile-inner ctx (marked_val "") true false (array) (array) 0 nil analysis_nil)) - ((exit_msg_val _ _ ctx) (compile-inner ctx (marked_val "Exiting with code: ") true false (array) (array) 0 nil analysis_nil)) - - (_ (true_print "about ot compile the root_marked_env")) - - ((root_marked_env_val _ _ ctx) (compile-inner ctx root_marked_env true false (array) (array) 0 nil analysis_nil)) - - (_ (true_print "made the vals")) - - (_ (true_print "gonna compile")) - ((compiled_value_ptr compiled_value_code compiled_value_error ctx) (compile-inner ctx marked_code true false (array) (array) 0 nil analysis_nil)) - ((datasi funcs memo root_marked_env pectx inline_locals) ctx) - (compiled_value_code (mif compiled_value_ptr (i64.const (mod_fval_to_wrap compiled_value_ptr)) compiled_value_code)) - - ; Swap for when need to profile what would be an error - ;(compiled_value_ptr (mif compiled_value_error 0 compiled_value_ptr)) - (_ (mif compiled_value_error (error compiled_value_error))) - - ; Ok, so the outer loop handles the IO monads - ; ('args ) - ; ('exit code) - ; ('read fd len ) - ; ('write fd "data" ) - ; ('open fd path ) - ; Could add some to open like lookup flags, o flags, base rights - ; ineriting rights, fdflags - - (start (func '$start '(local $it i64) '(local $tmp i64) '(local $ptr i32) '(local $monad_name i64) '(local $len i32) '(local $buf i32) '(local $traverse i32) '(local $x i32) '(local $y i32) '(local $code i32) '(local $str i64) '(local $result i64) '(local $debug_malloc_print i32) '(local $rc_bytes i64) '(local $rc_ptr i32) '(local $rc_tmp i32) - (local.set '$it compiled_value_code) - (block '$exit_block - (block '$error_block - (_loop '$l - ; Not array -> out - (br_if '$error_block (is_not_type_code array_tag (local.get '$it))) - ; less than len 2 -> out - (br_if '$error_block (i32.lt_u (extract_size_code (local.get '$it)) (i32.const 2))) - (local.set '$ptr (extract_ptr_code (local.get '$it))) - (local.set '$monad_name (i64.load (local.get '$ptr))) - - (_if '$is_args - (i64.eq (i64.const args_val) (local.get '$monad_name)) - (then - ; len != 2 - (br_if '$error_block (i32.ne (extract_size_code (local.get '$it)) (i32.const 2))) - ; second entry isn't a comb -> out - (br_if '$error_block (is_not_type_code comb_tag (i64.load 8 (local.get '$ptr)))) - (local.set '$tmp (generate_dup (i64.load 8 (local.get '$ptr)))) - (generate_drop (local.get '$it)) - (local.set '$code (call '$args_sizes_get - (i32.const iov_tmp) - (i32.const (+ iov_tmp 4)) - )) - (local.set '$len (i32.load (i32.const iov_tmp))) - (_if '$is_error - (i32.eqz (local.get '$code)) - (then - (local.set '$ptr (call '$malloc (i32.shl (local.get '$len) (i32.const 3)))) - (local.set '$buf (call '$malloc (i32.load (i32.const (+ iov_tmp 4))))) - (local.set '$result (mk_array_code_rc (local.get '$len) (local.get '$ptr))) - (local.set '$code (call '$args_get - (local.get '$ptr) - (local.get '$buf))) - (_if '$is_error2 - (i32.eqz (local.get '$code)) - (then - (block '$set_ptr_break - (_loop '$set_ptr - (br_if '$set_ptr_break (i32.eqz (local.get '$len))) - (local.set '$len (i32.sub (local.get '$len) (i32.const 1))) - (local.set '$traverse (local.tee '$x (i32.load (i32.add (local.get '$ptr) (i32.shl (local.get '$len) (i32.const 2)))))) - (block '$str_len_break - (_loop '$str_len - (br_if '$str_len_break (i32.eqz (i32.load8_u (local.get '$traverse)))) - (local.set '$traverse (i32.add (local.get '$traverse) (i32.const 1))) - (br '$str_len) - ) - ) - (local.set '$traverse (i32.sub (local.get '$traverse) (local.get '$x))) - (local.set '$y (call '$malloc (local.get '$traverse))) - (memory.copy (local.get '$y) - (local.get '$x) - (local.get '$traverse)) - (i64.store (i32.add (local.get '$ptr) (i32.shl (local.get '$len) (i32.const 3))) - (mk_string_code_rc (local.get '$traverse) (local.get '$y))) - (br '$set_ptr) - ) - ) - (call '$free (local.get '$buf)) - (local.set '$result (call '$array2_alloc (local.get '$result) - (i64.const 0))) - ) - (else - (call '$free (local.get '$ptr)) - (call '$free (local.get '$buf)) - (local.set '$result (call '$array2_alloc (i64.const bad_args_val) - (mk_int_code_i32u (local.get '$code)))) - ) - ) - ) - (else - (local.set '$result (call '$array2_alloc (i64.const bad_args_val) - (mk_int_code_i32u (local.get '$code)))) - ) - ) - - (generate_drop (global.get '$debug_func_to_call)) - (generate_drop (global.get '$debug_params_to_call)) - (generate_drop (global.get '$debug_env_to_call)) - (global.set '$debug_func_to_call (generate_dup (local.get '$tmp))) - (global.set '$debug_params_to_call (generate_dup (local.get '$result))) - (global.set '$debug_env_to_call (i64.const root_marked_env_val)) - (local.set '$it (call_indirect - ;type - k_vau - ;table - 0 - ;params - (local.get '$result) - ;top_env - (i64.const root_marked_env_val) - ; static env - (extract_func_env_code (local.get '$tmp)) - ;func_idx - (extract_func_idx_code (local.get '$tmp)) - )) - (br '$l) - ) - ) - - (_if '$is_run - (i64.eq (i64.const run_val) (local.get '$monad_name)) - (then - ;; len != 2 - (br_if '$error_block (i32.ne (extract_size_code (local.get '$it)) (i32.const 2))) - ;; second entry isn't a comb -> out - (br_if '$error_block (is_not_type_code comb_tag (i64.load 8 (local.get '$ptr)))) - (local.set '$tmp (generate_dup (i64.load 8 (local.get '$ptr)))) - (generate_drop (local.get '$it)) - (generate_drop (global.get '$debug_func_to_call)) - (generate_drop (global.get '$debug_params_to_call)) - (generate_drop (global.get '$debug_env_to_call)) - (global.set '$debug_func_to_call (generate_dup (local.get '$tmp))) - (global.set '$debug_params_to_call (i64.const nil_val)) - (global.set '$debug_env_to_call (i64.const root_marked_env_val)) - (local.set '$it (call_indirect - ;;type - k_vau - ;;table - 0 - ;;params - (i64.const nil_val) - ;;top_env - (i64.const root_marked_env_val) - ;; static env - (extract_func_env_code (local.get '$tmp)) - ;;func_idx - (extract_func_idx_code (local.get '$tmp)) - )) - (br '$l) - ) - ) - - ; second entry isn't an int -> out - (br_if '$error_block (is_not_type_code int_tag (i64.load 8 (local.get '$ptr)))) - - ; ('exit code) - (_if '$is_exit - (i64.eq (i64.const exit_val) (local.get '$monad_name)) - (then - ; len != 2 - (br_if '$error_block (i32.ne (extract_size_code (local.get '$it)) (i32.const 2))) - (call '$print (i64.const exit_msg_val)) - (call '$print (i64.load 8 (local.get '$ptr))) - (br '$exit_block) - ) - ) - - ; if len != 4 - (br_if '$error_block (i32.ne (extract_size_code (local.get '$it)) (i32.const 4))) - - ; ('read fd len ) - (_if '$is_read - (i64.eq (i64.const read_val) (local.get '$monad_name)) - (then - ; third entry isn't an int -> out - (br_if '$error_block (is_not_type_code int_tag (i64.load 16 (local.get '$ptr)))) - ; fourth entry isn't a comb -> out - (br_if '$error_block (is_not_type_code comb_tag (i64.load 24 (local.get '$ptr)))) - ; iov <32bit len><32bit addr> + <32bit num written> - (i32.store 4 (i32.const iov_tmp) (local.tee '$len (i32.wrap_i64 (extract_int_code (i64.load 16 (local.get '$ptr)))))) - (i32.store 0 (i32.const iov_tmp) (local.tee '$buf (call '$malloc (local.get '$len)))) - (local.set '$code (call '$fd_read - (i32.wrap_i64 (extract_int_code (i64.load 8 (local.get '$ptr)))) ;; file descriptor - (i32.const iov_tmp) ;; *iovs - (i32.const 1) ;; iovs_len - (i32.const (+ 8 iov_tmp)) ;; nwritten - )) - - (local.set '$str (mk_string_code_rc (i32.load 8 (i32.const iov_tmp)) (local.get '$buf))) - (_if '$is_error - (i32.eqz (local.get '$code)) - (then - (local.set '$result (call '$array2_alloc (local.get '$str) - (i64.const 0))) - ) - (else - (generate_drop (local.get '$str)) - (local.set '$result (call '$array2_alloc (i64.const bad_read_val) - (mk_int_code_i32u (local.get '$code)))) - ) - ) - - (local.set '$tmp (generate_dup (i64.load 24 (local.get '$ptr)))) - (generate_drop (global.get '$debug_func_to_call)) - (generate_drop (global.get '$debug_params_to_call)) - (generate_drop (global.get '$debug_env_to_call)) - (global.set '$debug_func_to_call (generate_dup (local.get '$tmp))) - (global.set '$debug_params_to_call (generate_dup (local.get '$result))) - (global.set '$debug_env_to_call (i64.const root_marked_env_val)) - (generate_drop (local.get '$it)) - (local.set '$it (call_indirect - ;type - k_vau - ;table - 0 - ;params - (local.get '$result) - ;top_env - (i64.const root_marked_env_val) - ; static env - (extract_func_env_code (local.get '$tmp)) - ;func_idx - (extract_func_idx_code (local.get '$tmp)) - )) - (br '$l) - ) - ) - - ; ('write fd "data" ) - (_if '$is_write - (i64.eq (i64.const write_val) (local.get '$monad_name)) - (then - ; third entry isn't a string -> out - (br_if '$error_block (is_not_type_code string_tag (i64.load 16 (local.get '$ptr)))) - ; fourth entry isn't a comb -> out - (br_if '$error_block (is_not_type_code comb_tag (i64.load 24 (local.get '$ptr)))) - ; 011 - (local.set '$str (i64.load 16 (local.get '$ptr))) - - ; iov <32bit addr><32bit len> + <32bit num written> - (i32.store 0 (i32.const iov_tmp) (extract_ptr_code (local.get '$str))) - (i32.store 4 (i32.const iov_tmp) (extract_size_code (local.get '$str))) - (local.set '$code (call '$fd_write - (i32.wrap_i64 (extract_int_code (i64.load 8 (local.get '$ptr)))) ;; file descriptor - (i32.const iov_tmp) ;; *iovs - (i32.const 1) ;; iovs_len - (i32.const (+ 8 iov_tmp)) ;; nwritten - )) - (local.set '$result (call '$array2_alloc (mk_int_code_i32u (i32.load (i32.const (+ 8 iov_tmp)))) - (mk_int_code_i32u (local.get '$code)))) - - (local.set '$tmp (generate_dup (i64.load 24 (local.get '$ptr)))) - (generate_drop (global.get '$debug_func_to_call)) - (generate_drop (global.get '$debug_params_to_call)) - (generate_drop (global.get '$debug_env_to_call)) - (global.set '$debug_func_to_call (generate_dup (local.get '$tmp))) - (global.set '$debug_params_to_call (generate_dup (local.get '$result))) - (global.set '$debug_env_to_call (i64.const root_marked_env_val)) - ;(call '$print (i64.const pre_write_callback)) - ;(call '$print (local.get '$tmp)) - ;(call '$print (extract_func_env_code (local.get '$tmp))) - ;(call '$print (i64.const newline_msg_val)) - ;(call '$print (mk_int_code_i64 (local.get '$tmp))) - ;(call '$print (i64.const newline_msg_val)) - ;(call '$print (mk_int_code_i64 (extract_func_env_code (local.get '$tmp)))) - ;(call '$print (i64.const newline_msg_val)) - (generate_drop (local.get '$it)) - (local.set '$it (call_indirect - ;type - k_vau - ;table - 0 - ;params - (local.get '$result) - ;top_env - (i64.const root_marked_env_val) - ; static env - (extract_func_env_code (local.get '$tmp)) - ;func_idx - (extract_func_idx_code (local.get '$tmp)) - )) - (br '$l) - ) - ) - ; ('open fd path ) - (_if '$is_open - (i64.eq (i64.const open_val) (local.get '$monad_name)) - (then - ; third entry isn't a string -> out - (br_if '$error_block (is_not_type_code string_tag (i64.load 16 (local.get '$ptr)))) - ; fourth entry isn't a comb -> out - (br_if '$error_block (is_not_type_code comb_tag (i64.load 24 (local.get '$ptr)))) - (local.set '$str (i64.load 16 (local.get '$ptr))) - - (local.set '$code (call '$path_open - (i32.wrap_i64 (extract_int_code (i64.load 8 (local.get '$ptr)))) ;; file descriptor - (i32.const 0) ;; lookup flags - (extract_ptr_code (local.get '$str)) ;; path string * - (extract_size_code (local.get '$str)) ;; path string len - (i32.const 1) ;; o flags - (i64.const 66) ;; base rights - (i64.const 66) ;; inheriting rights - (i32.const 0) ;; fdflags - (i32.const iov_tmp) ;; opened fd out ptr - )) - - (local.set '$result (call '$array2_alloc (mk_int_code_i32u (i32.load (i32.const iov_tmp))) - (mk_int_code_i32u (local.get '$code)))) - - (local.set '$tmp (generate_dup (i64.load 24 (local.get '$ptr)))) - (generate_drop (global.get '$debug_func_to_call)) - (generate_drop (global.get '$debug_params_to_call)) - (generate_drop (global.get '$debug_env_to_call)) - (global.set '$debug_func_to_call (generate_dup (local.get '$tmp))) - (global.set '$debug_params_to_call (generate_dup (local.get '$result))) - (global.set '$debug_env_to_call (i64.const root_marked_env_val)) - (generate_drop (local.get '$it)) - (local.set '$it (call_indirect - ;type - k_vau - ;table - 0 - ;params - (local.get '$result) - ;top_env - (i64.const root_marked_env_val) - ; static env - (extract_func_env_code (local.get '$tmp)) - ;func_idx - (extract_func_idx_code (local.get '$tmp)) - )) - (br '$l) - ) - ) - ) - ) - ; print error - (call '$print (i64.const monad_error_msg_val)) - (call '$print (local.get '$it)) - ) - (generate_drop (local.get '$it)) - (generate_drop (global.get '$debug_func_to_call)) - (generate_drop (global.get '$debug_params_to_call)) - (generate_drop (global.get '$debug_env_to_call)) - ;(generate_drop (global.get '$symbol_intern)) - - - (mk_int_code_i32s (global.get '$num_array_maxsubdrops)) - (mk_int_code_i32s (global.get '$num_array_subdrops)) - (mk_int_code_i32s (global.get '$num_array_innerdrops)) - (mk_int_code_i32s (global.get '$num_env_innerdrops)) - - - - (mk_int_code_i32s (global.get '$num_interned_symbols)) - (mk_int_code_i32s (global.get '$num_frees)) - (mk_int_code_i32s (global.get '$num_mallocs)) - (mk_int_code_i32s (global.get '$num_sbrks)) - - (mk_int_code_i32s (global.get '$num_compiled_dzero)) - (mk_int_code_i32s (global.get '$num_compiled_done)) - (mk_int_code_i32s (global.get '$num_interp_dzero)) - (mk_int_code_i32s (global.get '$num_interp_done)) - (mk_int_code_i32s (global.get '$num_all_evals)) - (mk_int_code_i32s (global.get '$num_evals)) - (call '$print (i64.const newline_msg_val)) - (call '$print (i64.const newline_msg_val)) - (call '$print (i64.const newline_msg_val)) - (call '$print (i64.const newline_msg_val)) - - (call '$print ) - (call '$print (i64.const newline_msg_val)) - (call '$print ) - (call '$print (i64.const newline_msg_val)) - (call '$print ) - (call '$print (i64.const newline_msg_val)) - (call '$print ) - (call '$print (i64.const newline_msg_val)) - (call '$print ) - (call '$print (i64.const newline_msg_val)) - (call '$print ) - - (call '$print (i64.const newline_msg_val)) - (call '$print (i64.const newline_msg_val)) - (call '$print (i64.const newline_msg_val)) - (call '$print (i64.const newline_msg_val)) - - (call '$print (i64.const newline_msg_val)) - (call '$print ) - (call '$print (i64.const newline_msg_val)) - (call '$print ) - (call '$print (i64.const newline_msg_val)) - (call '$print ) - (call '$print (i64.const newline_msg_val)) - (call '$print ) - (call '$print (i64.const newline_msg_val)) - (call '$print (i64.const newline_msg_val)) - (call '$print ) - (call '$print (i64.const newline_msg_val)) - (call '$print ) - (call '$print (i64.const newline_msg_val)) - (call '$print ) - (call '$print (i64.const newline_msg_val)) - (call '$print ) - (call '$print (i64.const newline_msg_val)) - )) - (_ (true_print "Beginning all symbol print")) - ((datasi symbol_intern_val) (foldl-tree (dlambda ((datasi a) k v) (mif (and (array? k) (marked_symbol? k)) - (dlet ( - ;(_ (true_print "symbol? " k " " v)) - ((a_loc a_len datasi) (alloc_data (concat (i64_le_hexify v) - (i64_le_hexify a)) - datasi)) - ) (array datasi (mk_array_value 2 a_loc))) - (array datasi a))) (array datasi nil_val) memo)) - (_ (true_print "Ending all symbol print")) - ((watermark datas) datasi) - ) (concat - (global '$data_end '(mut i32) (i32.const watermark)) - (global '$symbol_intern '(mut i64) (i64.const symbol_intern_val)) - datas funcs start - (table '$tab (len funcs) 'funcref) - (apply elem (cons (i32.const 0) (range dyn_start (+ num_pre_functions (len funcs))))) - (memory '$mem (+ 2 (>> watermark 16))) - )) - (export "memory" '(memory $mem)) - (export "_start" '(func $start)) - ))))) - - - (run_partial_eval_test (lambda (s) (dlet ( - (_ (print "\n\ngoing to partial eval " s)) - ((pectx err result) (partial_eval (read-string s))) - (_ (true_print "result of test \"" s "\" => " (true_str_strip result) " and err " err)) - ) nil))) - - - (test-most (lambda () (begin - (print (val? '(val))) - (print "take 3" (take '(1 2 3 4 5 6 7 8 9 10) 3)) - ; shadowed by wasm - ;(print "drop 3" (drop '(1 2 3 4 5 6 7 8 9 10) 3)) - (print (slice '(1 2 3) 1 2)) - (print (slice '(1 2 3) 1 -1)) - (print (slice '(1 2 3) -1 -1)) - (print (slice '(1 2 3) -2 -1)) - - (print "ASWDF") - (print (str-to-symbol (str '(a b)))) - (print (symbol? (str-to-symbol (str '(a b))))) - (print ( (dlambda ((a b)) a) '(1337 1338))) - (print ( (dlambda ((a b)) b) '(1337 1338))) - - (print (str 1 2 3 (array 1 23 4) "a" "B")) - - (print (dlet ( (x 2) ((a b) '(1 2)) (((i i2) i3) '((5 6) 7)) ) (+ x a b i i2 i3))) - - (print (array 1 2 3)) - (print (command-line-arguments)) - - ;(print (call-with-input-string "'(1 2)" (lambda (p) (read p)))) - (print (read (open-input-string "'(3 4)"))) - - (print "if tests") - (print (if true 1 2)) - (print (if false 1 2)) - (print (if true 1)) - (print (if false 1)) - (print "if tests end") - - (print "mif tests") - (print (mif true 1 2)) - (print (mif false 1 2)) - (print (mif true 1)) - (print (mif false 1)) - (print "2 nils") - (print (mif nil 1 2)) - (print (mif nil 1)) - (print "2 1s") - (print (mif 1 1 2)) - (print (mif 1 1)) - (print "mif tests end") - - (print (get-value (put (put empty_dict 3 4) 1 2) 3)) - (print (get-value (put (put empty_dict 3 4) 1 2) 1)) - - (print (get-value-or-false (put (put empty_dict 3 4) 1 2) 3)) - (print (get-value-or-false (put (put empty_dict 3 4) 1 2) 1)) - (print (get-value-or-false (put (put empty_dict 3 4) 1 2) 5)) - - (print "zip " (zip '(1 2 3) '(4 5 6) '(7 8 9))) - - (print (run_partial_eval_test "(+ 1 2)")) - ;(print) (print) - (print (run_partial_eval_test "(cond false 1 true 2)")) - (print (run_partial_eval_test "(log 1)")) - (print (run_partial_eval_test "((vau (x) (+ x 1)) 2)")) - - - (print (run_partial_eval_test "(+ 1 2)")) - (print (run_partial_eval_test "(vau (y) (+ 1 2))")) - (print (run_partial_eval_test "((vau (y) (+ 1 2)) 4)")) - (print (run_partial_eval_test "((vau (y) y) 4)")) - (print (run_partial_eval_test "((vau (y) (+ 13 2 y)) 4)")) - (print (run_partial_eval_test "((wrap (vau (y) (+ 13 2 y))) (+ 3 4))")) - (print (run_partial_eval_test "(vau de (y) (+ (eval y de) (+ 1 2)))")) - (print (run_partial_eval_test "((vau de (y) ((vau dde (z) (+ 1 (eval z dde))) y)) 17)")) - - (print (run_partial_eval_test "(cond false 1 false 2 (+ 1 2) 3 true 1337)")) - (print (run_partial_eval_test "(vau de (x) (cond false 1 false 2 x 3 true 42))")) - (print (run_partial_eval_test "(vau de (x) (cond false 1 false 2 3 x true 42))")) - - (print (run_partial_eval_test "(combiner? true)")) - (print (run_partial_eval_test "(combiner? (vau de (x) x))")) - (print (run_partial_eval_test "(vau de (x) (combiner? x))")) - - (print (run_partial_eval_test "((vau (x) x) a)")) - - (print (run_partial_eval_test "(env? true)")) - ; this doesn't partially eval, but it could with a more percise if the marked values were more percise - (print (run_partial_eval_test "(vau de (x) (env? de))")) - (print (run_partial_eval_test "(vau de (x) (env? x))")) - (print (run_partial_eval_test "((vau de (x) (env? de)) 1)")) - - (print (run_partial_eval_test "((wrap (vau (let1) (let1 a 12 (+ a 1)))) (vau de (s v b) (eval (array (array vau (array s) b) (eval v de)) de)))")) - (print (run_partial_eval_test "((wrap (vau (let1) (let1 a 12 (vau (x) (+ a 1))))) (vau de (s v b) (eval (array (array vau (array s) b) (eval v de)) de)))")) - (print (run_partial_eval_test "((wrap (vau (let1) (let1 a 12 (wrap (vau (x) (+ x a 1)))))) (vau de (s v b) (eval (array (array vau (array s) b) (eval v de)) de)))")) - (print (run_partial_eval_test "((wrap (vau (let1) (let1 a 12 (wrap (vau (x) (let1 y (+ a 1) (+ y x a))))))) (vau de (s v b) (eval (array (array vau (array s) b) (eval v de)) de)))")) - - ;(print "\n\nnil test\n") - ;(print (run_partial_eval_test "nil")) - ;(print (run_partial_eval_test "(nil? 1)")) - ;(print (run_partial_eval_test "(nil? nil)")) - - (print "\n\nlet 4.3\n\n") - (print (run_partial_eval_test "((wrap (vau (let1) - (let1 a 12 (wrap (vau (x) (let1 y (+ a 1) (+ y x a)))) - ))) (vau de (s v b) (eval (array (array wrap (array vau (array s) b)) v) de)))")) - (print "\n\nlet 4.7\n\n") - (print (run_partial_eval_test "((wrap (vau (let1) - (let1 a 12 (wrap (vau (x) (let1 y (+ x a 1) (+ y x a)))) - ))) (vau de (s v b) (eval (array (array wrap (array vau (array s) b)) v) de)))")) - - (print "\n\nlet 5\n\n") - (print (run_partial_eval_test "((wrap (vau (let1) - (let1 a 12 (wrap (vau (x) (let1 y (+ x a 1) (+ y x a)))) - ))) (vau de (s v b) (eval (array (array vau (array s) b) (eval v de)) de)))")) - - (print "\n\nlambda 1\n\n") - (print (run_partial_eval_test "((wrap (vau (let1) - (let1 lambda (vau se (p b) (wrap (eval (array vau p b) se))) - (lambda (x) x) - ))) (vau de (s v b) (eval (array (array wrap (array vau (array s) b)) v) de)))")) - (print "\n\nlambda 2\n\n") - (print (run_partial_eval_test "((wrap (vau (let1) - (let1 lambda (vau se (p b) (wrap (eval (array vau p b) se))) - (let1 a 12 - (lambda (x) (+ a x))) - ))) (vau de (s v b) (eval (array (array wrap (array vau (array s) b)) v) de)))")) - (print "\n\nlambda 3\n\n") - (print (run_partial_eval_test "((wrap (vau (let1) - (let1 lambda (vau se (p b) (wrap (eval (array vau p b) se))) - (let1 a 12 - (lambda (x) (let1 b (+ a x) - (+ a x b)))) - ))) (vau de (s v b) (eval (array (array wrap (array vau (array s) b)) v) de)))")) - - (print (run_partial_eval_test "(array 1 2 3 4 5)")) - (print (run_partial_eval_test "((wrap (vau (a & rest) rest)) 1 2 3 4 5)")) - - (print "\n\nrecursion test\n\n") - (print (run_partial_eval_test "((wrap (vau (let1) - (let1 lambda (vau se (p b) (wrap (eval (array vau p b) se))) - ((lambda (x n) (x x n)) (lambda (recurse n) (cond (!= 0 n) (* n (recurse recurse (- n 1))) - true 1 )) 5) - ))) (vau de (s v b) (eval (array (array wrap (array vau (array s) b)) v) de)))")) - - (print "\n\nlambda recursion test\n\n") - (print (run_partial_eval_test "((wrap (vau (let1) - (let1 lambda (vau se (p b) (wrap (eval (array vau p b) se))) - (lambda (n) ((lambda (x n) (x x n)) (lambda (recurse n) (cond (!= 0 n) (* n (recurse recurse (- n 1))) - true 1 )) n)) - ))) (vau de (s v b) (eval (array (array wrap (array vau (array s) b)) v) de)))")) - - ; The issue with this one is that (x2 x2) trips the infinate recursion protector, but then - ; that array gets marked as attempted & needing no more evaluation, and is frozen forever. - ; Then, when the recursion is actually being used, it won't keep going and you only get - ; the first level. - (print "\n\nlambda recursion Y combiner test\n\n") - (print (run_partial_eval_test "((wrap (vau (let1) - (let1 lambda (vau se (p b) (wrap (eval (array vau p b) se))) - (let1 lapply (lambda (f1 p) (eval (concat (array (unwrap f1)) p))) - (let1 Y (lambda (f3) - ((lambda (x1) (x1 x1)) - (lambda (x2) (f3 (lambda (& y) (lapply (x2 x2) y)))))) - ((Y (lambda (recurse) (lambda (n) (cond (!= 0 n) (* n (recurse (- n 1))) - true 1)))) - 5) - ))))) (vau de (s v b) (eval (array (array wrap (array vau (array s) b)) v) de)))")) - - - (print (run_partial_eval_test "(len \"asdf\")")) - (print (run_partial_eval_test "(idx \"asdf\" 1)")) - (print (run_partial_eval_test "(slice \"asdf\" 1 3)")) - (print (run_partial_eval_test "(concat \"asdf\" \";lkj\")")) - - - (true_print "ok, hex of 0 is " (hex_digit #\0)) - (true_print "ok, hex of 1 is " (hex_digit #\1)) - (true_print "ok, hex of a is " (hex_digit #\a)) - (true_print "ok, hex of A is " (hex_digit #\A)) - (true_print "ok, hexify of 1337 is " (i64_le_hexify 1337)) - (true_print "ok, hexify of 10 is " (i64_le_hexify 10)) - (true_print "ok, hexify of 15 is " (i64_le_hexify 15)) - (true_print "ok, hexfy of 15 << 60 is " (i64_le_hexify (<< 15 60))) - (dlet ( - ;(output1 (wasm_to_binary (module))) - ;(output2 (wasm_to_binary (module - ; (import "wasi_unstable" "path_open" - ; '(func $path_open (param i32 i32 i32 i32 i32 i64 i64 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))) - ; (memory '$mem 1) - ; (global '$gi 'i32 (i32.const 8)) - ; (global '$gb '(mut i64) (i64.const 9)) - ; (table '$tab 2 'funcref) - ; (data (i32.const 16) "HellH") ;; adder to put, then data - - - ; (func '$start - ; (i32.store (i32.const 8) (i32.const 16)) ;; adder of data - ; (i32.store (i32.const 12) (i32.const 5)) ;; len of data - ; ;; open file - ; (call 0 ;$path_open - ; (i32.const 3) ;; file descriptor - ; (i32.const 0) ;; lookup flags - ; (i32.const 16) ;; path string * - ; (i32.load (i32.const 12)) ;; path string len - ; (i32.const 1) ;; o flags - ; (i64.const 66) ;; base rights - ; (i64.const 66) ;; inheriting rights - ; (i32.const 0) ;; fdflags - ; (i32.const 4) ;; opened fd out ptr - ; ) - ; (drop) - ; (block '$a - ; (block '$b - ; (br '$a) - ; (br_if '$b - ; (i32.const 3)) - ; (_loop '$l - ; (br '$a) - ; (br '$l) - ; ) - ; (_if '$myif - ; (i32.const 1) - ; (then - ; (i32.const 1) - ; (drop) - ; (br '$b) - ; ) - ; (else - ; (br '$myif) - ; ) - ; ) - ; (_if '$another - ; (i32.const 1) - ; (br '$b)) - ; (i32.const 1) - ; (_if '$third - ; (br '$b)) - ; (_if '$fourth - ; (br '$fourth)) - ; ) - ; ) - ; (call '$fd_read - ; (i32.const 0) ;; file descriptor - ; (i32.const 8) ;; *iovs - ; (i32.const 1) ;; iovs_len - ; (i32.const 12) ;; nwritten, overwrite buf len with it - ; ) - ; (drop) - - ; ;; print name - ; (call '$fd_write - ; (i32.load (i32.const 4)) ;; file descriptor - ; (i32.const 8) ;; *iovs - ; (i32.const 1) ;; iovs_len - ; (i32.const 4) ;; nwritten - ; ) - ; (drop) - ; ) - - ; (elem (i32.const 0) '$start '$start) - ; (export "memory" '(memory $mem)) - ; (export "_start" '(func $start)) - ;))) - (_ (true_print "first compile")) - (output3 (compile (partial_eval (read-string "(array 1 (array ((vau (x) x) a) (array \"asdf\")) 2)")) false)) - (_ (true_print "end first compile")) - (output3 (compile (partial_eval (read-string "(array 1 (array 1 2 3 4) 2 (array 1 2 3 4))")) false)) - (output3 (compile (partial_eval (read-string "empty_env")) false)) - (output3 (compile (partial_eval (read-string "(eval (array (array vau ((vau (x) x) (a b)) (array (array vau ((vau (x) x) x) (array) ((vau (x) x) x)))) 1 2) empty_env)")) false)) - (output3 (compile (partial_eval (read-string "(eval (array (array vau ((vau (x) x) (a b)) (array (array vau ((vau (x) x) x) (array) ((vau (x) x) x)))) empty_env 2) empty_env)")) false)) - (output3 (compile (partial_eval (read-string "(eval (array (array vau ((vau (x) x) x) (array) ((vau (x) x) x))))")) false)) - (output3 (compile (partial_eval (read-string "(vau (x) x)")) false)) - (output3 (compile (partial_eval (read-string "(vau (x) 1)")) false)) - - (output3 (compile (partial_eval (read-string "(array ((vau (x) x) exit) 1)")) false)) - - (output3 (compile (partial_eval (read-string "(array ((vau (x) x) write) 1 \"waa\" (vau (written code) (array ((vau (x) x) exit) 1)))")) false)) - - (output3 (compile (partial_eval (read-string "(array ((vau (x) x) write) 1 \"waa\" (vau (written code) (array ((vau (x) x) exit) written)))")) false)) - - (output3 (compile (partial_eval (read-string "(array ((vau (x) x) write) 1 \"waa\" (vau (written code) written))")) false)) - (output3 (compile (partial_eval (read-string "(array ((vau (x) x) write) 1 \"waa\" (vau (written code) code))")) false)) - (output3 (compile (partial_eval (read-string "(array ((vau (x) x) write) 1 \"waa\" (vau (written code) (array 1337 written 1338 code 1339)))")) false)) - - (output3 (compile (partial_eval (read-string "(array ((vau (x) x) write) 1 \"waa\" (vau (written code) (cond (= 0 code) written true code)))")) false)) - (output3 (compile (partial_eval (read-string "(array ((vau (x) x) write) 1 \"waa\" (vau (written code) (str (= 0 code) written true (array) code)))")) false)) - (output3 (compile (partial_eval (read-string "(array ((vau (x) x) write) 1 \"waa\" (vau (written code) (log (= 0 code) written true (array) code)))")) false)) - (output3 (compile (partial_eval (read-string "(array ((vau (x) x) write) 1 \"waa\" (vau (written code) (error (= 0 code) written true code)))")) false)) - ;(output3 (compile (partial_eval (read-string "(array ((vau (x) x) write) 1 \"waa\" (vau (written code) (or (= 0 code) written true code)))")) false)) - - (output3 (compile (partial_eval (read-string "(array ((vau (x) x) write) 1 \"waa\" (vau (written code) (+ written code 1337)))")) false)) - (output3 (compile (partial_eval (read-string "(array ((vau (x) x) write) 1 \"waa\" (vau (written code) (- written code 1337)))")) false)) - (output3 (compile (partial_eval (read-string "(array ((vau (x) x) write) 1 \"waa\" (vau (written code) (* written 1337)))")) false)) - (output3 (compile (partial_eval (read-string "(array ((vau (x) x) write) 1 \"waa\" (vau (written code) (/ 1337 written)))")) false)) - (output3 (compile (partial_eval (read-string "(array ((vau (x) x) write) 1 \"waa\" (vau (written code) (% 1337 written)))")) false)) - (output3 (compile (partial_eval (read-string "(array ((vau (x) x) write) 1 \"waa\" (vau (written code) (band 1337 written)))")) false)) - (output3 (compile (partial_eval (read-string "(array ((vau (x) x) write) 1 \"waa\" (vau (written code) (bor 1337 written)))")) false)) - (output3 (compile (partial_eval (read-string "(array ((vau (x) x) write) 1 \"waa\" (vau (written code) (bnot written)))")) false)) - (output3 (compile (partial_eval (read-string "(array ((vau (x) x) write) 1 \"waa\" (vau (written code) (bxor 1337 written)))")) false)) - (output3 (compile (partial_eval (read-string "(array ((vau (x) x) write) 1 \"waa\" (vau (written code) (<< 1337 written)))")) false)) - (output3 (compile (partial_eval (read-string "(array ((vau (x) x) write) 1 \"waa\" (vau (written code) (>> 1337 written)))")) false)) - - (output3 (compile (partial_eval (read-string "(array ((vau (x) x) write) 1 \"waa\" (vau (written code) (<= (array written) (array 1337))))")) false)) - - (output3 (compile (partial_eval (read-string "(array ((vau (x) x) write) 1 \"waa\" (vau (written code) (read-string (cond written \"true\" true 3))))")) false)) - (output3 (compile (partial_eval (read-string "(array ((vau (x) x) write) 1 \"waa\" (vau (written code) (read-string (cond written \" true\" true 3))))")) false)) - (output3 (compile (partial_eval (read-string "(array ((vau (x) x) write) 1 \"waa\" (vau (written code) (read-string (cond written \" true \" true 3))))")) false)) - (output3 (compile (partial_eval (read-string "(array ((vau (x) x) write) 1 \"waa\" (vau (written code) (read-string (cond written \" false\" true 3))))")) false)) - (output3 (compile (partial_eval (read-string "(array ((vau (x) x) write) 1 \"waa\" (vau (written code) (read-string (cond written \"(false (true () true) true)\" true 3))))")) false)) - (output3 (compile (partial_eval (read-string "(array ((vau (x) x) write) 1 \"waa\" (vau (written code) (read-string (cond written \"(false (true () true) true) true\" true 3))))")) false)) - - (output3 (compile (partial_eval (read-string "(array ((vau (x) x) open) 3 \"test_out\" (vau (fd code) (array ((vau (x) x) write) fd \"waa\" (vau (written code) (array written code)))))")) false)) - (output3 (compile (partial_eval (read-string "(array ((vau (x) x) open) 3 \"test_out\" (vau (fd code) (array ((vau (x) x) read) fd 10 (vau (data code) (array data code)))))")) false)) - - ;(_ (print (slurp "test_parse_in"))) - (output3 (compile (partial_eval (read-string "(array ((vau (x) x) open) 3 \"test_parse_in\" (vau (fd code) (array ((vau (x) x) read) fd 1000 (vau (data code) (read-string data)))))")) false)) - (output3 (compile (partial_eval (read-string "(array ((vau (x) x) write) 1 \"test_parse_in\" (vau (written code) (array (array written))))")) false)) - - - (output3 (compile (partial_eval (read-string "(array ((vau (x) x) write) 1 \"waa\" (vau (& args) (slice args 1 -1)))")) false)) - (output3 (compile (partial_eval (read-string "(array ((vau (x) x) write) 1 \"waa\" (vau (& args) (len args)))")) false)) - (output3 (compile (partial_eval (read-string "(array ((vau (x) x) write) 1 \"waa\" (vau (& args) (idx args 0)))")) false)) - (output3 (compile (partial_eval (read-string "(array ((vau (x) x) write) 1 \"waa\" (vau (& args) (slice (concat args (array 1 2 3 4) args) 1 -2)))")) false)) - - (output3 (compile (partial_eval (read-string "(array ((vau (x) x) write) 1 \"waa\" (vau (& args) (str-to-symbol (str args))))")) false)) - (output3 (compile (partial_eval (read-string "(array ((vau (x) x) write) 1 \"waa\" (vau (& args) (get-text (str-to-symbol (str args)))))")) false)) - (output3 (compile (partial_eval (read-string "(array ((vau (x) x) write) 1 \"waa\" (vau (& args) (wrap (cond args idx true 0))))")) false)) - (output3 (compile (partial_eval (read-string "(array ((vau (x) x) write) 1 \"waa\" (vau (& args) (wrap (wrap (cond args idx true 0)))))")) false)) - (output3 (compile (partial_eval (read-string "(array ((vau (x) x) write) 1 \"waa\" (vau (& args) (wrap (wrap (wrap (cond args idx true 0))))))")) false)) - (output3 (compile (partial_eval (read-string "(array ((vau (x) x) write) 1 \"waa\" (vau (& args) (unwrap (cond args idx true 0))))")) false)) - (output3 (compile (partial_eval (read-string "(array ((vau (x) x) write) 1 \"waa\" (vau (& args) (unwrap (cond args vau true 0))))")) false)) - - (output3 (compile (partial_eval (read-string "(array ((vau (x) x) write) 1 \"waa\" (vau (written code) (array (nil? written) (array? written) (bool? written) (env? written) (combiner? written) (string? written) (int? written) (symbol? written))))")) false)) - (output3 (compile (partial_eval (read-string "(array ((vau (x) x) write) 1 \"waa\" (vau de (written code) (array (nil? (cond written (array) true 4)) (array? (cond written (array 1 2) true 4)) (bool? (= 3 written)) (env? de) (combiner? (cond written (vau () 1) true 43)) (string? (cond written \"a\" 3 3)) (int? (cond written \"a\" 3 3)) (symbol? (cond written ((vau (x) x) x) 3 3)) written)))")) false)) - - (output3 (compile (partial_eval (read-string "(array ((vau (x) x) write) 1 \"waa\" (vau (& args) args))")) false)) - (output3 (compile (partial_eval (read-string "(array ((vau (x) x) write) 1 \"waa\" (vau (a & args) a))")) false)) - (output3 (compile (partial_eval (read-string "(array ((vau (x) x) write) 1 \"waa\" (vau (a & args) args))")) false)) - - (output3 (compile (partial_eval (read-string "(array ((vau (x) x) read) 0 10 (vau (data code) data))")) false)) - (output3 (compile (partial_eval (read-string "(array ((vau (x) x) read) 0 10 (vau (data code) (array ((vau (x) x) write) 1 data (vau (written code) (array written code)))))")) false)) - - (output3 (compile (partial_eval (read-string "(wrap (vau (x) x))")) false)) - (output3 (compile (partial_eval (read-string "len")) false)) - (output3 (compile (partial_eval (read-string "vau")) false)) - (output3 (compile (partial_eval (read-string "(array len 3 len)")) false)) - (output3 (compile (partial_eval (read-string "(+ 1 1337 (+ 1 2))")) false)) - (output3 (compile (partial_eval (read-string "\"hello world\"")) false)) - (output3 (compile (partial_eval (read-string "((vau (x) x) asdf)")) false)) - (output3 (compile (partial_eval (read-string "((wrap (vau (let1) - (let1 lambda (vau se (p b) (wrap (eval (array vau p b) se))) - (array ((vau (x) x) write) 1 \"hahah\" (vau (written code) ((lambda (x n) (x x n)) (lambda (recurse n) (cond (!= 0 n) (* n (recurse recurse (- n 1))) - true 1)) written))) - ))) (vau de (s v b) (eval (array (array vau (array s) b) (eval v de)) de)))")) false)) - (_ (write_file "./csc_out.wasm" output3)) - (output3 (compile (partial_eval (read-string "(nil? 1)")) false)) - ;(output3 (compile (partial_eval (read-string "(nil? nil)")) false)) - ) (void)) - ))) - - (single-test (lambda () (dlet ( - ;(output3 (compile (partial_eval (read-string "1337")) false)) - ;(output3 (compile (partial_eval (read-string "\"This is a longish sring to make sure alloc data is working properly\"")) false)) - ;(output3 (compile (partial_eval (read-string "((vau (x) x) write)")) false)) - ;(output3 (compile (partial_eval (read-string "(wrap (vau (x) x))")) false)) - ;(output3 (compile (partial_eval (read-string "(wrap (vau (x) (log 1337)))")) false)) - ;(output3 (compile (partial_eval (read-string "(wrap (vau (x) (+ x 1337)))")) false)) - ;(output3 (compile (partial_eval (read-string "(array ((vau (x) x) write) 1 \"w\" (vau (written code) (+ written code 1337)))")) false)) - ;(output3 (compile (partial_eval (read-string "((wrap (vau (let1) - ; (let1 lambda (vau se (p b) (wrap (eval (array vau p b) se))) - ; (array ((vau (x) x) write) 1 \"hahah\" (vau (written code) ((lambda (x n) (x x n)) (lambda (recurse n) (cond (!= 0 n) (* n (recurse recurse (- n 1))) - ; true 1)) written))) - ; ))) (vau de (s v b) (eval (array (array vau (array s) b) (eval v de)) de)))")) false)) - - - ;(output3 (compile (partial_eval (read-string - ; "((wrap (vau root_env (quote) - ; ((wrap (vau (let1) - - ; (let1 lambda (vau se (p b) (wrap (eval (array vau p b) se))) - ; (let1 current-env (vau de () de) - ; (let1 lapply (lambda (f p) (eval (concat (array (unwrap f)) p) (current-env))) - ; (array (quote write) 1 \"test_self_out2\" (vau (written code) 1)) - ; ))) - - ; )) (vau de (s v b) (eval (array (array vau (array s) b) (eval v de)) de))) - ; )) (vau (x5) x5))")) false)) - ;(_ (write_file "./csc_out.wasm" output3)) - - ;(_ (write_file "./csc_out.wasm" (compile (partial_eval (read-string - ; "(array ((vau (x5) x5) write) 1 \"written\" (vau (written code) (len (cond (= 0 written) \"asdf\" true \"sdf\"))))")) false))) - - ;(_ (write_file "./csc_out.wasm" (compile (partial_eval (read-string - ; "(array ((vau (x5) x5) write) 1 \"written\" (vau (written code) (idx (cond (= 0 written) \"asdf\" true \"sdf\") 1)))")) false))) - - ;(_ (write_file "./csc_out.wasm" (compile (partial_eval (read-string - ; "(array ((vau (x5) x5) write) 1 \"written\" (vau (written code) (slice (cond (= 0 written) \"asdf\" true \"abcdefghi\") 1 3)))")) false))) - - ;(_ (write_file "./csc_out.wasm" (compile (partial_eval (read-string - ; "(array ((vau (x5) x5) write) 1 \"written\" (vau (written code) (concat \"hehe\" (cond (= 0 written) \"asdf\" true \"abcdefghi\"))))")) false))) - - (_ (write_file "./csc_out.wasm" (compile (partial_eval (read-string - "(array ((vau (x) x) write) 1 \"enter form: \" (vau (written code) - (array ((vau (x) x) read) 0 60 (vau (data code) - (array ((vau (x) x) exit) (eval (read-string data))) - )) - - ))")) false))) - - (output3 (compile (partial_eval (read-string "(array ((vau (x) x) read) 0 10 (vau (data code) data))")) false)) - - ) void))) - - (run-compiler (lambda (dont_partial_eval dont_lazy_env dont_y_comb dont_prim_inline dont_closure_inline f) - (dlet ( - (_ (true_print "reading in!")) - (read_in (read-string (slurp f))) - - ; This is basicaly (compile root_env)>) - ; this does mean that without partial eval this is an extra and unnecessary lookup of 'eval in the root env but w/e, it's a single load - ; empty partial_eval_ctx empty partial_eval_error value to compile - (body_value (marked_array true false nil (array (marked_symbol nil 'eval) (marked_array true false nil (array quote_internal (mark read_in)) true) root_marked_env) true)) - (constructed_body (idx (try_unval body_value (lambda (_) nil)) 1)) - (constructed_func (marked_comb 0 (+ env_id_start 1) 'outer root_marked_env false (array) constructed_body)) - (constructed_value (marked_array true false nil (array (marked_symbol nil 'run) constructed_func) true)) - (to_compile (array (array (+ env_id_start 1) empty_dict) nil constructed_value)) - ;(_ (true_print "done partialy evaling, now compiling")) - (_ (true_print "going")) - (bytes (compile to_compile dont_partial_eval dont_lazy_env dont_y_comb dont_prim_inline dont_closure_inline)) - ;(_ (true_print "compiled, writng out")) - (_ (write_file "./csc_out.wasm" bytes)) - ;(_ (true_print "written out")) - ) (void)) - )) - -) - (begin - ;(test-most) - ;(single-test) - ;(run-compiler "small_test.kp") - ;(run-compiler "to_compile.kp") - (true_print "args are " args) - (dlet ( (com (if (> (len args) 0) (idx args 0) "")) ) - (cond ((= "test" com) (test-most)) - ((= "single" com) (single-test)) - (true (run-compiler - (and (>= (len args) 2) (= "no_partial_eval" (idx args 1))) - (and (>= (len args) 2) (= "no_lazy_env" (idx args 1))) - (and (>= (len args) 2) (= "no_y_comb" (idx args 1))) - (and (>= (len args) 2) (= "no_prim_inline" (idx args 1))) - (and (>= (len args) 2) (= "no_closure_inline" (idx args 1))) - com)))) - - ;(true_print "GLOBAL_MAX was " GLOBAL_MAX) - ;(profile-dump-html) - ) -) - -;;;;;;;;;;;;;; -; Known TODOs -;;;;;;;;;;;;;; -; -; * NON NAIVE REFCOUNTING -; EVENTUALLY: Support some hard core partial_eval that an fully make (foldl or stuff) short circut effeciencly with double-inlining, finally -; addressing the strict-languages-don't-compose thing diff --git a/sl/Cargo.lock b/sl/Cargo.lock new file mode 100644 index 0000000..b622cfb --- /dev/null +++ b/sl/Cargo.lock @@ -0,0 +1,902 @@ +# This file is automatically @generated by Cargo. +# It is not intended for manual editing. +version = 3 + +[[package]] +name = "ahash" +version = "0.8.6" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "91429305e9f0a25f6205c5b8e0d2db09e0708a7a6df0f42212bb56c32c8ac97a" +dependencies = [ + "cfg-if", + "once_cell", + "version_check", + "zerocopy", +] + +[[package]] +name = "aho-corasick" +version = "1.1.2" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "b2969dcb958b36655471fc61f7e416fa76033bdd4bfed0678d8fee1e2d07a1f0" +dependencies = [ + "memchr", +] + +[[package]] +name = "anyhow" +version = "1.0.75" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "a4668cab20f66d8d020e1fbc0ebe47217433c1b6c8f2040faf858554e394ace6" + +[[package]] +name = "arbitrary" +version = "1.3.2" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "7d5a26814d8dcb93b0e5a0ff3c6d80a8843bafb21b39e8e18a6f05471870e110" + +[[package]] +name = "ascii-canvas" +version = "3.0.0" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "8824ecca2e851cec16968d54a01dd372ef8f95b244fb84b84e70128be347c3c6" +dependencies = [ + "term", +] + +[[package]] +name = "autocfg" +version = "1.1.0" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "d468802bab17cbc0cc575e9b053f41e72aa36bfa6b7f55e3529ffa43161b97fa" + +[[package]] +name = "bit-set" +version = "0.5.3" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "0700ddab506f33b20a03b13996eccd309a48e5ff77d0d95926aa0210fb4e95f1" +dependencies = [ + "bit-vec", +] + +[[package]] +name = "bit-vec" +version = "0.6.3" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "349f9b6a179ed607305526ca489b34ad0a41aed5f7980fa90eb03160b69598fb" + +[[package]] +name = "bitflags" +version = "1.3.2" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "bef38d45163c2f1dde094a7dfd33ccf595c92905c8f8f4fdc18d06fb1037718a" + +[[package]] +name = "bitflags" +version = "2.4.1" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "327762f6e5a765692301e5bb513e0d9fef63be86bbc14528052b1cd3e6f03e07" + +[[package]] +name = "bumpalo" +version = "3.14.0" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "7f30e7476521f6f8af1a1c4c0b8cc94f0bee37d91763d0ca2665f299b6cd8aec" + +[[package]] +name = "cfg-if" +version = "1.0.0" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "baf1de4339761588bc0619e3cbc0120ee582ebb74b53b4efbf79117bd2da40fd" + +[[package]] +name = "cranelift" +version = "0.101.4" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "e4fdf311b2564edbf43d3a06335d309814f6ec60f55d090885d68e1a2e664c04" +dependencies = [ + "cranelift-codegen", + "cranelift-frontend", +] + +[[package]] +name = "cranelift-bforest" +version = "0.101.4" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "2b5bb9245ec7dcc04d03110e538d31f0969d301c9d673145f4b4d5c3478539a3" +dependencies = [ + "cranelift-entity", +] + +[[package]] +name = "cranelift-codegen" +version = "0.101.4" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "ebb18d10e5ddac43ba4ca8fd4e310938569c3e484cc01b6372b27dc5bb4dfd28" +dependencies = [ + "bumpalo", + "cranelift-bforest", + "cranelift-codegen-meta", + "cranelift-codegen-shared", + "cranelift-control", + "cranelift-entity", + "cranelift-isle", + "gimli", + "hashbrown 0.14.2", + "log", + "regalloc2", + "smallvec", + "target-lexicon", +] + +[[package]] +name = "cranelift-codegen-meta" +version = "0.101.4" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "7a3ce6d22982c1b9b6b012654258bab1a13947bb12703518bef06b1a4867c3d6" +dependencies = [ + "cranelift-codegen-shared", +] + +[[package]] +name = "cranelift-codegen-shared" +version = "0.101.4" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "47220fd4f9a0ce23541652b6f16f83868d282602c600d14934b2a4c166b4bd80" + +[[package]] +name = "cranelift-control" +version = "0.101.4" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "ed5a4c42672aea9b6e820046b52e47a1c05d3394a6cdf4cb3c3c4b702f954bd2" +dependencies = [ + "arbitrary", +] + +[[package]] +name = "cranelift-entity" +version = "0.101.4" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "0b4e9a3296fc827f9d35135dc2c0c8dd8d8359eb1ef904bae2d55d5bcb0c9f94" + +[[package]] +name = "cranelift-frontend" +version = "0.101.4" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "33ec537d0f0b8e084517f3e7bfa1d89af343d7c7df455573fca9f272d4e01267" +dependencies = [ + "cranelift-codegen", + "log", + "smallvec", + "target-lexicon", +] + +[[package]] +name = "cranelift-isle" +version = "0.101.4" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "45bab6d69919d210a50331d35cc6ce111567bc040aebac63a8ae130d0400a075" + +[[package]] +name = "cranelift-jit" +version = "0.101.4" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "1daca8224e77263494e1d949daeb0a0a0992f9c489d4dc395bfc8ddda0eafcaf" +dependencies = [ + "anyhow", + "cranelift-codegen", + "cranelift-control", + "cranelift-entity", + "cranelift-module", + "cranelift-native", + "libc", + "log", + "region", + "target-lexicon", + "wasmtime-jit-icache-coherence", + "windows-sys", +] + +[[package]] +name = "cranelift-module" +version = "0.101.4" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "533ebbad90a77980bdbbe6bd4beee9598a74db06316e8a9def7a6d9564e19f5e" +dependencies = [ + "anyhow", + "cranelift-codegen", + "cranelift-control", +] + +[[package]] +name = "cranelift-native" +version = "0.101.4" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "f32e81605f352cf37af5463f11cd7deec7b6572741931a8d372f7fdd4a744f5d" +dependencies = [ + "cranelift-codegen", + "libc", + "target-lexicon", +] + +[[package]] +name = "crunchy" +version = "0.2.2" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "7a81dae078cea95a014a339291cec439d2f232ebe854a9d672b796c6afafa9b7" + +[[package]] +name = "diff" +version = "0.1.13" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "56254986775e3233ffa9c4d7d3faaf6d36a2c09d30b20687e9f88bc8bafc16c8" + +[[package]] +name = "dirs-next" +version = "2.0.0" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "b98cf8ebf19c3d1b223e151f99a4f9f0690dca41414773390fc824184ac833e1" +dependencies = [ + "cfg-if", + "dirs-sys-next", +] + +[[package]] +name = "dirs-sys-next" +version = "0.1.2" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "4ebda144c4fe02d1f7ea1a7d9641b6fc6b580adcfa024ae48797ecdeb6825b4d" +dependencies = [ + "libc", + "redox_users", + "winapi", +] + +[[package]] +name = "either" +version = "1.9.0" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "a26ae43d7bcc3b814de94796a5e736d4029efb0ee900c12e2d54c993ad1a1e07" + +[[package]] +name = "ena" +version = "0.14.2" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "c533630cf40e9caa44bd91aadc88a75d75a4c3a12b4cfde353cbed41daa1e1f1" +dependencies = [ + "log", +] + +[[package]] +name = "equivalent" +version = "1.0.1" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "5443807d6dff69373d433ab9ef5378ad8df50ca6298caf15de6e52e24aaf54d5" + +[[package]] +name = "errno" +version = "0.3.7" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "f258a7194e7f7c2a7837a8913aeab7fd8c383457034fa20ce4dd3dcb813e8eb8" +dependencies = [ + "libc", + "windows-sys", +] + +[[package]] +name = "fallible-iterator" +version = "0.3.0" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "2acce4a10f12dc2fb14a218589d4f1f62ef011b2d0cc4b3cb1bba8e94da14649" + +[[package]] +name = "fixedbitset" +version = "0.4.2" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "0ce7134b9999ecaf8bcd65542e436736ef32ddca1b3e06094cb6ec5755203b80" + +[[package]] +name = "getrandom" +version = "0.2.11" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "fe9006bed769170c11f845cf00c7c1e9092aeb3f268e007c3e760ac68008070f" +dependencies = [ + "cfg-if", + "libc", + "wasi", +] + +[[package]] +name = "gimli" +version = "0.28.0" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "6fb8d784f27acf97159b40fc4db5ecd8aa23b9ad5ef69cdd136d3bc80665f0c0" +dependencies = [ + "fallible-iterator", + "indexmap", + "stable_deref_trait", +] + +[[package]] +name = "hashbrown" +version = "0.13.2" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "43a3c133739dddd0d2990f9a4bdf8eb4b21ef50e4851ca85ab661199821d510e" +dependencies = [ + "ahash", +] + +[[package]] +name = "hashbrown" +version = "0.14.2" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "f93e7192158dbcda357bdec5fb5788eebf8bbac027f3f33e719d29135ae84156" + +[[package]] +name = "hermit-abi" +version = "0.3.3" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "d77f7ec81a6d05a3abb01ab6eb7590f6083d08449fe5a1c8b1e620283546ccb7" + +[[package]] +name = "indexmap" +version = "2.1.0" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "d530e1a18b1cb4c484e6e34556a0d948706958449fca0cab753d649f2bce3d1f" +dependencies = [ + "equivalent", + "hashbrown 0.14.2", +] + +[[package]] +name = "is-terminal" +version = "0.4.9" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "cb0889898416213fab133e1d33a0e5858a48177452750691bde3666d0fdbaf8b" +dependencies = [ + "hermit-abi", + "rustix", + "windows-sys", +] + +[[package]] +name = "itertools" +version = "0.10.5" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "b0fd2260e829bddf4cb6ea802289de2f86d6a7a690192fbe91b3f46e0f2c8473" +dependencies = [ + "either", +] + +[[package]] +name = "lalrpop" +version = "0.20.0" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "da4081d44f4611b66c6dd725e6de3169f9f63905421e8626fcb86b6a898998b8" +dependencies = [ + "ascii-canvas", + "bit-set", + "diff", + "ena", + "is-terminal", + "itertools", + "lalrpop-util", + "petgraph", + "pico-args", + "regex", + "regex-syntax 0.7.5", + "string_cache", + "term", + "tiny-keccak", + "unicode-xid", +] + +[[package]] +name = "lalrpop-util" +version = "0.20.0" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "3f35c735096c0293d313e8f2a641627472b83d01b937177fe76e5e2708d31e0d" +dependencies = [ + "regex", +] + +[[package]] +name = "libc" +version = "0.2.150" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "89d92a4743f9a61002fae18374ed11e7973f530cb3a3255fb354818118b2203c" + +[[package]] +name = "libredox" +version = "0.0.1" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "85c833ca1e66078851dba29046874e38f08b2c883700aa29a03ddd3b23814ee8" +dependencies = [ + "bitflags 2.4.1", + "libc", + "redox_syscall", +] + +[[package]] +name = "linux-raw-sys" +version = "0.4.11" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "969488b55f8ac402214f3f5fd243ebb7206cf82de60d3172994707a4bcc2b829" + +[[package]] +name = "lock_api" +version = "0.4.11" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "3c168f8615b12bc01f9c17e2eb0cc07dcae1940121185446edc3744920e8ef45" +dependencies = [ + "autocfg", + "scopeguard", +] + +[[package]] +name = "log" +version = "0.4.20" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "b5e6163cb8c49088c2c36f57875e58ccd8c87c7427f7fbd50ea6710b2f3f2e8f" + +[[package]] +name = "mach" +version = "0.3.2" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "b823e83b2affd8f40a9ee8c29dbc56404c1e34cd2710921f2801e2cf29527afa" +dependencies = [ + "libc", +] + +[[package]] +name = "memchr" +version = "2.6.4" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "f665ee40bc4a3c5590afb1e9677db74a508659dfd71e126420da8274909a0167" + +[[package]] +name = "new_debug_unreachable" +version = "1.0.4" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "e4a24736216ec316047a1fc4252e27dabb04218aa4a3f37c6e7ddbf1f9782b54" + +[[package]] +name = "once_cell" +version = "1.18.0" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "dd8b5dd2ae5ed71462c540258bedcb51965123ad7e7ccf4b9a8cafaa4a63576d" + +[[package]] +name = "parking_lot" +version = "0.12.1" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "3742b2c103b9f06bc9fff0a37ff4912935851bee6d36f3c02bcc755bcfec228f" +dependencies = [ + "lock_api", + "parking_lot_core", +] + +[[package]] +name = "parking_lot_core" +version = "0.9.9" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "4c42a9226546d68acdd9c0a280d17ce19bfe27a46bf68784e4066115788d008e" +dependencies = [ + "cfg-if", + "libc", + "redox_syscall", + "smallvec", + "windows-targets", +] + +[[package]] +name = "petgraph" +version = "0.6.4" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "e1d3afd2628e69da2be385eb6f2fd57c8ac7977ceeff6dc166ff1657b0e386a9" +dependencies = [ + "fixedbitset", + "indexmap", +] + +[[package]] +name = "phf_shared" +version = "0.10.0" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "b6796ad771acdc0123d2a88dc428b5e38ef24456743ddb1744ed628f9815c096" +dependencies = [ + "siphasher", +] + +[[package]] +name = "pico-args" +version = "0.5.0" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "5be167a7af36ee22fe3115051bc51f6e6c7054c9348e28deb4f49bd6f705a315" + +[[package]] +name = "precomputed-hash" +version = "0.1.1" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "925383efa346730478fb4838dbe9137d2a47675ad789c546d150a6e1dd4ab31c" + +[[package]] +name = "proc-macro2" +version = "1.0.69" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "134c189feb4956b20f6f547d2cf727d4c0fe06722b20a0eec87ed445a97f92da" +dependencies = [ + "unicode-ident", +] + +[[package]] +name = "quote" +version = "1.0.33" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "5267fca4496028628a95160fc423a33e8b2e6af8a5302579e322e4b520293cae" +dependencies = [ + "proc-macro2", +] + +[[package]] +name = "redox_syscall" +version = "0.4.1" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "4722d768eff46b75989dd134e5c353f0d6296e5aaa3132e776cbdb56be7731aa" +dependencies = [ + "bitflags 1.3.2", +] + +[[package]] +name = "redox_users" +version = "0.4.4" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "a18479200779601e498ada4e8c1e1f50e3ee19deb0259c25825a98b5603b2cb4" +dependencies = [ + "getrandom", + "libredox", + "thiserror", +] + +[[package]] +name = "regalloc2" +version = "0.9.3" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "ad156d539c879b7a24a363a2016d77961786e71f48f2e2fc8302a92abd2429a6" +dependencies = [ + "hashbrown 0.13.2", + "log", + "rustc-hash", + "slice-group-by", + "smallvec", +] + +[[package]] +name = "regex" +version = "1.10.2" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "380b951a9c5e80ddfd6136919eef32310721aa4aacd4889a8d39124b026ab343" +dependencies = [ + "aho-corasick", + "memchr", + "regex-automata", + "regex-syntax 0.8.2", +] + +[[package]] +name = "regex-automata" +version = "0.4.3" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "5f804c7828047e88b2d32e2d7fe5a105da8ee3264f01902f796c8e067dc2483f" +dependencies = [ + "aho-corasick", + "memchr", + "regex-syntax 0.8.2", +] + +[[package]] +name = "regex-syntax" +version = "0.7.5" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "dbb5fb1acd8a1a18b3dd5be62d25485eb770e05afb408a9627d14d451bae12da" + +[[package]] +name = "regex-syntax" +version = "0.8.2" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "c08c74e62047bb2de4ff487b251e4a92e24f48745648451635cec7d591162d9f" + +[[package]] +name = "region" +version = "2.2.0" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "877e54ea2adcd70d80e9179344c97f93ef0dffd6b03e1f4529e6e83ab2fa9ae0" +dependencies = [ + "bitflags 1.3.2", + "libc", + "mach", + "winapi", +] + +[[package]] +name = "rustc-hash" +version = "1.1.0" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "08d43f7aa6b08d49f382cde6a7982047c3426db949b1424bc4b7ec9ae12c6ce2" + +[[package]] +name = "rustix" +version = "0.38.25" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "dc99bc2d4f1fed22595588a013687477aedf3cdcfb26558c559edb67b4d9b22e" +dependencies = [ + "bitflags 2.4.1", + "errno", + "libc", + "linux-raw-sys", + "windows-sys", +] + +[[package]] +name = "rustversion" +version = "1.0.14" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "7ffc183a10b4478d04cbbbfc96d0873219d962dd5accaff2ffbd4ceb7df837f4" + +[[package]] +name = "scopeguard" +version = "1.2.0" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "94143f37725109f92c262ed2cf5e59bce7498c01bcc1502d7b9afe439a4e9f49" + +[[package]] +name = "siphasher" +version = "0.3.11" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "38b58827f4464d87d377d175e90bf58eb00fd8716ff0a62f80356b5e61555d0d" + +[[package]] +name = "sl" +version = "0.1.0" +dependencies = [ + "anyhow", + "cranelift", + "cranelift-jit", + "cranelift-module", + "cranelift-native", + "lalrpop", + "lalrpop-util", + "once_cell", + "regex", +] + +[[package]] +name = "slice-group-by" +version = "0.3.1" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "826167069c09b99d56f31e9ae5c99049e932a98c9dc2dac47645b08dbbf76ba7" + +[[package]] +name = "smallvec" +version = "1.11.2" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "4dccd0940a2dcdf68d092b8cbab7dc0ad8fa938bf95787e1b916b0e3d0e8e970" + +[[package]] +name = "stable_deref_trait" +version = "1.2.0" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "a8f112729512f8e442d81f95a8a7ddf2b7c6b8a1a6f509a95864142b30cab2d3" + +[[package]] +name = "string_cache" +version = "0.8.7" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "f91138e76242f575eb1d3b38b4f1362f10d3a43f47d182a5b359af488a02293b" +dependencies = [ + "new_debug_unreachable", + "once_cell", + "parking_lot", + "phf_shared", + "precomputed-hash", +] + +[[package]] +name = "syn" +version = "2.0.39" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "23e78b90f2fcf45d3e842032ce32e3f2d1545ba6636271dcbf24fa306d87be7a" +dependencies = [ + "proc-macro2", + "quote", + "unicode-ident", +] + +[[package]] +name = "target-lexicon" +version = "0.12.12" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "14c39fd04924ca3a864207c66fc2cd7d22d7c016007f9ce846cbb9326331930a" + +[[package]] +name = "term" +version = "0.7.0" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "c59df8ac95d96ff9bede18eb7300b0fda5e5d8d90960e76f8e14ae765eedbf1f" +dependencies = [ + "dirs-next", + "rustversion", + "winapi", +] + +[[package]] +name = "thiserror" +version = "1.0.50" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "f9a7210f5c9a7156bb50aa36aed4c95afb51df0df00713949448cf9e97d382d2" +dependencies = [ + "thiserror-impl", +] + +[[package]] +name = "thiserror-impl" +version = "1.0.50" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "266b2e40bc00e5a6c09c3584011e08b06f123c00362c92b975ba9843aaaa14b8" +dependencies = [ + "proc-macro2", + "quote", + "syn", +] + +[[package]] +name = "tiny-keccak" +version = "2.0.2" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "2c9d3793400a45f954c52e73d068316d76b6f4e36977e3fcebb13a2721e80237" +dependencies = [ + "crunchy", +] + +[[package]] +name = "unicode-ident" +version = "1.0.12" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "3354b9ac3fae1ff6755cb6db53683adb661634f67557942dea4facebec0fee4b" + +[[package]] +name = "unicode-xid" +version = "0.2.4" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "f962df74c8c05a667b5ee8bcf162993134c104e96440b663c8daa176dc772d8c" + +[[package]] +name = "version_check" +version = "0.9.4" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "49874b5167b65d7193b8aba1567f5c7d93d001cafc34600cee003eda787e483f" + +[[package]] +name = "wasi" +version = "0.11.0+wasi-snapshot-preview1" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "9c8d87e72b64a3b4db28d11ce29237c246188f4f51057d65a7eab63b7987e423" + +[[package]] +name = "wasmtime-jit-icache-coherence" +version = "14.0.4" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "f67e6be36375c39cff57ed3b137ab691afbf2d9ba8ee1c01f77888413f218749" +dependencies = [ + "cfg-if", + "libc", + "windows-sys", +] + +[[package]] +name = "winapi" +version = "0.3.9" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "5c839a674fcd7a98952e593242ea400abe93992746761e38641405d28b00f419" +dependencies = [ + "winapi-i686-pc-windows-gnu", + "winapi-x86_64-pc-windows-gnu", +] + +[[package]] +name = "winapi-i686-pc-windows-gnu" +version = "0.4.0" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "ac3b87c63620426dd9b991e5ce0329eff545bccbbb34f3be09ff6fb6ab51b7b6" + +[[package]] +name = "winapi-x86_64-pc-windows-gnu" +version = "0.4.0" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "712e227841d057c1ee1cd2fb22fa7e5a5461ae8e48fa2ca79ec42cfc1931183f" + +[[package]] +name = "windows-sys" +version = "0.48.0" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "677d2418bec65e3338edb076e806bc1ec15693c5d0104683f2efe857f61056a9" +dependencies = [ + "windows-targets", +] + +[[package]] +name = "windows-targets" +version = "0.48.5" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "9a2fa6e2155d7247be68c096456083145c183cbbbc2764150dda45a87197940c" +dependencies = [ + "windows_aarch64_gnullvm", + "windows_aarch64_msvc", + "windows_i686_gnu", + "windows_i686_msvc", + "windows_x86_64_gnu", + "windows_x86_64_gnullvm", + "windows_x86_64_msvc", +] + +[[package]] +name = "windows_aarch64_gnullvm" +version = "0.48.5" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "2b38e32f0abccf9987a4e3079dfb67dcd799fb61361e53e2882c3cbaf0d905d8" + +[[package]] +name = "windows_aarch64_msvc" +version = "0.48.5" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "dc35310971f3b2dbbf3f0690a219f40e2d9afcf64f9ab7cc1be722937c26b4bc" + +[[package]] +name = "windows_i686_gnu" +version = "0.48.5" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "a75915e7def60c94dcef72200b9a8e58e5091744960da64ec734a6c6e9b3743e" + +[[package]] +name = "windows_i686_msvc" +version = "0.48.5" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "8f55c233f70c4b27f66c523580f78f1004e8b5a8b659e05a4eb49d4166cca406" + +[[package]] +name = "windows_x86_64_gnu" +version = "0.48.5" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "53d40abd2583d23e4718fddf1ebec84dbff8381c07cae67ff7768bbf19c6718e" + +[[package]] +name = "windows_x86_64_gnullvm" +version = "0.48.5" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "0b7b52767868a23d5bab768e390dc5f5c55825b6d30b86c844ff2dc7414044cc" + +[[package]] +name = "windows_x86_64_msvc" +version = "0.48.5" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "ed94fce61571a4006852b7389a063ab983c02eb1bb37b47f8272ce92d06d9538" + +[[package]] +name = "zerocopy" +version = "0.7.26" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "e97e415490559a91254a2979b4829267a57d2fcd741a98eee8b722fb57289aa0" +dependencies = [ + "zerocopy-derive", +] + +[[package]] +name = "zerocopy-derive" +version = "0.7.26" +source = "registry+https://github.com/rust-lang/crates.io-index" +checksum = "dd7e48ccf166952882ca8bd778a43502c64f33bf94c12ebe2a7f08e5a0f6689f" +dependencies = [ + "proc-macro2", + "quote", + "syn", +] diff --git a/kr/Cargo.toml b/sl/Cargo.toml similarity index 52% rename from kr/Cargo.toml rename to sl/Cargo.toml index e4f6b3b..ee4f801 100644 --- a/kr/Cargo.toml +++ b/sl/Cargo.toml @@ -1,20 +1,22 @@ [package] -name = "kr" +name = "sl" version = "0.1.0" edition = "2021" -build = "build.rs" # See more keys and their definitions at https://doc.rust-lang.org/cargo/reference/manifest.html - [profile.bench] debug = true [dependencies] -lalrpop-util = {version="0.19.7", features=["lexer"]} +lalrpop-util = {version="0.20", features=["lexer"]} regex = "1" -once_cell = "1.17.0" +once_cell = "1" anyhow = "1" +cranelift = "0.101.4" +cranelift-module = "0.101.4" +cranelift-jit = "0.101.4" +cranelift-native = "0.101.4" [build-dependencies] -lalrpop = "0.19.7" +lalrpop = "0.20" diff --git a/kr/build.rs b/sl/build.rs similarity index 100% rename from kr/build.rs rename to sl/build.rs diff --git a/sl/src/grammar.lalrpop b/sl/src/grammar.lalrpop new file mode 100644 index 0000000..b308c59 --- /dev/null +++ b/sl/src/grammar.lalrpop @@ -0,0 +1,31 @@ +use std::str::FromStr; +use std::rc::Rc; +use sl::Form; + +grammar; + +pub Term: Rc = { + NUM => Rc::new(Form::Int(i32::from_str(<>).unwrap())), + SYM => Rc::new(Form::Symbol(<>.to_owned())), + "(" ")" => <>.unwrap_or(Rc::new(Form::Nil)), + "'" => Rc::new(Form::Pair(Rc::new(Form::Symbol("quote".to_owned())), Rc::new(Form::Pair(<>, Rc::new(Form::Nil))))), + "!" => { + h.append(t).unwrap() + }, +}; +ListInside: Rc = { + => Rc::new(Form::Pair(<>, Rc::new(Form::Nil))), + => Rc::new(Form::Pair(h, t)), + "." => Rc::new(Form::Pair(a, d)), +} +match { + "(", + ")", + ".", + "'", + "!", + r"[0-9]+" => NUM, + r"[a-zA-Z+*/_=?%&|^<>-][\w+*/=_?%&|^<>-]*" => SYM, + r"(;[^\n]*\n)|\s+" => { } +} + diff --git a/sl/src/lib.rs b/sl/src/lib.rs new file mode 100644 index 0000000..b862149 --- /dev/null +++ b/sl/src/lib.rs @@ -0,0 +1,186 @@ +use std::rc::Rc; +use std::collections::BTreeMap; +use std::fmt; + +use anyhow::{anyhow,Result}; + +#[derive(Debug, Eq, PartialEq)] +pub enum Form { + Nil, + Int(i32), + Bool(bool), + Symbol(String), + Pair(Rc,Rc), + Prim(Prim), +} + +#[derive(Debug, Eq, PartialEq, Clone, Copy)] +pub enum Prim { + Add, + Mul, + Eq, +} + +impl Form { + fn new_nil() -> Rc { + Rc::new(Form::Nil) + } + fn new_int(i: i32) -> Rc { + Rc::new(Form::Int(i)) + } + fn new_bool(b: bool) -> Rc { + Rc::new(Form::Bool(b)) + } + fn truthy(&self) -> bool { + match self { + Form::Bool(b) => *b, + Form::Nil => false, + _ => true, + } + } + fn int(&self) -> Result { + match self { + Form::Int(i) => Ok(*i), + _ => Err(anyhow!("int on not a int")), + } + } + fn prim(&self) -> Result { + match self { + Form::Prim(p) => Ok(*p), + _ => Err(anyhow!("prim on not a prim")), + } + } + fn sym(&self) -> Result<&str> { + match self { + Form::Symbol(s) => Ok(s), + _ => Err(anyhow!("sym on not a sym")), + } + } + fn pair(&self) -> Result<(Rc,Rc)> { + match self { + Form::Pair(car, cdr) => Ok((Rc::clone(car),Rc::clone(cdr))), + _ => Err(anyhow!("pair on not a pair")), + } + } + fn car(&self) -> Result> { + match self { + Form::Pair(car, _cdr) => Ok(Rc::clone(car)), + _ => Err(anyhow!("car on not a pair")), + } + } + fn cdr(&self) -> Result> { + match self { + Form::Pair(_car, cdr) => Ok(Rc::clone(cdr)), + _ => Err(anyhow!("cdr on not a pair")), + } + } + fn is_nil(&self) -> bool { + match self { + Form::Nil => true, + _ => false, + } + } + pub fn append(&self, x: Rc) -> Result> { + match self { + Form::Pair(car, cdr) => cdr.append(x).map(|x| Rc::new(Form::Pair(Rc::clone(car), x))), + Form::Nil => Ok(Rc::new(Form::Pair(x, Rc::new(Form::Nil)))), + _ => Err(anyhow!("append to not a pair")), + } + } +} + +pub struct Env { + m: BTreeMap> +} +impl Env { + pub fn root_env() -> Env { + Env { + m: [ + ("+", Rc::new(Form::Prim(Prim::Add))), + ("*", Rc::new(Form::Prim(Prim::Mul))), + ("=", Rc::new(Form::Prim(Prim::Eq))), + ].into_iter().map(|(s,p)| (s.to_owned(), p)).collect() + } + } + pub fn lookup(&self, s: &str) -> Result> { + Ok(Rc::clone(self.m.get(s).ok_or(anyhow!("lookup failed"))?)) + } +} + +pub fn tree_walker_eval(f: Rc, e: &mut Env) -> Result> { + Ok(match &*f { + Form::Symbol(s) => e.lookup(s)?, + Form::Pair(car, cdr) => { + match &**car { + Form::Symbol(s) if s == "if" => { + if tree_walker_eval(cdr.car()?, e)?.truthy() { + tree_walker_eval(cdr.cdr()?.car()?, e)? + } else { + tree_walker_eval(cdr.cdr()?.cdr()?.car()?, e)? + } + + } + _ => { + let comb = tree_walker_eval(Rc::clone(car), e)?; + let a = tree_walker_eval(cdr.car()?, e)?; + let b = tree_walker_eval(cdr.cdr()?.car()?, e)?; + match comb.prim().unwrap() { + Prim::Add => Form::new_int(a.int()? + b.int()?), + Prim::Mul => Form::new_int(a.int()? * b.int()?), + Prim::Eq => Form::new_bool(a == b), + } + } + } + }, + _ => f + }) +} + +// todo, strings not symbols? +impl From for Form { fn from(item: String) -> Self { Form::Symbol(item) } } +impl From<&str> for Form { fn from(item: &str) -> Self { Form::Symbol(item.to_owned()) } } +impl From for Form { fn from(item: i32) -> Self { Form::Int(item) } } +impl From for Form { fn from(item: bool) -> Self { Form::Bool(item) } } +impl, B: Into> From<(A, B)> for Form { + fn from(item: (A, B)) -> Self { + Form::Pair(Rc::new(item.0.into()), Rc::new(item.1.into())) + } +} + +impl fmt::Display for Form { + fn fmt(&self, f: &mut fmt::Formatter<'_>) -> fmt::Result { + match self { + Form::Nil => write!(f, "nil"), + Form::Int(i) => write!(f, "{i}"), + Form::Bool(b) => write!(f, "{b}"), + Form::Symbol(s) => write!(f, "'{s}"), + Form::Pair(car, cdr) => { + write!(f, "({}", car)?; + let mut traverse: Rc = Rc::clone(cdr); + loop { + match &*traverse { + Form::Pair(ref carp, ref cdrp) => { + write!(f, " {}", carp)?; + traverse = Rc::clone(cdrp); + }, + Form::Nil => { + write!(f, ")")?; + return Ok(()); + }, + x => { + write!(f, ". {x})")?; + return Ok(()); + }, + } + } + }, + Form::Prim(p) => { + match p { + Prim::Add => write!(f, "+"), + Prim::Mul => write!(f, "*"), + Prim::Eq => write!(f, "="), + } + } + } + } +} diff --git a/sl/src/main.rs b/sl/src/main.rs new file mode 100644 index 0000000..cd90476 --- /dev/null +++ b/sl/src/main.rs @@ -0,0 +1,18 @@ +#[macro_use] extern crate lalrpop_util; +lalrpop_mod!(pub grammar); + +use std::rc::Rc; +use anyhow::Result; + +use sl::{tree_walker_eval, Env}; + +fn main() -> Result<()> { + let input = "(if (= 1 2) (+ 2 3) (* 2 2))"; + let parsed_input = Rc::new(grammar::TermParser::new().parse(input)?); + //println!("Hello, world: {parsed_input:?}"); + println!("Hello, world: {parsed_input}"); + let mut e = Env::root_env(); + let tree_walker_evaled = tree_walker_eval(Rc::clone(&parsed_input), &mut e)?; + println!("tree walker evaled: {tree_walker_evaled}"); + Ok(()) +} diff --git a/small_demo/demo.sh b/small_demo/demo.sh deleted file mode 100755 index b863e77..0000000 --- a/small_demo/demo.sh +++ /dev/null @@ -1,14 +0,0 @@ -#!/usr/bin/env bash - -echo -echo "Partially Evaluating & compiling " $@ -echo "Source is" -cat $@ -echo -touch csc_out.wasm && rm csc_out.wasm && time scheme --script ../partial_eval.scm $@ -echo -echo "Running" -echo -wasmtime ./csc_out.wasm -echo -echo diff --git a/small_demo/enter_debug.kp b/small_demo/enter_debug.kp deleted file mode 100644 index bba8846..0000000 --- a/small_demo/enter_debug.kp +++ /dev/null @@ -1,156 +0,0 @@ -((wrap (vau root_env (quote) -((wrap (vau (let1) -(let1 lambda (vau se (p b1) (wrap (eval (array vau p b1) se))) -(let1 current-env (vau de () de) -(let1 cons (lambda (h t) (concat (array h) t)) -(let1 Y (lambda (f3) - ((lambda (x1) (x1 x1)) - (lambda (x2) (f3 (lambda (& y) (lapply (x2 x2) y)))))) -(let1 vY (lambda (f) - ((lambda (x3) (x3 x3)) - (lambda (x4) (f (vau de1 (& y) (vapply (x4 x4) y de1)))))) -(let1 let (vY (lambda (recurse) (vau de2 (vs b) (cond (= (len vs) 0) (eval b de2) - true (vapply let1 (array (idx vs 0) (idx vs 1) (array recurse (slice vs 2 -1) b)) de2))))) - (let ( - lcompose (lambda (g f) (lambda (& args) (lapply g (array (lapply f args))))) - rec-lambda (vau se (n p b) (eval (array Y (array lambda (array n) (array lambda p b))) se)) - if (vau de (con than & else) (cond (eval con de) (eval than de) - (> (len else) 0) (eval (idx else 0) de) - true false)) - - map (lambda (f5 l5) - ; now maybe errors on can't find helper? - (let (helper (rec-lambda recurse (f4 l4 n4 i4) - (cond (= i4 (len l4)) n4 - (<= i4 (- (len l4) 4)) (recurse f4 l4 (concat n4 (array - (f4 (idx l4 (+ i4 0))) - (f4 (idx l4 (+ i4 1))) - (f4 (idx l4 (+ i4 2))) - (f4 (idx l4 (+ i4 3))) - )) (+ i4 4)) - true (recurse f4 l4 (concat n4 (array (f4 (idx l4 i4)))) (+ i4 1))))) - (helper f5 l5 (array) 0))) - - - map_i (lambda (f l) - (let (helper (rec-lambda recurse (f l n i) - (cond (= i (len l)) n - (<= i (- (len l) 4)) (recurse f l (concat n (array - (f (+ i 0) (idx l (+ i 0))) - (f (+ i 1) (idx l (+ i 1))) - (f (+ i 2) (idx l (+ i 2))) - (f (+ i 3) (idx l (+ i 3))) - )) (+ i 4)) - true (recurse f l (concat n (array (f i (idx l i)))) (+ i 1))))) - (helper f l (array) 0))) - - filter_i (lambda (f l) - (let (helper (rec-lambda recurse (f l n i) - (if (= i (len l)) - n - (if (f i (idx l i)) (recurse f l (concat n (array (idx l i))) (+ i 1)) - (recurse f l n (+ i 1)))))) - (helper f l (array) 0))) - filter (lambda (f l) (filter_i (lambda (i x) (f x)) l)) - - foldl (let (helper (rec-lambda recurse (f z vs i) (if (= i (len (idx vs 0))) z - (recurse f (lapply f (cons z (map (lambda (x) (idx x i)) vs))) vs (+ i 1))))) - (lambda (f z & vs) (helper f z vs 0))) - - not (lambda (x) (if x false true)) - - ; Huge thanks to Oleg Kiselyov for his fantastic website - ; http://okmij.org/ftp/Computation/fixed-point-combinators.html - Y* (lambda (& l) - ((lambda (u) (u u)) - (lambda (p) - (map (lambda (li) (lambda (& x) (lapply (lapply li (p p)) x))) l)))) - vY* (lambda (& l) - ((lambda (u) (u u)) - (lambda (p) - (map (lambda (li) (vau ide (& x) (vapply (lapply li (p p)) x ide))) l)))) - - let-rec (vau de (name_func body) - (let (names (filter_i (lambda (i x) (= 0 (% i 2))) name_func) - funcs (filter_i (lambda (i x) (= 1 (% i 2))) name_func) - overwrite_name (idx name_func (- (len name_func) 2))) - (eval (array let (concat (array overwrite_name (concat (array Y*) (map (lambda (f) (array lambda names f)) funcs))) - (lapply concat (map_i (lambda (i n) (array n (array idx overwrite_name i))) names))) - body) de))) - let-vrec (vau de (name_func body) - (let (names (filter_i (lambda (i x) (= 0 (% i 2))) name_func) - funcs (filter_i (lambda (i x) (= 1 (% i 2))) name_func) - overwrite_name (idx name_func (- (len name_func) 2))) - (eval (array let (concat (array overwrite_name (concat (array vY*) (map (lambda (f) (array lambda names f)) funcs))) - (lapply concat (map_i (lambda (i n) (array n (array idx overwrite_name i))) names))) - body) de))) - - flat_map (lambda (f l) - (let (helper (rec-lambda recurse (f l n i) - (if (= i (len l)) - n - (recurse f l (concat n (f (idx l i))) (+ i 1))))) - (helper f l (array) 0))) - flat_map_i (lambda (f l) - (let (helper (rec-lambda recurse (f l n i) - (if (= i (len l)) - n - (recurse f l (concat n (f i (idx l i))) (+ i 1))))) - (helper f l (array) 0))) - - ; with all this, we make a destrucutring-capable let - let (let ( - destructure_helper (rec-lambda recurse (vs i r) - (cond (= (len vs) i) r - (array? (idx vs i)) (let (bad_sym (str-to-symbol (str (idx vs i))) - ;new_vs (flat_map_i (lambda (i x) (array x (array idx bad_sym i))) (slice (idx vs i) 1 -1)) - new_vs (flat_map_i (lambda (i x) (array x (array idx bad_sym i))) (idx vs i)) - ) - (recurse (concat new_vs (slice vs (+ i 2) -1)) 0 (concat r (array bad_sym (idx vs (+ i 1)))))) - true (recurse vs (+ i 2) (concat r (slice vs i (+ i 2)))) - ))) (vau de (vs b) (vapply let (array (destructure_helper vs 0 (array)) b) de))) - - ; and a destructuring-capable lambda! - only_symbols (rec-lambda recurse (a i) (cond (= i (len a)) true - (symbol? (idx a i)) (recurse a (+ i 1)) - true false)) - - ; Note that if macro_helper is inlined, the mapping lambdas will close over - ; se, and then not be able to be taken in as values to the maps, and the vau - ; will fail to partially evaluate away. - lambda (let (macro_helper (lambda (p b) (let ( - sym_params (map (lambda (param) (if (symbol? param) param - (str-to-symbol (str param)))) p) - body (array let (flat_map_i (lambda (i x) (array (idx p i) x)) sym_params) b) - ) (array vau sym_params body)))) - (vau se (p b) (if (only_symbols p 0) (vapply lambda (array p b) se) - (wrap (eval (macro_helper p b) se))))) - - ; and rec-lambda - yes it's the same definition again - rec-lambda (vau se (n p b) (eval (array Y (array lambda (array n) (array lambda p b))) se)) - - nil (array) - or (let (macro_helper (rec-lambda recurse (bs i) (cond (= i (len bs)) false - (= (+ 1 i) (len bs)) (idx bs i) - true (array let (array 'tmp (idx bs i)) (array if 'tmp 'tmp (recurse bs (+ i 1))))))) - (vau se (& bs) (eval (macro_helper bs 0) se))) - and (let (macro_helper (rec-lambda recurse (bs i) (cond (= i (len bs)) true - (= (+ 1 i) (len bs)) (idx bs i) - true (array let (array 'tmp (idx bs i)) (array if 'tmp (recurse bs (+ i 1)) 'tmp))))) - (vau se (& bs) (eval (macro_helper bs 0) se))) - - - monad (array 'write 1 "entering debug time!" (vau (written code) (array 'exit (debug)))) - - ) - monad - ) - ;(array 'write 1 "test_self_out2" (vau (written code) 7)) -; end of all lets -)))))) -; impl of let1 -; this would be the macro style version ((( -)) (vau de (s v b) (eval (array (array wrap (array vau (array s) b)) v) de))) -;)) (vau de (s v b) (eval (array (array vau (array s) b) (eval v de)) de))) -; impl of quote -)) (vau (x5) x5)) diff --git a/small_demo/small_demo.kp b/small_demo/small_demo.kp deleted file mode 100644 index 4d956a6..0000000 --- a/small_demo/small_demo.kp +++ /dev/null @@ -1 +0,0 @@ -(+ 1 2) diff --git a/small_demo/small_lambda_demo.kp b/small_demo/small_lambda_demo.kp deleted file mode 100644 index ea4a9e5..0000000 --- a/small_demo/small_lambda_demo.kp +++ /dev/null @@ -1 +0,0 @@ -(wrap (vau () (+ 1 2))) diff --git a/small_demo/small_macro_demo.kp b/small_demo/small_macro_demo.kp deleted file mode 100644 index 6f4a4cd..0000000 --- a/small_demo/small_macro_demo.kp +++ /dev/null @@ -1,8 +0,0 @@ - -((wrap (vau (quote) - - -(vau () (array (quote a) (+ 1 2))) - -; impl of quote -)) (vau (x5) x5)) diff --git a/small_demo/small_test.kp b/small_demo/small_test.kp deleted file mode 100644 index bb6fc61..0000000 --- a/small_demo/small_test.kp +++ /dev/null @@ -1,154 +0,0 @@ -((wrap (vau root_env (quote) -((wrap (vau (let1) -(let1 lambda (vau se (p b1) (wrap (eval (array vau p b1) se))) -(let1 current-env (vau de () de) -(let1 cons (lambda (h t) (concat (array h) t)) -(let1 Y (lambda (f3) - ((lambda (x1) (x1 x1)) - (lambda (x2) (f3 (lambda (& y) (lapply (x2 x2) y)))))) -(let1 vY (lambda (f) - ((lambda (x3) (x3 x3)) - (lambda (x4) (f (vau de1 (& y) (vapply (x4 x4) y de1)))))) -(let1 let (vY (lambda (recurse) (vau de2 (vs b) (cond (= (len vs) 0) (eval b de2) - true (vapply let1 (array (idx vs 0) (idx vs 1) (array recurse (slice vs 2 -1) b)) de2))))) - (let ( - lcompose (lambda (g f) (lambda (& args) (lapply g (array (lapply f args))))) - rec-lambda (vau se (n p b) (eval (array Y (array lambda (array n) (array lambda p b))) se)) - if (vau de (con than & else) (cond (eval con de) (eval than de) - (> (len else) 0) (eval (idx else 0) de) - true false)) - - map (lambda (f5 l5) - ; now maybe errors on can't find helper? - (let (helper (rec-lambda recurse (f4 l4 n4 i4) - (cond (= i4 (len l4)) n4 - (<= i4 (- (len l4) 4)) (recurse f4 l4 (concat n4 (array - (f4 (idx l4 (+ i4 0))) - (f4 (idx l4 (+ i4 1))) - (f4 (idx l4 (+ i4 2))) - (f4 (idx l4 (+ i4 3))) - )) (+ i4 4)) - true (recurse f4 l4 (concat n4 (array (f4 (idx l4 i4)))) (+ i4 1))))) - (helper f5 l5 (array) 0))) - - - map_i (lambda (f l) - (let (helper (rec-lambda recurse (f l n i) - (cond (= i (len l)) n - (<= i (- (len l) 4)) (recurse f l (concat n (array - (f (+ i 0) (idx l (+ i 0))) - (f (+ i 1) (idx l (+ i 1))) - (f (+ i 2) (idx l (+ i 2))) - (f (+ i 3) (idx l (+ i 3))) - )) (+ i 4)) - true (recurse f l (concat n (array (f i (idx l i)))) (+ i 1))))) - (helper f l (array) 0))) - - filter_i (lambda (f l) - (let (helper (rec-lambda recurse (f l n i) - (if (= i (len l)) - n - (if (f i (idx l i)) (recurse f l (concat n (array (idx l i))) (+ i 1)) - (recurse f l n (+ i 1)))))) - (helper f l (array) 0))) - filter (lambda (f l) (filter_i (lambda (i x) (f x)) l)) - - not (lambda (x) (if x false true)) - - ; Huge thanks to Oleg Kiselyov for his fantastic website - ; http://okmij.org/ftp/Computation/fixed-point-combinators.html - Y* (lambda (& l) - ((lambda (u) (u u)) - (lambda (p) - (map (lambda (li) (lambda (& x) (lapply (lapply li (p p)) x))) l)))) - vY* (lambda (& l) - ((lambda (u) (u u)) - (lambda (p) - (map (lambda (li) (vau ide (& x) (vapply (lapply li (p p)) x ide))) l)))) - - let-rec (vau de (name_func body) - (let (names (filter_i (lambda (i x) (= 0 (% i 2))) name_func) - funcs (filter_i (lambda (i x) (= 1 (% i 2))) name_func) - overwrite_name (idx name_func (- (len name_func) 2))) - (eval (array let (concat (array overwrite_name (concat (array Y*) (map (lambda (f) (array lambda names f)) funcs))) - (lapply concat (map_i (lambda (i n) (array n (array idx overwrite_name i))) names))) - body) de))) - let-vrec (vau de (name_func body) - (let (names (filter_i (lambda (i x) (= 0 (% i 2))) name_func) - funcs (filter_i (lambda (i x) (= 1 (% i 2))) name_func) - overwrite_name (idx name_func (- (len name_func) 2))) - (eval (array let (concat (array overwrite_name (concat (array vY*) (map (lambda (f) (array lambda names f)) funcs))) - (lapply concat (map_i (lambda (i n) (array n (array idx overwrite_name i))) names))) - body) de))) - - flat_map (lambda (f l) - (let (helper (rec-lambda recurse (f l n i) - (if (= i (len l)) - n - (recurse f l (concat n (f (idx l i))) (+ i 1))))) - (helper f l (array) 0))) - flat_map_i (lambda (f l) - (let (helper (rec-lambda recurse (f l n i) - (if (= i (len l)) - n - (recurse f l (concat n (f i (idx l i))) (+ i 1))))) - (helper f l (array) 0))) - - ; with all this, we make a destrucutring-capable let - let (let ( - destructure_helper (rec-lambda recurse (vs i r) - (cond (= (len vs) i) r - (array? (idx vs i)) (let (bad_sym (str-to-symbol (str (idx vs i))) - ;new_vs (flat_map_i (lambda (i x) (array x (array idx bad_sym i))) (slice (idx vs i) 1 -1)) - new_vs (flat_map_i (lambda (i x) (array x (array idx bad_sym i))) (idx vs i)) - ) - (recurse (concat new_vs (slice vs (+ i 2) -1)) 0 (concat r (array bad_sym (idx vs (+ i 1)))))) - true (recurse vs (+ i 2) (concat r (slice vs i (+ i 2)))) - ))) (vau de (vs b) (vapply let (array (destructure_helper vs 0 (array)) b) de))) - - ; and a destructuring-capable lambda! - only_symbols (rec-lambda recurse (a i) (cond (= i (len a)) true - (symbol? (idx a i)) (recurse a (+ i 1)) - true false)) - - ; Note that if macro_helper is inlined, the mapping lambdas will close over - ; se, and then not be able to be taken in as values to the maps, and the vau - ; will fail to partially evaluate away. - lambda (let (macro_helper (lambda (p b) (let ( - sym_params (map (lambda (param) (if (symbol? param) param - (str-to-symbol (str param)))) p) - body (array let (flat_map_i (lambda (i x) (array (idx p i) x)) sym_params) b) - ) (array vau sym_params body)))) - (vau se (p b) (if (only_symbols p 0) (vapply lambda (array p b) se) - (wrap (eval (macro_helper p b) se))))) - - ; and rec-lambda - yes it's the same definition again - rec-lambda (vau se (n p b) (eval (array Y (array lambda (array n) (array lambda p b))) se)) - - nil (array) - or (let (macro_helper (rec-lambda recurse (bs i) (cond (= i (len bs)) false - (= (+ 1 i) (len bs)) (idx bs i) - true (array let (array 'tmp (idx bs i)) (array if 'tmp 'tmp (recurse bs (+ i 1))))))) - (vau se (& bs) (eval (macro_helper bs 0) se))) - and (let (macro_helper (rec-lambda recurse (bs i) (cond (= i (len bs)) true - (= (+ 1 i) (len bs)) (idx bs i) - true (array let (array 'tmp (idx bs i)) (array if 'tmp (recurse bs (+ i 1)) 'tmp))))) - (vau se (& bs) (eval (macro_helper bs 0) se))) - - - test17 (or false 1 "a" true) - test18 (and 1 "a" nil true) - monad (array 'write 1 "test_self_out2" (vau (written code) (array 'exit (or written code) test17 (or false nil 0) (and written code) test18 (and nil 0 false)))) - - ) - monad - ) - ;(array 'write 1 "test_self_out2" (vau (written code) 7)) -; end of all lets -)))))) -; impl of let1 -; this would be the macro style version ((( -)) (vau de (s v b) (eval (array (array wrap (array vau (array s) b)) v) de))) -;)) (vau de (s v b) (eval (array (array vau (array s) b) (eval v de)) de))) -; impl of quote -)) (vau (x5) x5)) diff --git a/small_demo/small_vau_demo.kp b/small_demo/small_vau_demo.kp deleted file mode 100644 index 078dcbd..0000000 --- a/small_demo/small_vau_demo.kp +++ /dev/null @@ -1 +0,0 @@ -(vau () (+ 1 2)) diff --git a/website/index.html b/website/index.html index 936e517..830dce3 100644 --- a/website/index.html +++ b/website/index.html @@ -10,6 +10,7 @@ FOSS Fexprs: https://github.com/limvot/kraken
+

Concept:

  • Minimal, purely functional Kernel/Scheme as core language, with Kernel/Vau calculus inspiration oblivating the need for non-reader macros (Kernel/Vau calculus thesis) -
  • Partial evaluation to make fexprs fast (my PhD research! First paper on arXiv) +
  • Partial evaluation (or now, maybe tracing JIT compilation) to make fexprs fast (my PhD research! First paper on arXiv)
  • Implement Type Systems as Macros (but using Fexprs instead of macros) (paper, up to System Fω) (second paper, up to dependent types) -
  • Use fexprs to bootstrap more complex features, like delimited continuations
  • Use above "type systems as fexprs" to add types and create a statically-typed language on top (with Algebraic Effects using the underlying delimited continuations, etc)

About:

-

This is my 3rd run at this Lisp concept, with Partial Evaluation to make fexprs fast forming the core of my current PhD research. (tiny personal PhD website here)

+

This is my 4th run at this Lisp concept, with tracing JIT compilation to make fexprs fast forming the core of my current PhD research. (tiny personal PhD website here)

Vau/Kernel as simple core:

By constructing our core language on a very simple Vau/Kernel base, we can keep the base truely tiny, and build up normal Lisp functions and programming language features in the language itself. This should help implement other programming languages concisely, and will hopefully make optimization easier and more broadly applicable.
diff --git a/website/presentation.html b/website/quals_presentation.html similarity index 100% rename from website/presentation.html rename to website/quals_presentation.html diff --git a/website/slides_to_add b/website/slides_to_add deleted file mode 100644 index 11657d9..0000000 --- a/website/slides_to_add +++ /dev/null @@ -1,5 +0,0 @@ -x lisp tree -x explain quote -x show fold's internals -x fix if0 primitive -_ partial evaluation diff --git a/working_files/bf.kp b/working_files/bf.kp deleted file mode 100644 index 61e787e..0000000 --- a/working_files/bf.kp +++ /dev/null @@ -1,52 +0,0 @@ - -(load-file "./k_prime_stdlib/prelude.kp") - -; We don't have atoms built in, mutable arrays -; are our base building block. In order to make the -; following BF implementation nice, let's add atoms! -; They will be implmented as length 1 arrays with nice syntax for deref -(fun make-atom (x) [x]) -(fun set-atom! (x y) (set-idx! x 0 y)) -(fun get-atom (x) (idx x 0)) -(add_grammar_rule 'form ["@" 'form] (lambda (_ x) `(get-atom ~x))) - -; Now begin by defining our BF syntax & semantics -; Define our tokens as BF atoms -(add_grammar_rule 'bfs_atom ["<"] (lambda (_) '(set-atom! cursor (- @cursor 1)))) -(add_grammar_rule 'bfs_atom [">"] (lambda (_) '(set-atom! cursor (+ @cursor 1)))) -(add_grammar_rule 'bfs_atom ["\\+"] (lambda (_) '(set-idx! tape @cursor (+ (idx tape @cursor) 1)))) -(add_grammar_rule 'bfs_atom ["-"] (lambda (_) '(set-idx! tape @cursor (- (idx tape @cursor) 1)))) -(add_grammar_rule 'bfs_atom [","] (lambda (_) '(let (value (idx input @inptr)) - (do (set-atom! inptr (+ 1 @inptr)) - (set-idx! tape @cursor value))))) -(add_grammar_rule 'bfs_atom ["."] (lambda (_) '(set-atom! output (concat [(idx tape @cursor)] @output)))) - -; Define strings of BF atoms -(add_grammar_rule 'bfs ['bfs_atom *] (lambda (x) x)) - -; Add loop as an atom -; (note that closure cannot yet close over itself by value, so we pass it in) -(add_grammar_rule 'bfs_atom ["\\[" 'bfs "]"] (lambda (_ x _) - `(let (f (lambda (f) - (if (= 0 (idx tape @cursor)) - nil - (do ,x (f f))))) - (f f)))) - -; For now, stick BFS rule inside an unambigious BFS block -; Also add setup code -(add_grammar_rule 'form ["bf" 'optional_WS "{" 'optional_WS 'bfs 'optional_WS "}"] - (lambda (_ _ _ _ x _ _) - `(lambda (input) - (let ( - tape (array 0 0 0 0 0) - cursor (make-atom 0) - inptr (make-atom 0) - output (make-atom (array)) - ) - (do (println "beginning bfs") ,x (idx output 0)))))) - -; Let's try it out! This BF program prints the input 3 times -(println (bf { ,>+++[<.>-] } [1337])) -; we can also have it compile into our main program -(fun main () (do (println "BF: " (bf { ,>+++[<.>-] } [1337])) 0)) diff --git a/working_files/collections.kp b/working_files/collections.kp deleted file mode 100644 index a78e4be..0000000 --- a/working_files/collections.kp +++ /dev/null @@ -1,27 +0,0 @@ - -(let ( - - foldl (let (helper (rec-lambda recurse (f z vs i) (if (= i (len (idx vs 0))) z - (recurse f (lapply f (cons z (map (lambda (x) (idx x i)) vs))) vs (+ i 1))))) - (lambda (f z & vs) (helper f z vs 0))) - foldr (let (helper (rec-lambda recurse (f z vs i) (if (= i (len (idx vs 0))) z - (lapply f (cons (recurse f z vs (+ i 1)) (map (lambda (x) (idx x i)) vs)))))) - (lambda (f z & vs) (helper f z vs 0))) - reverse (lambda (x) (foldl (lambda (acc i) (cons i acc)) [] x)) - zip (lambda (& xs) (lapply foldr (concat [(lambda (a & ys) (cons ys a)) []] xs))) - empty_dict [] - put (lambda (m k v) (cons [k v] m)) - get-value-helper (rec-lambda recurse (dict key i) (if (>= i (len dict)) - (error (str key " not found in " dict)) - (if (= key (idx (idx dict i) 0)) - (idx (idx dict i) 1) - (recurse dict key (+ i 1))))) - get-value (lambda (dict key) (get-value-helper dict key 0)) - add-dict-to-env (let (helper (rec-lambda recurse (env dict i) - (if (= i (len dict)) env - (recurse (eval [ [vau '_ [(idx (idx dict i) 0)] [ [vau 'inner [] 'inner] ] ] (idx (idx dict i) 1) ] env) dict (+ i 1))))) - (lambda (env dict) (helper env dict 0))) -) - (provide foldl foldr reverse zip empty_dict put get-value add-dict-to-env) -) - diff --git a/working_files/comp_wasm.kp b/working_files/comp_wasm.kp deleted file mode 100644 index 387c516..0000000 --- a/working_files/comp_wasm.kp +++ /dev/null @@ -1,92 +0,0 @@ -(with_import "./wasm.kp" -(let ( - _ (println "args" *ARGV*) - (_ _ out) (cond (!= (len *ARGV*) 3) (error "wrong number of params to comp_wasm (please provide out)") - true *ARGV*) - _ (println "out" out) - wasm_code - (module - (import "wasi_unstable" "path_open" - (func $path_open (param i32 i32 i32 i32 i32 i64 i64 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))) - (memory $mem 1) - (global $gi i32 (i32.const 8)) - (global $gb (mut i64) (i64.const 9)) - (table $tab 2 funcref) - ;(table $tab2 8 16 funcref) - (data (i32.const 16) "HellH") ;; adder to put, then data - (func $start - (i32.store (i32.const 8) (i32.const 16)) ;; adder of data - (i32.store (i32.const 12) (i32.const 5)) ;; len of data - ;; open file - (call $path_open - (i32.const 3) ;; file descriptor - (i32.const 0) ;; lookup flags - (i32.const 16) ;; path string * - (i32.load (i32.const 12)) ;; path string len - (i32.const 1) ;; o flags - (i64.const 66) ;; base rights - (i64.const 66) ;; inheriting rights - (i32.const 0) ;; fdflags - (i32.const 4) ;; opened fd out ptr - ) - drop - (block $a - (block $b - (br $a) - (br_if $b (i32.const 3)) - (loop $l - (br $a) - (br $l) - ) - (_if $myif (i32.const 1) - (then - (i32.const 1) - drop - (br $b) - ) - (else - (br $myif) - ) - ) - (_if $another (i32.const 1) (br $b)) - (i32.const 1) - (_if $third (br $b)) - (_if $fourth (br $fourth)) - ) - ) - - (call $fd_read - (i32.const 0) ;; file descriptor - (i32.const 8) ;; *iovs - (i32.const 1) ;; iovs_len - (i32.const 12) ;; nwritten, overwrite buf len with it - ) - drop - - ;; print name - (call $fd_write - (i32.load (i32.const 4)) ;; file descriptor - (i32.const 8) ;; *iovs - (i32.const 1) ;; iovs_len - (i32.const 4) ;; nwritten - ) - drop - ) - (elem (i32.const 0) $start $start) - (export "memory" (memory $mem)) - (export "_start" (func $start)) - (start $start) - ) - _ (write_file out (wasm_to_binary wasm_code)) - return_code 0 -) return_code )) diff --git a/working_files/compile_for_web.sh b/working_files/compile_for_web.sh deleted file mode 100755 index 71e2976..0000000 --- a/working_files/compile_for_web.sh +++ /dev/null @@ -1,4 +0,0 @@ -#!/usr/bin/env bash - -emcc ./k_prime.krak.c -o k_prime.html --embed-file k_prime_stdlib -s EXPORTED_FUNCTIONS='["_main"]' -s EXTRA_EXPORTED_RUNTIME_METHODS='["ccall", "cwrap"]' -s ERROR_ON_UNDEFINED_SYMBOLS=0 -#emcc ./k_prime.krak.c -o k_prime.js -s EXPORTED_FUNCTIONS='["_fun_execute_code_starcharactercolonobkcbk_"]' -s EXTRA_EXPORTED_RUNTIME_METHODS='["ccall", "cwrap"]' -s ERROR_ON_UNDEFINED_SYMBOLS=0 diff --git a/working_files/damas_hindley_milner.kp b/working_files/damas_hindley_milner.kp deleted file mode 100644 index 0ace2e7..0000000 --- a/working_files/damas_hindley_milner.kp +++ /dev/null @@ -1,141 +0,0 @@ -(let ( - ; First quick lookup function, since maps are not built in - lookup (let (lookup-helper (rec-lambda recurse (dict key i) (if (>= i (len dict)) - nil - (if (= key (idx (idx dict i) 0)) - (idx (idx dict i) 1) - (recurse dict key (+ i 1)))))) - (lambda (dict key) (lookup-helper dict key 0))) - - contains (let (contains-helper (rec-lambda recurse (s x i) (cond (= i (len s)) false - (= x (idx s i)) true - true (recurse s x (+ i 1))))) - (lambda (s x) (contains-helper s x 0))) - - applyST (rec-lambda recurse (S t) - (cond - (meta t) (with-meta (recurse (filter (lambda (x) (not (contains (meta t) x))) S) (with-meta t nil)) (meta t)) - (int? t) (or (lookup S t) t) - (array? t) (map (lambda (x) (recurse S x)) t) - true t - )) - applySE (lambda (S env) (map (lambda (x) [(idx x 0) (applyST S (idx x 1))]) env)) - applySS (lambda (S_0 S_1) (let (r (concat S_0 (applySE S_0 S_1)) _ (println "applySS of " S_0 " and " S_1 " is " r)) r)) - fvT (rec-lambda recurse (t) (cond (meta t) (filter (lambda (x) (not (contains (meta t) x))) (recurse (with-meta t nil))) - (int? t) [t] - (array? t) (flat_map recurse t) - true [] - )) - fvE (lambda (env) (flat_map (lambda (x) (fvT (idx x 1))) env)) - varBind (lambda (a b) (cond - (= a b) [] - (contains (fvT b) a) (error "Contains check failed for " a " and " b) - true [ [a b] ])) - mgu (rec-lambda mgu (a b) (let (r (cond - (and (array? a) (array? b) (= (len a) (len b))) ((rec-lambda recurse (S i) (if (= i (len a)) S - (recurse (applySS (mgu (idx a i) (idx b i)) S) (+ 1 i)))) [] 0) - (int? a) (varBind a b) - (int? b) (varBind b a) - (= a b) [] - true (error (str "Cannot unify " a " and " b)) - ) _ (println "mgu of " a " and " b " is " r)) r)) - - generalize (lambda (env t) (do (println "generalize " t " with respect to " env) (let (free_T (fvT t) - free_E (fvE env)) - (with-meta t (filter (lambda (x) (not (contains free_E x))) free_T))))) - instantiate (lambda (sigma idn) (do (println "instantiate " sigma " meta is " (meta sigma)) [(applyST (map_i (lambda (x i) [x (+ i idn)]) (meta sigma)) (with-meta sigma nil)) (+ idn (len (meta sigma)))])) - - execute_type_com (lambda (tc e idn) (tc e idn)) - - simple_type_com (lambda (exp typ) (lambda (env idn) [exp typ [] idn])) - symbol_type_com (lambda (sym) (lambda (env idn) (let ( - (t idn) (instantiate (lookup env sym) idn)) - [sym t [] idn]))) - - call_type_com (lambda (innards) - (lambda (env idn) - (if (= 0 (len innards)) (error "stlc_error: Can't have a 0-length call") - (let ( - (f_e f_t S_0 idn) (execute_type_com (idx innards 0) env idn) - across_params (rec-lambda recurse (env S idn params i out_e out_t) - (if (= i (len params)) [out_e out_t S idn] - (let ( - (p_e p_t S_i idn) (execute_type_com (idx params i) env idn) - ) (recurse (applySE S_i env) (applySS S_i S) idn params (+ 1 i) (concat out_e [p_e]) (concat out_t [p_t]))))) - (p_es p_ts S_ps idn) (across_params (applySE S_0 env) [] idn (slice innards 1 -1) 0 [] []) - (r_t idn) [idn (+ 1 idn)] - S_f (mgu (applyST S_ps f_t) [p_ts r_t]) - _ (println "mgu of " (applyST S_ps f_t) " and " [p_ts r_t] " produces substitution " S_f) - _ (println "For this call: " (cons f_e p_es) " the return type " r_t " transformed by " S_f " is " (applyST S_f r_t)) - ) [(cons f_e p_es) (applyST S_f r_t) (applySS S_f (applySS S_ps S_0)) idn]) - ) - ) - ) - - lambda_type_com (lambda (p t b) - (lambda (env idn) - (let ( - (p_t idn) (if (= nil t) [idn (+ 1 idn)] - [t idn]) - extended_env (cons [p (with-meta p_t [])] env) - (b_e b_t S idn) (execute_type_com b extended_env idn) - f_e [lambda [p] b_e] - f_t [[ (applyST S p_t) ] b_t] - ) [f_e f_t S idn]) - ) - ) - - let_type_com (lambda (x e1 e2) - (lambda (env0 idn) - (let ( - (e1_e e1_t S_0 idn) (execute_type_com e1 env0 idn) - env1 (applySE S_0 env0) - e1_sigma (generalize env1 e1_t) - extended_env (cons [x e1_sigma] env1) - (e2_e e2_t S_1 idn) (execute_type_com e2 extended_env idn) - l_e [[lambda [x] e2_e] e1_e] - l_t e2_t - ) [l_e l_t (applySS S_1 S_0) idn]) - ) - ) - - base_env [ - [ '+ (with-meta [['int 'int] 'int] []) ] - [ '- (with-meta [['int 'int] 'int] []) ] - [ '< (with-meta [['int 'int] 'bool] []) ] - [ '> (with-meta [['int 'int] 'bool] []) ] - [ 'println (with-meta [['str] 'void] []) ] - ] - current_env (vau de () de) - syms (map (lambda (x) (idx x 0)) base_env) - builtin_real_env (eval (concat (vapply provide syms root_env) [[current_env]]) empty_env) - top-level-erase-and-check (lambda (e) (let ( - (e t S idn) (execute_type_com e base_env 0) - _ (println "Type of program is " t " with sub " S) - _ (println "expression code is " e) - ) e)) - - stlc (concat basic_rules [ - - [ 'expr [ 'number ] (lambda (x) (simple_type_com x 'int)) ] - [ 'expr [ 'string ] (lambda (x) (simple_type_com x 'str)) ] - [ 'expr [ 'bool_nil_symbol ] (lambda (x) (cond (= x true) (simple_type_com x 'bool) - (= x false) (simple_type_com x 'bool) - (= x nil) (simple_type_com x 'nil) - true (symbol_type_com x) - ) - ) ] - [ 'expr [ "\\\\" 'WS * 'bool_nil_symbol 'WS * ":" 'WS * 'bool_nil_symbol 'WS * "." 'WS * 'expr ] (lambda (_ _ p _ _ _ t _ _ _ b) (lambda_type_com p t b)) ] - [ 'expr [ "\\\\" 'WS * 'bool_nil_symbol 'WS * "." 'WS * 'expr ] (lambda (_ _ p _ _ _ b) (lambda_type_com p nil b)) ] - - [ 'expr [ "let" 'WS * 'bool_nil_symbol 'WS * "=" 'WS * 'expr 'WS * "in" 'WS * 'expr ] (lambda (_ _ x _ _ _ e1 _ _ _ e2) (let_type_com x e1 e2)) ] - - [ 'call_innards [ 'WS * ] (lambda (_) []) ] - [ 'call_innards [ 'expr [ 'WS 'expr ] * ] (lambda (f r) (cons f (map (lambda (x) (idx x 1)) r))) ] - [ 'expr [ "\\(" 'call_innards "\\)" ] (lambda (_ innards _) (call_type_com innards)) ] - - [ 'stlc_start_symbol [ 'WS * 'expr 'WS * ] (lambda (_ e _) [eval (top-level-erase-and-check e) builtin_real_env]) ] - - ])) - (provide stlc) -) diff --git a/working_files/damas_hindley_milner_test.kp b/working_files/damas_hindley_milner_test.kp deleted file mode 100644 index d341cd7..0000000 --- a/working_files/damas_hindley_milner_test.kp +++ /dev/null @@ -1,2 +0,0 @@ -#lang (with_import "./types.kp" stlc) stlc_start_symbol -let id = \ x . x in ((id println) (id "woo")) diff --git a/working_files/dlambda_test.kp b/working_files/dlambda_test.kp deleted file mode 100644 index f3bcea7..0000000 --- a/working_files/dlambda_test.kp +++ /dev/null @@ -1,20 +0,0 @@ - -(let ( - dl1 (lambda ([a b]) (+ a b)) - _ (println "dl1 " (dl1 [5 6])) - dl2 (lambda (a [b c]) (+ a b c)) - _ (println "dl2 " (dl2 1 [5 6])) - dl3 (lambda ([a b] c) (+ a b c)) - _ (println "dl3 " (dl3 [5 6] 2)) - dl4 (lambda (a [b c] d) (+ a b c d)) - _ (println "dl4 " (dl4 5 [5 6] 4)) - dl5 (lambda (a) (+ a 1)) - _ (println "dl5 " (dl5 1336)) - dl6 (lambda (a b) (+ a b)) - _ (println "dl6 " (dl6 1336 12)) - dl7 (lambda () (+ 1 1)) - _ (println "dl7 " (dl7)) - fib (rec-lambda recurse (n [a b]) (if (= 0 n) a - (recurse (- n 1) [b (+ a b)]))) - _ (println "fib 5 " (fib 5 [1 1])) -) nil) diff --git a/working_files/even_odd.kp b/working_files/even_odd.kp deleted file mode 100644 index e807a45..0000000 --- a/working_files/even_odd.kp +++ /dev/null @@ -1,51 +0,0 @@ -(do - (println "Double") - (let-rec ( - even (lambda (n) (cond (= 0 n) true - (= 1 n) false - true (odd (- n 1)))) - odd (lambda (n) (cond (= 0 n) false - (= 1 n) true - true (even (- n 1)))) - ) - (do - (println (even 7)) - (println (even 8)) - (println (odd 7)) - (println (odd 8)) - ) - ) - - (println "Triple") - (let-rec ( - first (lambda (n) (cond (= 0 n) true - (= 1 n) false - (= 2 n) false - true (third (- n 1)))) - - second (lambda (n) (cond (= 0 n) false - (= 1 n) true - (= 2 n) false - true (first (- n 1)))) - - third (lambda (n) (cond (= 0 n) false - (= 1 n) false - (= 2 n) true - true (second (- n 1)))) - ) - (do - (println) - (println (first 7)) - (println (first 8)) - (println (first 9)) - (println) - (println (second 7)) - (println (second 8)) - (println (second 9)) - (println) - (println (third 7)) - (println (third 8)) - (println (third 9)) - ) - ) -) diff --git a/working_files/fib-comp.kp b/working_files/fib-comp.kp deleted file mode 100644 index 8a9f3b0..0000000 --- a/working_files/fib-comp.kp +++ /dev/null @@ -1,8 +0,0 @@ -(def! fib (fn* (n) (cond (= 0 n) 0 - (= 1 n) 1 - true (+ (fib (- n 1)) (fib (- n 2)))))) -(def! main (fn* () - (do - (let* (n 27) - (println "Fib(" n "): " (fib n))) - 0))) diff --git a/working_files/fib-interp.kp b/working_files/fib-interp.kp deleted file mode 100644 index d85e8df..0000000 --- a/working_files/fib-interp.kp +++ /dev/null @@ -1,5 +0,0 @@ -(def! fib (fn* (n) (cond (= 0 n) 0 - (= 1 n) 1 - true (+ (fib (- n 1)) (fib (- n 2)))))) -(let* (n 27) - (println "Fib(" n "): " (fib n))) diff --git a/working_files/fib.c b/working_files/fib.c deleted file mode 100644 index 54fea15..0000000 --- a/working_files/fib.c +++ /dev/null @@ -1,17 +0,0 @@ -#include - -int fib(int n) { - if (n == 0) { - return 0; - } else if (n == 1) { - return 1; - } else { - return fib(n-1) + fib(n-2); - } -} - -int main(int argc, char** argv) { - int n = 27; - printf("Fib(%d): %d\n", n, fib(n)); - return 0; -} diff --git a/working_files/fungll.kp b/working_files/fungll.kp deleted file mode 100644 index eb55362..0000000 --- a/working_files/fungll.kp +++ /dev/null @@ -1,96 +0,0 @@ - -(with_import "./collections.kp" -(with_import "./rb.kp" -(let ( - - ; Implementing "Purely Functional GLL Parsing" - ; by L. Thomas van Binsbergena, Elizabeth Scott, Adrian Johnstone - ; retrived from from http://ltvanbinsbergen.nl/publications/jcola-fgll.pdf - - ; discriptor is a triple of grammer-slot and 2 indicies of t-string - ; corresponding to process - ; - ; I previously had this as nonterminal, rule-idx, idx into rule, l,r - - ; U - discriptors added to (worklist?), makes sure no duplicates added to "list" - ; P - binary relation between pairs of commencments and right extants - ; makes sure that later discoveries that use a sub-non-terminal that has already - ; been processed can be completed since the sub-non-terminal won't be - ; re-descended at the same index - ; - ; a commencement is a pair of a nonterminal and a left extent (the arguemnts to - ; descend, since that's what we're skipping) to a set of right extants - ; G - binary relation between commencments and continuations, modified to include - ; actional continuation. - ; The normal continuation is a pair of as slot and a left extent. - ; So < -> > in G, with a new are is combined to form - ; discriptor and BSR whenever k,r are discovered for X - ; Note we haven't finished things with the above P, since some subs of the form - ; or descriptors that follow them may not have been processed - ; yet. When new Right extants are discovered, we must add descriptors - ; and to R (if not in U) and add - ; BSR elements and to Y - ; Y - Our result BSR set! - - ; I've decided, a slot is [X [stff] int-for-dot] - - id (lambda (sigma) sigma) - altStart (lambda (t s k c) id) - altOp (lambda (p q) (lambda (t s k c) (lcompose (p t s k c) (q t s [] k c)))) - term_parser (lambda (t [X b i] l k c) (lambda (sigma) - (let (this_term (idx b (- i 1)) - _ (println "term parser looking for " this_term " at position " k " in " t) - ) - (if (and (<= (+ k (len this_term)) (len t)) (= this_term (slice t k (+ k (len this_term))))) ((c [[X b i] l (+ (len this_term) k)]) sigma) - sigma)))) - ; the extra lambda layer of indirection is so that - ; recursive nonterminals can be made with rec-let, which - ; only works on functions. So both term types get wrapped in - ; an extra function which is evaluated in seqOp and parse - term (lambda (s) (lambda () [ s term_parser ])) - - continue (lambda (BSR_element c) (lambda ([U G P Y]) - (let ( - [slot l k r] BSR_element - descriptor [slot l r] - (X b i) slot - Yp (if (or (!= 0 i) (= (len rhs) i)) (set-insert Y BSR_element) - Y) - Up (set-insert U descriptor) - ) (if (set-contains? U descriptor) [U G P Yp] - ((c descriptor) [Up G P Yp]))))) - seqStart (lambda (t X b l c0) (continue [[X b 0] l l l] c0)) - seqOp (lambda (p s_q) (lambda (t X b l c0) (let ( - ; see term discussion about extra lambda wrap - [s q] (s_q) - c1 (lambda ([[X b i] l k]) (let ( - c2 (lambda ([slot l r]) (continue [slot l k r] c0)) - ) (q t [X b (+ 1 i)] l k c2))) - ) (p t X (cons s b) l c1)))) - - cont_for (lambda (s p) (lambda ([[s d i] k r]) (lambda ([U G P Y]) (let ( - composed (set-foldl (lambda (cp [g l c]) (lcompose cp (c [g l r]))) id (multimap-get G [s k])) - ) (composed [U G (multimap-insert P [s k] r) Y]))))) - nterm_parser (lambda (p) (lambda (t gram_slot l k c) (lambda ([U G P Y]) - (let ( - [X b i] gram_slot - s (idx b (- i 1)) - R (multimap-get P [s k]) - sigmap [U (multimap-insert G [s k] [gram_slot l c]) P Y] - ) (if (= 0 (size R)) ((p t s k (cont_for s p)) sigmap) - (set-foldl (lambda (cp r) (lcompose cp (c [gram_slot l r]))) id R) - ))))) - ; see term discussion about extra lambda wrap - nterm (lambda (s p) (lambda () [ s (nterm_parser p) ])) - parse (lambda (s_f) (lambda (t) - (let ( - ; see term discussion about extra lambda wrap - [s f] (s_f) - X '__FUNGLL_UNIQUE_START_SYMBOL__ - sigma [ set-empty multimap-empty multimap-empty set-empty ] - c (lambda (descriptor) (lambda (sigma) sigma)) - [U G P Y] ((f t ['X [s] 1] 0 0 c) sigma) - ) (set-foldl cons [] Y)))) -) -(provide altStart altOp term seqStart seqOp nterm parse) -))) diff --git a/working_files/fungll_test.kp b/working_files/fungll_test.kp deleted file mode 100644 index de24225..0000000 --- a/working_files/fungll_test.kp +++ /dev/null @@ -1,48 +0,0 @@ -(with_import "./fungll.kp" -(let ( - - _ (println "The a parser") - just_a_parser (parse (nterm 'A (altOp altStart (seqOp seqStart (term "a"))))) - _ (println "parse result for a " (just_a_parser "a")) - _ (println "parse result for b " (just_a_parser "b")) - _ (println "parse result for aa " (just_a_parser "aa")) - _ (println "parse result for ba " (just_a_parser "ba")) - _ (println "parse result for ab " (just_a_parser "ab")) - - _ (println "The aa parser") - just_aa_parser (parse (nterm 'A (altOp altStart (seqOp seqStart (term "aa"))))) - _ (println "parse result for a " (just_aa_parser "a")) - _ (println "parse result for b " (just_aa_parser "b")) - _ (println "parse result for aa " (just_aa_parser "aa")) - _ (println "parse result for ba " (just_aa_parser "ba")) - _ (println "parse result for ab " (just_aa_parser "ab")) - - _ (println "The a.a parser") - just_aa_parser (parse (nterm 'A (altOp altStart (seqOp (seqOp seqStart (term "a")) (term "a"))))) - _ (println "parse result for a " (just_aa_parser "a")) - _ (println "parse result for b " (just_aa_parser "b")) - _ (println "parse result for aa " (just_aa_parser "aa")) - _ (println "parse result for ba " (just_aa_parser "ba")) - _ (println "parse result for ab " (just_aa_parser "ab")) - - _ (println "The b|a.a parser") - just_aa_parser (parse (nterm 'A (altOp (altOp altStart (seqOp seqStart (term "b"))) (seqOp (seqOp seqStart (term "a")) (term "a"))))) - _ (println "parse result for a " (just_aa_parser "a")) - _ (println "parse result for b " (just_aa_parser "b")) - _ (println "parse result for aa " (just_aa_parser "aa")) - _ (println "parse result for ba " (just_aa_parser "ba")) - _ (println "parse result for ab " (just_aa_parser "ab")) - - _ (println "The a|a,A parser") - just_aa_parser (let-rec ( - As (nterm 'A (altOp (altOp altStart (seqOp seqStart (term "a"))) (seqOp (seqOp (seqOp seqStart (term "a")) (term ",")) As))) - ) (parse As)) - _ (println "parse result for a " (just_aa_parser "a")) - _ (println "parse result for b " (just_aa_parser "b")) - _ (println "parse result for aa " (just_aa_parser "aa")) - _ (println "parse result for ba " (just_aa_parser "ba")) - _ (println "parse result for ab " (just_aa_parser "ab")) - _ (println "parse result for a,a " (just_aa_parser "a,a")) - _ (println "parse result for a,a,a " (just_aa_parser "a,a,a")) - -) nil)) diff --git a/working_files/import_test.kp b/working_files/import_test.kp deleted file mode 100644 index eddce14..0000000 --- a/working_files/import_test.kp +++ /dev/null @@ -1 +0,0 @@ -(let (a 123) (provide a)) diff --git a/working_files/index.html b/working_files/index.html deleted file mode 100644 index d898593..0000000 --- a/working_files/index.html +++ /dev/null @@ -1,425 +0,0 @@ - - - - - - - -

Nathan Braswell's Current Programming Language / Compiler Research

- Repository: https://github.com/limvot/kraken -

- Table of Contents: If you're impatient, jump to the code examples! - - -

Concept:

- - -

About:

-

Currently, I am bootstrapping this new core Lisp out of my prior compiler for my programming language, Kraken. I have implemented the first version of the FUN-GLL algorithm and have working vaus and context-free reader macros. -

The general flow is that the input files will be executed with the core Lisp interpreter, and if there is a "main" symbol defined the compiler emits C code for that function & all other functions & data that it references. In this way the language supports very powerful meta-programming at compile time, including adding syntax to the language, arbitrary computation, and importing other files, and then compiles into a static executable. -

Below are a few examples of using the vau / live grammar modification / context-free reader macros to implement basic methods as well as embed the BF language into the core Lisp. The core Lisp implementation has been compiled to WebAssembly and should be able to run in your browser. Feel free to make edits and play around below. -
-Note that the current implementation is inefficient, and sometimes has problems running in phone web browsers. - -

Runnable Example Code:

-
-
; Of course -(println "Hello World") -; Just print 3 -(println "Math works:" (+ 1 2)) -
-

Output:

- - -

Vau/Kernel as simple core:

- By constructing our core language on a very simple Vau/Kernel base, we can keep the base truely tiny, and build up normal Lisp functions and programming language features in the language itself. This should help implement other programming languages concisely, and will hopefully make optimization easier and more broadly applicable. -
- Below is the current prelude that adds quoting, quasiquoting, syntax for arrays and quoting/quasiquoting, do, if, let, and even lambda itself! -
-
-
- -(set! quote (vau _ (x) x)) -(set! lambda (vau se (p b) (wrap (eval (array vau (quote _) p b) se)))) -(set! current-env (vau de () de)) -(set! fun (vau se (n p b) (eval (array set! n (array lambda p b)) se))) - -; do_helper is basically mapping eval over statements, but the last one is in TCO position -; a bit of a hack, using cond to sequence (note the repitition of the eval in TCO position if it's last, -; otherwise the same eval in cond position, and wheather or not it returns a truthy value, it recurses in TCO position) -(fun do_helper (s i se) (cond (= i (len s)) nil - (= i (- (len s) 1)) (eval (idx s i) se) - (eval (idx s i) se) (do_helper s (+ i 1) se) - true (do_helper s (+ i 1) se))) -(set! do (vau se (& s) (do_helper s 0 se))) - -(fun concat_helper (a1 a2 a3 i) (cond (< i (len a1)) (do (set-idx! a3 i (idx a1 i)) (concat_helper a1 a2 a3 (+ i 1))) - (< i (+ (len a1) (len a2))) (do (set-idx! a3 i (idx a2 (- i (len a1)))) (concat_helper a1 a2 a3 (+ i 1))) - true a3)) -(fun concat (a1 a2) (concat_helper a1 a2 (array-with-len (+ (len a1) (len a2))) 0)) - -(add_grammar_rule (quote form) (quote ( "'" optional_WS form )) (vau de (_ _ f) (array quote (eval f de)))) -(add_grammar_rule 'form '( "\\[" optional_WS space_forms optional_WS "\\]" ) (vau de (_ _ fs _ _) (concat (array array) (eval fs de)))) - -(fun vapply (f p ede) (eval (concat [f] p) ede)) -(fun lapply (f p) (eval (concat [(unwrap f)] p) (current-env))) - -(set! let1 (vau de (s v b) (eval [[vau '_ [s] b] (eval v de)] de))) -(set! let (vau de (vs b) (cond (= (len vs) 0) (eval b de) true (vapply let1 [(idx vs 0) (idx vs 1) [let (slice vs 2 -1) b]] de)))) - -(set! if (vau de (con than & else) (cond - (eval con de) (eval than de) - (> (len else) 0) (eval (idx else 0) de) - true nil))) -(fun map (f l) - (let (helper (lambda (f l n i recurse) - (if (= i (len l)) - n - (do (set-idx! n i (f (idx l i))) - (recurse f l n (+ i 1) recurse))))) - (helper f l (array-with-len (len l)) 0 helper))) -(fun flat_map (f l) - (let (helper (lambda (f l n i recurse) - (if (= i (len l)) - n - (recurse f l (concat n (f (idx l i))) (+ i 1) recurse)))) - (helper f l (array) 0 helper))) -(fun map_with_idx (f l) - (let (helper (lambda (f l n i recurse) - (if (= i (len l)) - n - (do (set-idx! n i (f i (idx l i))) - (recurse f l n (+ i 1) recurse))))) - (helper f l (array-with-len (len l)) 0 helper))) - -(fun print_through (x) (do (println x) x)) -(fun is_pair? (x) (and (array? x) (> (len x) 0))) - -(set! quasiquote (vau de (x) - (cond (is_pair? x) - (cond (and (symbol? (idx x 0)) (= (get-text (idx x 0)) "unquote")) - (eval (idx x 1) de) - true - (cond (and (is_pair? (idx x 0)) (symbol? (idx (idx x 0) 0)) (= (get-text (idx (idx x 0) 0)) "splice-unquote")) - (concat (eval (idx (idx x 0) 1) de) (vapply quasiquote [(slice x 1 -1)] de)) - true - (concat [(vapply quasiquote [(idx x 0)] de)] (vapply quasiquote [(slice x 1 -1)] de)))) - true x))) - -(add_grammar_rule 'form '("`" optional_WS form) (lambda (_ _ f) ['quasiquote f])) -(add_grammar_rule 'form '("~" optional_WS form) (lambda (_ _ f) ['unquote f])) -(add_grammar_rule 'form '("," optional_WS form) (lambda (_ _ f) ['splice-unquote f])) - - -(println "now with both array and quasiquote syntax, check out " `(1 2 3 ~(+ 7 8) ,[ 5 6 7])) -
-

Output:

- - -

Method Example:

- Let's use our meta system (attaching objects to other objects) to implement basic objects/methods, a new lambda syntax, a new block syntax, and string interpolation! - We will attach a array of alternating symbols / functions (to make this example simple, since maps aren't built in) to our data as the meta, then look up methods on it when we perform a call. The add_grammar_rule function modifies the grammar/parser currently being used to parse the file and operates as a super-powerful reader macro. We use it in this code to add a rule that transforms 
a.b(c, d)
into 
(method-call a 'b c d)
where method-call is the function that looks up the symbol 'b on the meta object attached to a and calls it with the rest of the parameters. - Note also the block ({}) syntax that translates to nested do/let expressions, the nicer lambda syntax, and the string interpolation (that even works nested!). -
- -
-
-; Load prelude so we get fun, lambda, if, quoting, etc -(load-file "./k_prime_stdlib/prelude.kp") -; First quick lookup function, since maps are not built in -(fun get-value-helper (dict key i) (if (>= i (len dict)) - nil - (if (= key (idx (idx dict i) 0)) - (idx (idx dict i) 1) - (get-value-helper dict key (+ i 1))))) -(fun get-value (dict key) (get-value-helper dict key 0)) - -; Our actual method call function -(fun method-call (object method & arguments) (let (method_fn (get-value (meta object) method)) - (if (= method_fn nil) - (println "no method " method) - (lapply method_fn (concat [object] arguments))))) -; Some nice syntactic sugar for method calls -; No params -(add_grammar_rule 'form ['form "\\." 'atom] - (lambda (o _ m) `(method-call ~o '~m))) -; params -(add_grammar_rule 'form ['form "\\." 'atom 'optional_WS "\\(" 'optional_WS 'space_forms 'optional_WS "\\)"] - (lambda (o _ m _ _ _ p _ _) `(method-call ~o '~m ,p))) - -; object creation -(fun make_constructor (members methods) - (eval `(lambda ~members - (with-meta [,members] - [,(map_with_idx (lambda (i x) [array `'~x (lambda (o) (idx o i))]) members) - ,(map (lambda (x) [array `'~(idx x 0) (idx x 1)]) methods)])))) - -; object syntax -(add_grammar_rule 'form ["obj" 'WS 'atom "\\(" ['optional_WS 'atom] * 'optional_WS "\\)" 'optional_WS "{" 'optional_WS ['atom 'optional_WS 'form 'optional_WS] * "}"] (lambda (_ _ name _ members _ _ _ _ _ methods _) - `(set! ~name (make_constructor [,(map (lambda (x) `'~(idx x 1)) members)] - [,(map (lambda (x) `['~(idx x 0) ~(idx x 2)]) methods)])))) - -; Lambda syntax -(add_grammar_rule 'form ["\\|" 'optional_WS [ 'atom 'optional_WS ] * "\\|" 'optional_WS 'form ] - (lambda (_ _ params _ _ body) `(lambda (,(map (lambda (x) (idx x 0)) params)) ~body))) - -; {} body translated to do and let -(add_grammar_rule 'block_member [ 'form ] |x| [x]) -(add_grammar_rule 'block_member [ "let" 'optional_WS 'atom 'optional_WS "=" 'optional_WS 'form ] - |_ _ name _ _ _ rhs| `(~name ~rhs)) -(fun construct_body (is_do current to_add i) - (if (> (len to_add) i) - (cond (and is_do (= (len (idx to_add i)) 1)) (construct_body true (concat current [(idx (idx to_add i) 0)]) to_add (+ i 1)) - (= (len (idx to_add i)) 1) (concat current [(construct_body true [do (idx (idx to_add i) 0)] to_add (+ i 1))]) - true (concat current [(construct_body false [let [(idx (idx to_add i) 0) (idx (idx to_add i) 1)] ] to_add (+ i 1))])) - current)) -(add_grammar_rule 'form ["{" 'optional_WS [ 'block_member 'optional_WS ] * "}"] - |_ _ inner _| (construct_body true [do] (map |x| (idx x 0) inner) 0)) - -; Call functions with function first, c style (notice no whitespace) -(add_grammar_rule 'form [ 'form 'call_form ] |f ps| (concat [f] ps)) - -; fun syntax -(add_grammar_rule 'form [ "fun" 'WS 'atom 'optional_WS "\\(" 'optional_WS [ 'atom 'optional_WS ] * "\\)" 'optional_WS 'form ] - |_ _ name _ _ _ params _ _ body| `(fun ~name (,(map |x| (idx x 0) params)) ~body)) - -; string interpolation -fun remove_dollar(done to_do i j) (cond (>= j (- (len to_do) 2)) (str done (slice to_do i -1)) - (= "\\$" (slice to_do j (+ j 2))) (remove_dollar (str done (slice to_do i j) "$") to_do (+ j 2) (+ j 2)) - true (remove_dollar done to_do i (+ j 1))) -fun fixup_str_parts(s) (remove_dollar "" (slice s 0 -2) 0 0) -(add_grammar_rule 'form [ "$\"" [ "(#|[%-[]| |[]-~]|(\\\\)|(\\n)|(\\t)|(\\*)|(\\\\$)| -|[ -!]|(\\\\\"))*$" 'form ] * "(#|[%-[]| |[]-~]|(\\\\)|(\\n)|(\\t)|(\\*)|(\\\\$)| -|[ -!]|(\\\\\"))*\"" ] - |_ string_form_pairs end| `(str ,( flat_map |x| [ (fixup_str_parts (idx x 0)) (idx x 1) ] string_form_pairs) ~(fixup_str_parts end))) - -(println $"unu |\$| $$"inner $(+ 1 2) post-inner" sual") - -obj Point( x y ) { - add |self other| { Point((+ self.x other.x) (+ self.y other.y)) } - sub |self other| { Point((- self.x other.x) (- self.y other.y)) } - to_str |self| { str("x: " self.x ", y: " self.y) } -} - -fun say_hi(name) { - println("hayo" name) -} - -fun test() { - let plus_1 = |x| (+ x 1) - let a = 1 - let b = plus_1(a) - println("some" b) - - say_hi("Marcus") - - let p1 = Point(1 2) - let p2 = Point(3 4) - let p3 = p1.add(p2) - let p4 = p1.sub(p2) - - println("p1:" p1.to_str) - println("p2:" p2.to_str) - println("p3:" p3.to_str) - println("p4:" p4.to_str) - - (+ a b) -} -println("Test result is" test()) -
-

Output:

- - -

More Complicated Example: BF as an embedded language

-
-
- -(load-file "./k_prime_stdlib/prelude.kp") - -; We don't have atoms built in, mutable arrays -; are our base building block. In order to make the -; following BF implementation nice, let's add atoms! -; They will be implmented as length 1 arrays with nice syntax for deref -(fun make-atom (x) [x]) -(fun set-atom! (x y) (set-idx! x 0 y)) -(fun get-atom (x) (idx x 0)) -(add_grammar_rule 'form ["@" 'form] (lambda (_ x) `(get-atom ~x))) - -; Now begin by defining our BF syntax & semantics -; Define our tokens as BF atoms -(add_grammar_rule 'bfs_atom ["<"] (lambda (_) '(set-atom! cursor (- @cursor 1)))) -(add_grammar_rule 'bfs_atom [">"] (lambda (_) '(set-atom! cursor (+ @cursor 1)))) -(add_grammar_rule 'bfs_atom ["\\+"] (lambda (_) '(set-idx! tape @cursor (+ (idx tape @cursor) 1)))) -(add_grammar_rule 'bfs_atom ["-"] (lambda (_) '(set-idx! tape @cursor (- (idx tape @cursor) 1)))) -(add_grammar_rule 'bfs_atom [","] (lambda (_) '(let (value (idx input @inptr)) - (do (set-atom! inptr (+ 1 @inptr)) - (set-idx! tape @cursor value))))) -(add_grammar_rule 'bfs_atom ["."] (lambda (_) '(set-atom! output (concat [(idx tape @cursor)] @output)))) - -; Define strings of BF atoms -(add_grammar_rule 'bfs ['bfs_atom *] (lambda (x) x)) - -; Add loop as an atom -; (note that closure cannot yet close over itself by value, so we pass it in) -(add_grammar_rule 'bfs_atom ["\\[" 'bfs "]"] (lambda (_ x _) - `(let (f (lambda (f) - (if (= 0 (idx tape @cursor)) - nil - (do ,x (f f))))) - (f f)))) - -; For now, stick BFS rule inside an unambigious BFS block -; Also add setup code -(add_grammar_rule 'form ["bf" 'optional_WS "{" 'optional_WS 'bfs 'optional_WS "}"] - (lambda (_ _ _ _ x _ _) - `(lambda (input) - (let ( - tape (array 0 0 0 0 0) - cursor (make-atom 0) - inptr (make-atom 0) - output (make-atom (array)) - ) - (do (println "beginning bfs") ,x (idx output 0)))))) - -; Let's try it out! This BF program prints the input 3 times -(println (bf { ,>+++[<.>-] } [1337])) -; we can also have it compile into our main program -(fun main () (do (println "BF: " (bf { ,>+++[<.>-] } [1337])) 0)) -
-

Output:

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

Next Steps

-
    -
  • Implement persistent functional data structures -
      -
    • Hash Array-Mapped Trie (HAMT) / Relaxed Radix Balance Tree (RRB-Tree) -
    • Hash Map based on the above -
    • Hash Set based on the above -
    -
  • Prototype Type Systems as Macros, may require macro system rewrite/upgrade -
  • Sketch out Kraken language on top of core Lisp, includes basic Hindley-Milner type system implemented with Macros and above data structures -
  • Re-self-host using functional approach in above Kraken language -
  • Use Type System Macros to implement automatic transient creation on HAMT/RBB-Tree as an optimization -
  • Implement RVSDG IR and develop best bang-for-buck optimizations using it -
- - - - - - - diff --git a/working_files/k_prime_stdlib/method.kp b/working_files/k_prime_stdlib/method.kp deleted file mode 100644 index 1890fcc..0000000 --- a/working_files/k_prime_stdlib/method.kp +++ /dev/null @@ -1,100 +0,0 @@ -; First quick lookup function, since maps are not built in -(fun get-value-helper (dict key i) (if (>= i (len dict)) - nil - (if (= key (idx (idx dict i) 0)) - (idx (idx dict i) 1) - (get-value-helper dict key (+ i 1))))) -(fun get-value (dict key) (get-value-helper dict key 0)) - -; Our actual method call function -(fun method-call (object method & arguments) (let (method_fn (get-value (meta object) method)) - (if (= method_fn nil) - (println "no method " method) - (lapply method_fn (concat [object] arguments))))) -; Some nice syntactic sugar for method calls -; No params -(add_grammar_rule 'form ['form "\\." 'atom] - (lambda (o _ m) `(method-call ~o '~m))) -; params -(add_grammar_rule 'form ['form "\\." 'atom 'optional_WS "\\(" 'optional_WS 'space_forms 'optional_WS "\\)"] - (lambda (o _ m _ _ _ p _ _) `(method-call ~o '~m ,p))) - -; object creation -(fun make_constructor (members methods) - (eval `(lambda ~members - (with-meta [,members] - [,(map_with_idx (lambda (i x) [array `'~x (lambda (o) (idx o i))]) members) - ,(map (lambda (x) [array `'~(idx x 0) (idx x 1)]) methods)])))) - -; object syntax -(add_grammar_rule 'form ["obj" 'WS 'atom "\\(" ['optional_WS 'atom] * 'optional_WS "\\)" 'optional_WS "{" 'optional_WS ['atom 'optional_WS 'form 'optional_WS] * "}"] (lambda (_ _ name _ members _ _ _ _ _ methods _) - `(set! ~name (make_constructor [,(map (lambda (x) `'~(idx x 1)) members)] - [,(map (lambda (x) `['~(idx x 0) ~(idx x 2)]) methods)])))) - -; Lambda syntax -(add_grammar_rule 'form ["\\|" 'optional_WS [ 'atom 'optional_WS ] * "\\|" 'optional_WS 'form ] - (lambda (_ _ params _ _ body) `(lambda (,(map (lambda (x) (idx x 0)) params)) ~body))) - -; {} body translated to do and let -(add_grammar_rule 'block_member [ 'form ] |x| [x]) -(add_grammar_rule 'block_member [ "let" 'optional_WS 'atom 'optional_WS "=" 'optional_WS 'form ] - |_ _ name _ _ _ rhs| `(~name ~rhs)) -(fun construct_body (is_do current to_add i) - (if (> (len to_add) i) - (cond (and is_do (= (len (idx to_add i)) 1)) (construct_body true (concat current [(idx (idx to_add i) 0)]) to_add (+ i 1)) - (= (len (idx to_add i)) 1) (concat current [(construct_body true [do (idx (idx to_add i) 0)] to_add (+ i 1))]) - true (concat current [(construct_body false [let [(idx (idx to_add i) 0) (idx (idx to_add i) 1)] ] to_add (+ i 1))])) - current)) -(add_grammar_rule 'form ["{" 'optional_WS [ 'block_member 'optional_WS ] * "}"] - |_ _ inner _| (construct_body true [do] (map |x| (idx x 0) inner) 0)) - -; Call functions with function first, c style (notice no whitespace) -(add_grammar_rule 'form [ 'form 'call_form ] |f ps| (concat [f] ps)) - -; fun syntax -(add_grammar_rule 'form [ "fun" 'WS 'atom 'optional_WS "\\(" 'optional_WS [ 'atom 'optional_WS ] * "\\)" 'optional_WS 'form ] - |_ _ name _ _ _ params _ _ body| `(fun ~name (,(map |x| (idx x 0) params)) ~body)) - -; string interpolation -fun remove_dollar(done to_do i j) (cond (>= j (- (len to_do) 2)) (str done (slice to_do i -1)) - (= "\\$" (slice to_do j (+ j 2))) (remove_dollar (str done (slice to_do i j) "$") to_do (+ j 2) (+ j 2)) - true (remove_dollar done to_do i (+ j 1))) -fun fixup_str_parts(s) (remove_dollar "" (slice s 0 -2) 0 0) -(add_grammar_rule 'form [ "$\"" [ "(#|[%-[]| |[]-~]|(\\\\)|(\\n)|(\\t)|(\\*)|(\\\\$)| -|[ -!]|(\\\\\"))*$" 'form ] * "(#|[%-[]| |[]-~]|(\\\\)|(\\n)|(\\t)|(\\*)|(\\\\$)| -|[ -!]|(\\\\\"))*\"" ] - |_ string_form_pairs end| `(str ,( flat_map |x| [ (fixup_str_parts (idx x 0)) (idx x 1) ] string_form_pairs) ~(fixup_str_parts end))) - -(println $"unu |\$| $$"inner $(+ 1 2) post-inner" sual") - -obj Point( x y ) { - add |self other| { Point((+ self.x other.x) (+ self.y other.y)) } - sub |self other| { Point((- self.x other.x) (- self.y other.y)) } - to_str |self| { str("x: " self.x ", y: " self.y) } -} - -fun say_hi(name) { - println("hayo" name) -} - -fun test() { - let plus_1 = |x| (+ x 1) - let a = 1 - let b = plus_1(a) - println("some" b) - - say_hi("Marcus") - - let p1 = Point(1 2) - let p2 = Point(3 4) - let p3 = p1.add(p2) - let p4 = p1.sub(p2) - - println("p1:" p1.to_str) - println("p2:" p2.to_str) - println("p3:" p3.to_str) - println("p4:" p4.to_str) - - (+ a b) -} -println("Test result is" test()) diff --git a/working_files/k_prime_stdlib/prelude.kp b/working_files/k_prime_stdlib/prelude.kp deleted file mode 100644 index ec172bd..0000000 --- a/working_files/k_prime_stdlib/prelude.kp +++ /dev/null @@ -1,82 +0,0 @@ - -(set! quote (vau _ (x) x)) -(set! lambda (vau se (p b) (wrap (eval (array vau (quote _) p b) se)))) -(set! current-env (vau de () de)) -(set! fun (vau se (n p b) (eval (array set! n (array lambda p b)) se))) - -; do_helper is basically mapping eval over statements, but the last one is in TCO position -; a bit of a hack, using cond to sequence (note the repitition of the eval in TCO position if it's last, -; otherwise the same eval in cond position, and wheather or not it returns a truthy value, it recurses in TCO position) -(fun do_helper (s i se) (cond (= i (len s)) nil - (= i (- (len s) 1)) (eval (idx s i) se) - (eval (idx s i) se) (do_helper s (+ i 1) se) - true (do_helper s (+ i 1) se))) -(set! do (vau se (& s) (do_helper s 0 se))) - -(fun concat_helper (a1 a2 a3 i) (cond (< i (len a1)) (do (set-idx! a3 i (idx a1 i)) (concat_helper a1 a2 a3 (+ i 1))) - (< i (+ (len a1) (len a2))) (do (set-idx! a3 i (idx a2 (- i (len a1)))) (concat_helper a1 a2 a3 (+ i 1))) - true a3)) -(fun concat (a1 a2) (concat_helper a1 a2 (array-with-len (+ (len a1) (len a2))) 0)) - -(add_grammar_rule (quote form) (quote ( "'" optional_WS form )) (vau de (_ _ f) (array quote (eval f de)))) -(add_grammar_rule 'form '( "\\[" optional_WS space_forms optional_WS "\\]" ) (vau de (_ _ fs _ _) (concat (array array) (eval fs de)))) - -(fun vapply (f p ede) (eval (concat [f] p) ede)) -(fun lapply (f p) (eval (concat [(unwrap f)] p) (current-env))) - -(set! let1 (vau de (s v b) (eval [[vau '_ [s] b] (eval v de)] de))) -(set! let (vau de (vs b) (cond (= (len vs) 0) (eval b de) true (vapply let1 [(idx vs 0) (idx vs 1) [let (slice vs 2 -1) b]] de)))) - -(set! if (vau de (con than & else) (cond - (eval con de) (eval than de) - (> (len else) 0) (eval (idx else 0) de) - true nil))) -(fun map (f l) - (let (helper (lambda (f l n i recurse) - (if (= i (len l)) - n - (do (set-idx! n i (f (idx l i))) - (recurse f l n (+ i 1) recurse))))) - (helper f l (array-with-len (len l)) 0 helper))) -(fun flat_map (f l) - (let (helper (lambda (f l n i recurse) - (if (= i (len l)) - n - (recurse f l (concat n (f (idx l i))) (+ i 1) recurse)))) - (helper f l (array) 0 helper))) -(fun map_with_idx (f l) - (let (helper (lambda (f l n i recurse) - (if (= i (len l)) - n - (do (set-idx! n i (f i (idx l i))) - (recurse f l n (+ i 1) recurse))))) - (helper f l (array-with-len (len l)) 0 helper))) - -(fun print_through (x) (do (println x) x)) -(fun is_pair? (x) (and (array? x) (> (len x) 0))) - -(set! quasiquote (vau de (x) - (cond (is_pair? x) - (cond (and (symbol? (idx x 0)) (= (get-text (idx x 0)) "unquote")) - (eval (idx x 1) de) - true - (cond (and (is_pair? (idx x 0)) (symbol? (idx (idx x 0) 0)) (= (get-text (idx (idx x 0) 0)) "splice-unquote")) - (concat (eval (idx (idx x 0) 1) de) (vapply quasiquote [(slice x 1 -1)] de)) - true - (concat [(vapply quasiquote [(idx x 0)] de)] (vapply quasiquote [(slice x 1 -1)] de)))) - true x))) - -(add_grammar_rule 'form '("`" optional_WS form) (lambda (_ _ f) ['quasiquote f])) -(add_grammar_rule 'form '("~" optional_WS form) (lambda (_ _ f) ['unquote f])) -(add_grammar_rule 'form '("," optional_WS form) (lambda (_ _ f) ['splice-unquote f])) - -(set! Y (lambda (f) - ((lambda (x) (x x)) - (lambda (x) (f (lambda (& y) (lapply (x x) y))))))) - -(set! vY (lambda (f) - ((lambda (x) (x x)) - (lambda (x) (f (vau de (& y) (vapply (x x) y de))))))) - -(set! rep (Y (lambda (recurse) (wrap (vau de () - (do (println (eval (read-string (get_line "> ")) de)) (recurse))))))) diff --git a/working_files/match.kp b/working_files/match.kp deleted file mode 100644 index ba302f9..0000000 --- a/working_files/match.kp +++ /dev/null @@ -1,32 +0,0 @@ -(with_import "./collections.kp" -(let ( - - match (vau de (x & cases) (let ( - x (eval x de) - evaluate_case (rec-lambda recurse (name_dict x c) (cond - ; an explicit nil name_dict case allows us to simply fold over recurse in the array case later - (nil? name_dict) nil - (symbol? c) (put name_dict c x) - (and (int? x) (int? c) (= x c)) name_dict - (and (string? x) (string? c) (= x c)) name_dict - (and (bool? x) (bool? c) (= x c)) name_dict - (and (combiner? x) (combiner? c) (= x c)) name_dict - ; check for invocation of quote directly - ; not necessarily ideal if they define their own quote or something - (and (symbol? x) (array? c) (= 2 (len c)) (= quote (idx c 0)) (= x (idx c 1))) name_dict - ; ditto with above, but with unquote to allow matching against the *value* of variables - (and (array? c) (= 2 (len c)) (= 'unquote (idx c 0)) (= x (eval (idx c 1) de))) name_dict - ; ditto with above, but with array. Also note this means you have to use '[' and ']' as calling - ; array explicitly will give you the symbol array instead... - (and (array? x) (array? c) (= (+ 1 (len x)) (len c)) (= array (idx c 0))) (foldl recurse name_dict x (slice c 1 -1)) - true nil - )) - - iter (rec-lambda recurse (x i cases) (if (>= i (len cases)) (error "none of match arms matched!") - (let ( mapping (evaluate_case empty_dict x (idx cases i))) - (if (!= nil mapping) (eval (idx cases (+ i 1)) (add-dict-to-env de mapping)) - (recurse x (+ i 2) cases))))) - ) (iter x 0 cases))) -) - (provide match) -)) diff --git a/working_files/match_test.kp b/working_files/match_test.kp deleted file mode 100644 index 9dbc817..0000000 --- a/working_files/match_test.kp +++ /dev/null @@ -1,49 +0,0 @@ -(with_import "./match.kp" -(do - (println "first " - (match 1 - 1 true - a (+ a 1) - )) - - (println "second " - (match 3 - 1 true - a (+ a 1) - )) - (println "third " - (match "str" - 1 true - "str" "It was a string!" - a (+ a 1) - )) - (println "fourth " - (match [ 1337 "str" ] - 1 true - "str" "It was a string!" - [ 1337 "str" ] "matched an array of int str" - a (+ a 1) - )) - (println "fifth " - (match [ 1337 "str" 'sy ] - 1 true - "str" "It was a string!" - [ 1337 "str" 'sy ] "matched an array of int str symbol" - a (+ a 1) - )) - (println "sixth " - (match [ 1337 "str" 'walla + 11 false 'kraken [ 'inner 'middle 'end ] [ 'inner1 'middle1 'end1 ] ] - 1 true - "str" "It was a string!" - [ 1337 "str" 'walla + a false b [ 'inner c 'end ] d ] (str "matched, and got " a b c d) - a (+ a 1) - )) - (println "seventh " - (let (b 2) - (match [ 1337 [ 1 2 3] 11 ] - 1 true - "str" "It was a string!" - [ 1337 [ a ~b c] 11 ] (str "matched, and got " a c " while checking based on inserted " b) - a "sigh, failed to match" - ))) -)) diff --git a/working_files/method.kp b/working_files/method.kp deleted file mode 100644 index adfc1cf..0000000 --- a/working_files/method.kp +++ /dev/null @@ -1,103 +0,0 @@ -; Load prelude so we get fun, lambda, if, quoting, etc -(load-file "./k_prime_stdlib/prelude.kp") -; First quick lookup function, since maps are not built in -(fun get-value-helper (dict key i) (if (>= i (len dict)) - nil - (if (= key (idx (idx dict i) 0)) - (idx (idx dict i) 1) - (get-value-helper dict key (+ i 1))))) -(fun get-value (dict key) (get-value-helper dict key 0)) - -; Our actual method call function -(fun method-call (object method & arguments) (let (method_fn (get-value (meta object) method)) - (if (= method_fn nil) - (println "no method " method) - (lapply method_fn (concat [object] arguments))))) -; Some nice syntactic sugar for method calls -; No params -(add_grammar_rule 'form ['form "\\." 'atom] - (lambda (o _ m) `(method-call ~o '~m))) -; params -(add_grammar_rule 'form ['form "\\." 'atom 'optional_WS "\\(" 'optional_WS 'space_forms 'optional_WS "\\)"] - (lambda (o _ m _ _ _ p _ _) `(method-call ~o '~m ,p))) - -; object creation -(fun make_constructor (members methods) - (eval `(lambda ~members - (with-meta [,members] - [,(map_with_idx (lambda (i x) [array `'~x (lambda (o) (idx o i))]) members) - ,(map (lambda (x) [array `'~(idx x 0) (idx x 1)]) methods)])))) - -; object syntax -(add_grammar_rule 'form ["obj" 'WS 'atom "\\(" ['optional_WS 'atom] * 'optional_WS "\\)" 'optional_WS "{" 'optional_WS ['atom 'optional_WS 'form 'optional_WS] * "}"] (lambda (_ _ name _ members _ _ _ _ _ methods _) - `(set! ~name (make_constructor [,(map (lambda (x) `'~(idx x 1)) members)] - [,(map (lambda (x) `['~(idx x 0) ~(idx x 2)]) methods)])))) - -; Lambda syntax -(add_grammar_rule 'form ["\\|" 'optional_WS [ 'atom 'optional_WS ] * "\\|" 'optional_WS 'form ] - (lambda (_ _ params _ _ body) `(lambda (,(map (lambda (x) (idx x 0)) params)) ~body))) - -; {} body translated to do and let -(add_grammar_rule 'block_member [ 'form ] |x| [x]) -(add_grammar_rule 'block_member [ "let" 'optional_WS 'atom 'optional_WS "=" 'optional_WS 'form ] - |_ _ name _ _ _ rhs| `(~name ~rhs)) -(fun construct_body (is_do current to_add i) - (if (> (len to_add) i) - (cond (and is_do (= (len (idx to_add i)) 1)) (construct_body true (concat current [(idx (idx to_add i) 0)]) to_add (+ i 1)) - (= (len (idx to_add i)) 1) (concat current [(construct_body true [do (idx (idx to_add i) 0)] to_add (+ i 1))]) - true (concat current [(construct_body false [let [(idx (idx to_add i) 0) (idx (idx to_add i) 1)] ] to_add (+ i 1))])) - current)) -(add_grammar_rule 'form ["{" 'optional_WS [ 'block_member 'optional_WS ] * "}"] - |_ _ inner _| (construct_body true [do] (map |x| (idx x 0) inner) 0)) - -; Call functions with function first, c style (notice no whitespace) -(add_grammar_rule 'form [ 'form 'call_form ] |f ps| (concat [f] ps)) - -; fun syntax -(add_grammar_rule 'form [ "fun" 'WS 'atom 'optional_WS "\\(" 'optional_WS [ 'atom 'optional_WS ] * "\\)" 'optional_WS 'form ] - |_ _ name _ _ _ params _ _ body| `(fun ~name (,(map |x| (idx x 0) params)) ~body)) - -; string interpolation -fun remove_dollar(done to_do i j) (cond (>= j (- (len to_do) 2)) (str done (slice to_do i -1)) - (= "\\$" (slice to_do j (+ j 2))) (remove_dollar (str done (slice to_do i j) "$") to_do (+ j 2) (+ j 2)) - true (remove_dollar done to_do i (+ j 1))) -fun fixup_str_parts(s) (remove_dollar "" (slice s 0 -2) 0 0) -(add_grammar_rule 'form [ "$\"" [ "(#|[%-[]| |[]-~]|(\\\\)|(\\n)|(\\t)|(\\*)|(\\\\$)| -|[ -!]|(\\\\\"))*$" 'form ] * "(#|[%-[]| |[]-~]|(\\\\)|(\\n)|(\\t)|(\\*)|(\\\\$)| -|[ -!]|(\\\\\"))*\"" ] - |_ string_form_pairs end| `(str ,( flat_map |x| [ (fixup_str_parts (idx x 0)) (idx x 1) ] string_form_pairs) ~(fixup_str_parts end))) - -(println $"unu |\$| $$"inner $(+ 1 2) post-inner" sual") - -obj Point( x y ) { - add |self other| { Point((+ self.x other.x) (+ self.y other.y)) } - sub |self other| { Point((- self.x other.x) (- self.y other.y)) } - to_str |self| { str("x: " self.x ", y: " self.y) } -} - -fun say_hi(name) { - println("hayo" name) -} - -fun test() { - let plus_1 = |x| (+ x 1) - let a = 1 - let b = plus_1(a) - println("some" b) - - say_hi("Marcus") - - let p1 = Point(1 2) - let p2 = Point(3 4) - let p3 = p1.add(p2) - let p4 = p1.sub(p2) - - println("p1:" p1.to_str) - println("p2:" p2.to_str) - println("p3:" p3.to_str) - println("p4:" p4.to_str) - - (+ a b) -} -println("Test result is" test()) - diff --git a/working_files/new_kraken.kp b/working_files/new_kraken.kp deleted file mode 100644 index 6d70f46..0000000 --- a/working_files/new_kraken.kp +++ /dev/null @@ -1,102 +0,0 @@ -(let ( - - ; First quick lookup function, since maps are not built in - get-value-helper (rec-lambda recurse (dict key i) (if (>= i (len dict)) - nil - (if (= key (idx (idx dict i) 0)) - (idx (idx dict i) 1) - (recurse dict key (+ i 1))))) - get-value (lambda (dict key) (get-value-helper dict key 0)) - - ; Our actual method call function - method-call (lambda (object method & arguments) (let (method_fn (get-value (meta object) method)) - (if (= method_fn nil) - (println "no method " method) - (lapply method_fn (concat [object] arguments))))) - - - make_constructor (lambda (name members methods) - `(~rec-lambda ~name ~members - (~with-meta [,members] - [,(map_i (lambda (i x) [array `'~x (lambda (o) (idx o i))]) members) - ,(map (lambda (x) [array `'~(idx x 0) (idx x 1)]) methods)]))) - - - ; {} body translated to do and let - construct_body (rec-lambda recurse (is_do current to_add i) - (if (> (len to_add) i) - (cond (and is_do (= (len (idx to_add i)) 1)) (recurse true (concat current [(idx (idx to_add i) 0)]) to_add (+ i 1)) - (= (len (idx to_add i)) 1) (concat current [(recurse true [do (idx (idx to_add i) 0)] to_add (+ i 1))]) - (= (len (idx to_add i)) 3) (concat current [[with_import (idx (idx to_add i) 0) (recurse false [do] to_add (+ i 1))]]) - true (concat current [(recurse false [let [(idx (idx to_add i) 0) (idx (idx to_add i) 1)] ] to_add (+ i 1))])) - current)) - - - ; string interpolation - remove_dollar (rec-lambda recurse (done to_do i j) (cond (>= j (- (len to_do) 2)) (str done (slice to_do i -1)) - (= "\\$" (slice to_do j (+ j 2))) (recurse (str done (slice to_do i j) "$") to_do (+ j 2) (+ j 2)) - true (recurse done to_do i (+ j 1)))) - fixup_str_parts (lambda (s) (remove_dollar "" (slice s 0 -2) 0 0)) - - - - new_kraken_untyped (concat standard_grammar [ - - [ 'expr [ 'number ] (lambda (x) x) ] - [ 'expr [ 'string ] (lambda (x) x) ] - [ 'expr [ 'bool_nil_symbol ] (lambda (x) x) ] - - [ 'call_innards [ 'WS * ] (lambda (_) []) ] - [ 'call_innards [ 'expr [ 'WS 'expr ] * ] (lambda (f r) (concat [f] (map (lambda (x) (idx x 1)) r))) ] - - [ 'expr ['expr "\\." 'bool_nil_symbol] (lambda (o _ m) `(~method-call ~o '~m)) ] - ; params - [ 'expr ['expr "\\." 'bool_nil_symbol "\\(" 'call_innards "\\)"] - (lambda (o _ m _ p _) `(~method-call ~o '~m ,p)) ] - - - [ 'expr [ "\\|" 'call_innards "\\|" 'WS * 'expr ] - (lambda (_ params _ _ body) `(lambda (,params) ~body)) ] - - ; Call functions with function first, c style (notice no whitespace) - [ 'expr [ 'expr "\\(" 'call_innards "\\)" ] - (lambda (f _ ps _) (concat [f] ps)) ] - - ; fun syntax - [ 'block_member [ "fun" 'WS 'bool_nil_symbol 'WS * "\\(" 'call_innards "\\)" 'WS * 'expr ] - (lambda (_ _ name _ _ params _ _ body) `(~name (~lambda (,params) ~body))) ] - - [ 'block_member [ 'expr ] (lambda (x) [x]) ] - [ 'block_member [ "let" 'WS * 'bool_nil_symbol 'WS * "=" 'WS * 'expr ] - (lambda (_ _ name _ _ _ rhs) `(~name ~rhs)) ] - ; object syntax - [ 'block_member ["obj" 'WS 'bool_nil_symbol "\\(" ['WS * 'bool_nil_symbol] * 'WS * "\\)" 'WS * "{" 'WS * ['bool_nil_symbol 'WS * 'expr 'WS *] * "}"] - (lambda (_ _ name _ members _ _ _ _ _ methods _) - [name (make_constructor name (map (lambda (x) (idx x 1)) members) - (map (lambda (x) [(idx x 0) (idx x 2)]) methods))]) ] - ; import - [ 'block_member [ "with_import" 'WS 'string 'WS * ":" ] - (lambda (_ _ file _ _) [file 0 0]) ] - - [ 'expr ["{" 'WS * 'block_member "}"] - (lambda (_ _ inner _) (construct_body true [do] [inner] 0)) ] - [ 'expr ["{" 'WS * [ 'block_member 'WS ] * "}"] - (lambda (_ _ inner _) (construct_body true [do] (map (lambda (x) (idx x 0)) inner) 0)) ] - - [ 'new_kraken_start_symbol [ 'WS * [ 'block_member 'WS ] * ] - (lambda (_ inner) (construct_body true [do] (map (lambda (x) (idx x 0)) inner) 0)) ] - - - [ 'expr [ "$\"" [ "(#|[%-[]| |[]-~]|(\\\\\\\\)|(\\\\n)|(\\\\t)|(\\*)|(\\\\$)| -|[ -!]|(\\\\\"))*$" 'expr ] * "(#|[%-[]| |[]-~]|(\\\\\\\\)|(\\\\n)|(\\\\t)|(\\*)|(\\\\$)| -|[ -!]|(\\\\\"))*\"" ] - (lambda (_ string_expr_pairs end) `(str ,( flat_map (lambda (x) [ (fixup_str_parts (idx x 0)) (idx x 1) ]) string_expr_pairs) ~(fixup_str_parts end))) ] - - ; Swapping back and forth between underlying Lisp syntax - ; Might want to disable this when we start doing typing - ; till we figure out how to type Vau and such. - [ 'expr [ "\\\\" 'form ] (lambda (_ inner) inner) ] - [ 'form [ "\\\\" 'expr ] (lambda (_ inner) inner) ] - ])) - (provide new_kraken_untyped) -) diff --git a/working_files/new_kraken_test.kp b/working_files/new_kraken_test.kp deleted file mode 100644 index 5a65e6e..0000000 --- a/working_files/new_kraken_test.kp +++ /dev/null @@ -1,49 +0,0 @@ -#lang (with_import "./new_kraken.kp" new_kraken_untyped) new_kraken_start_symbol - -let my_var = 1337 -println($"this is string interpolation: ${+(1 3 4)} <- cool right? another $my_var yep even variables") - -obj Point( x y ) { - add |self other| { Point(+(self.x other.x) +(self.y other.y)) } - sub |self other| { Point(-(self.x other.x) -(self.y other.y)) } - to_str |self| { str("x: " self.x ", y: " self.y) } -} - -fun say_hi(name) { - println("hayo" name) -} - -fun test() { - let plus_1 = |x| { +(x 1) } - let a = 1 - let b = plus_1(a) - println("some" b) - - say_hi("Marcus") - - let p1 = Point(1 2) - let p2 = Point(3 4) - let p3 = p1.add(p2) - let p4 = p1.sub(p2) - say_hi("Charlie/Betty") - - println("p1:" p1.to_str) - println("p2:" p2.to_str) - println("p3:" p3.to_str) - println("p4:" p4.to_str) - - println("before + a b" +(a b)) - with_import("./import_test.kp" println("after + a b" +(a b))) - println("post after + a b" +(a b)) - with_import "./import_test.kp": - println("post new impot after + a b" +(a b)) - println("We're back baby" \(+ 1 13 - (do - (println "hahaha" 'a \{ - let a = 75 - let b = 75 - println("Inside hahaha more HAHAHAA " +(1 2 a b)) - "Inside Result" - }) 4))) -} -println("Test result is" test()) diff --git a/working_files/partial_eval.kp b/working_files/partial_eval.kp deleted file mode 100644 index f09675f..0000000 --- a/working_files/partial_eval.kp +++ /dev/null @@ -1,521 +0,0 @@ -(with_import "./collections.kp" -(let ( - ; For right now we only support calling partial_eval in such a way that it partial evals against - ; the root env, but this is could and really should be extended. We could at least check if the env we're called with - ; is the root_env, or if what we look up in whatever env is passed in matches something in the root env - ; Care should also be taken when evaluating outside combinators to have them be in the right env, etc - - ; Here is every form in k' - ; True - ; False - ; Env: *KPEnv - ; Combiner: KPCombiner / BuiltinCombiner: KPBuiltinCombiner - ; String: str - ; Symbol: str - ; Int: int - ; Array: rc> - ; Nil - - - ; Ok, some more things we need / need to change - ; 1) meta... - ; Honestly, I'm tempted to get rid of it - - ; Possible marked values - ; ['val v] - v is a value that evaluates to itself, and not a combiner or env, as those have their own metadata. Not an array or symbol - ; That means it's true/false/a string/ an int/nil - ; ['marked_array is_val a] - a contains marked values. if is_val, then it's the value version, and must be stripped back into (array ...), - ; otherwise it's a calling form, and should be lowered back to (...). Also, if it's is_val, partial_eval won't perform a call, etc - ; ['marked_symbol is_val s] - a symbol. is_val has the same meaning as in marked_array - ; ['comb wrap_level de? se variadic params body] - A combiner. Contains the static env and the actual function, if possible. - ; It is possible to have a combiner without an actual function, but that's only generated when - ; we know it's about to be called and we won't have to strip-lower it - ; ['prim_comb ] - A primitive combiner! It has it's own special handler function to partial eval - ; ['env is_real de_bruijn_idx_or_nil [ ['symbol marked_value ]... ]] - A marked env - - - val? (lambda (x) (= 'val (idx x 0))) - .val (lambda (x) (idx x 1)) - marked_array? (lambda (x) (= 'marked_array (idx x 0))) - .marked_array_is_val (lambda (x) (idx x 1)) - .marked_array_values (lambda (x) (idx x 2)) - marked_symbol? (lambda (x) (= 'marked_symbol (idx x 0))) - .marked_symbol_is_val (lambda (x) (idx x 1)) - .marked_symbol_value (lambda (x) (idx x 2)) - comb? (lambda (x) (= 'comb (idx x 0))) - .comb (lambda (x) (slice x 1 -1)) - prim_comb? (lambda (x) (= 'prim_comb (idx x 0))) - .prim_comb (lambda (x) (idx x 1)) - marked_env? (lambda (x) (= 'env (idx x 0))) - marked_env_real? (lambda (x) (idx x 1)) - .marked_env_idx (lambda (x) (idx x 2)) - .env_marked (lambda (x) (idx x 3)) - - later? (rec-lambda recurse (x) (or (and (marked_array? x) (or (= false (.marked_array_is_val x)) (foldl (lambda (a x) (or a (recurse x))) false (.marked_array_values x)))) - (and (marked_symbol? x) (= false (.marked_symbol_is_val x))) - ; This is now taken care of via the de Bruijn >= 0 check in call, otherwise these are values, kinda, as long as they don't go negative (or are real) - ;(and (marked_env? x) (not (marked_env_real? x))) - ;(and (comb? x) (let ([wrap_level de? se variadic params body] (.comb x) - ; ; this is the complex bit - we should do something like check if - ; ; se is fake check to see if there are symbols or eval that could use it - ; ; or a sub-comb's se, or if de is non-nil and used in some sub-call. - ; comb_is_later (recurse se) - ; ) comb_is_later)) - )) - false? (lambda (x) (cond (and (marked_array? x) (= false (.marked_array_is_val x))) (error (str "got a later marked_array passed to false? " x)) - (and (marked_symbol? x) (= false (.marked_symbol_is_val x))) (error (str "got a later marked_symbol passed to false? " x)) - (val? x) (not (.val x)) - true false)) - - env-lookup-helper (rec-lambda recurse (dict key i fail success) (cond (and (= i (- (len dict) 1)) (= nil (idx dict i))) (fail) - (= i (- (len dict) 1)) (recurse (.env_marked (idx dict i)) key 0 fail success) - (= key (idx (idx dict i) 0)) (success (idx (idx dict i) 1)) - true (recurse dict key (+ i 1) fail success))) - env-lookup (lambda (env key) (env-lookup-helper (.env_marked env) key 0 (lambda () (error (str key " not found in env " (.env_marked env)))) (lambda (x) x))) - - mark (rec-lambda recurse (x) (cond (env? x) (error (str "called mark with an env " x)) - (combiner? x) (error (str "called mark with a combiner " x)) - (symbol? x) ['marked_symbol false x] - (array? x) ['marked_array false (map recurse x)] - true ['val x])) - - indent_str (rec-lambda recurse (i) (if (= i 0) "" - (str " " (recurse (- i 1))))) - - str_strip (lambda (& args) (lapply str (concat (slice args 0 -2) [((rec-lambda recurse (x) - (cond (val? x) (.val x) - (marked_array? x) (let (stripped_values (map recurse (.marked_array_values x))) - (if (.marked_array_is_val x) (cons array stripped_values) - stripped_values)) - (marked_symbol? x) (if (.marked_symbol_is_val x) ['quote (.marked_symbol_value x)] - (.marked_symbol_value x)) - (comb? x) (let ([wrap_level de? se variadic params body] (.comb x)) - (str " " params " " (recurse body) ">")) - (prim_comb? x) (idx x 2) - (marked_env? x) (let (e (.env_marked x) - index (.marked_env_idx x) - u (idx e -1) - ) (if u (str "<" (if (marked_env_real? x) "real" "fake") " ENV idx: " (str index) ", " (map (lambda ([k v]) [k (recurse v)]) (slice e 0 -2)) " upper: " (recurse u) ">") - "")) - true (error (str "some other str_strip? |" x "|")) - ) - ) (idx args -1))]))) - print_strip (lambda (& args) (println (lapply str_strip args))) - - strip (let (helper (rec-lambda recurse (x need_value) - (cond (val? x) (.val x) - (marked_array? x) (let (stripped_values (map (lambda (x) (recurse x need_value)) (.marked_array_values x))) - (if (.marked_array_is_val x) (if need_value (error (str "needed value for this strip but got" x)) (cons array stripped_values)) - stripped_values)) - (marked_symbol? x) (if (.marked_symbol_is_val x) (if need_value (error (str "needed value for this strip but got" x)) [quote (.marked_symbol_value x)]) - (.marked_symbol_value x)) - (comb? x) (let ([wrap_level de? se variadic params body] (.comb x) - de_entry (if de? [de?] []) - final_params (if variadic (concat (slice params 0 -2) '& [(idx params -1)]) params) - ; Honestly, could trim down the env to match what could be evaluated in the comb - ; Also if this isn't real, lower to a call to vau - se_env (if (marked_env_real? se) (recurse se true) nil) - body_v (recurse body false) - ve (concat [vau] de_entry [final_params] [body_v]) - fe ((rec-lambda recurse (x i) (if (= i 0) x (recurse [wrap x] (- i 1)))) ve wrap_level) - ) (if se_env (eval fe se_env) fe)) - (prim_comb? x) (idx x 2) - ; env emitting doesn't pay attention to real value right now, not sure if that makes sense - ; TODO: properly handle de Bruijn indexed envs - (marked_env? x) (cond (and (not need_value) (= 0 (.marked_env_idx x))) [current-env] - true (let (_ (if (not (marked_env_real? x)) (error (str_strip "trying to emit fake env!" x))) - upper (idx (.env_marked x) -1) - upper_env (if upper (recurse upper true) empty_env) - just_entries (slice (.env_marked x) 0 -2) - vdict (map (lambda ([k v]) [k (recurse v true)]) just_entries) - ) (add-dict-to-env upper_env vdict))) - true (error (str "some other strip? " x)) - ) - )) (lambda (x) (let (_ (print_strip "stripping: " x) r (helper x false) _ (println "result of strip " r)) r))) - - ; A bit wild, but what if instead of is_value we had an evaluation level integer, kinda like wrap? - ; when lowering, it could just turn into multiple evals or somesuch, though we'd have to be careful of envs... - try_unval (rec-lambda recurse (x fail_f) - (cond (marked_array? x) (if (not (.marked_array_is_val x)) [false (fail_f x)] - (let ([sub_ok subs] (foldl (lambda ([ok a] x) (let ([nok p] (recurse x fail_f)) - [(and ok nok) (concat a [p])])) - [true []] - (.marked_array_values x))) - [sub_ok ['marked_array false subs]])) - (marked_symbol? x) (if (.marked_symbol_is_val x) [true ['marked_symbol false (.marked_symbol_value x)]] - [false (fail_f x)]) - true [true x] - ) - ) - try_unval_array (lambda (x) (foldl (lambda ([ok a] x) (let ([nok p] (try_unval x (lambda (_) nil))) - [(and ok nok) (concat a [p])])) - [true []] - x)) - - ensure_val (rec-lambda recurse (x) - (cond (marked_array? x) ['marked_array true (map recurse (.marked_array_values x))] - (marked_symbol? x) ['marked_symbol true (.marked_symbol_value x)] - true x - ) - ) - - ; This is a conservative analysis, since we can't always tell what constructs introduce - ; a new binding scope & would be shadowing... we should at least be able to implement it for - ; vau/lambda, but we won't at first - in_array (let (helper (rec-lambda recurse (x a i) (cond (= i (len a)) false - (= x (idx a i)) true - true (recurse x a (+ i 1))))) - (lambda (x a) (helper x a 0))) - ; TODO: make this check for stop envs using de Bruijn indicies - contains_symbols (rec-lambda recurse (stop_envs symbols x) (cond - (val? x) false - (marked_symbol? x) (let (r (in_array (.marked_symbol_value x) symbols) - _ (if r (println "!!! contains symbols found " x " in symbols " symbols))) - r) - (marked_array? x) (foldl (lambda (a x) (or a (recurse stop_envs symbols x))) false (.marked_array_values x)) - (comb? x) (let ([wrap_level de? se variadic params body] (.comb x)) - (or (recurse stop_envs symbols se) (recurse stop_envs (filter (lambda (y) (not (or (= de? y) (in_array y params)))) symbols) body))) - - (prim_comb? x) false - (marked_env? x) (let (inner (.env_marked x)) - (cond (in_array x stop_envs) false - (foldl (lambda (a x) (or a (recurse stop_envs symbols (idx x 1)))) false (slice inner 0 -2)) true - (idx inner -1) (recurse stop_envs symbols (idx inner -1)) - true false)) - true (error (str "Something odd passed to contains_symbols " x)) - )) - - is_all_values (lambda (evaled_params) (foldl (lambda (a x) (and a (not (later? x)))) true evaled_params)) - - ; * TODO: allowing envs to be shead if they're not used. - shift_envs (rec-lambda recurse (cutoff d x) (cond - (val? x) [true x] - (marked_env? x) (let ([_env is_real dbi meat] x - [nmeat_ok nmeat] (foldl (lambda ([ok r] [k v]) (let ([tok tv] (recurse cutoff d v)) [(and ok tok) (concat r [[k tv]])])) [true []] (slice meat 0 -2)) - [nupper_ok nupper] (if (idx meat -1) (recurse cutoff d (idx meat -1)) [true nil]) - ndbi (cond (nil? dbi) nil - (>= dbi cutoff) (+ dbi d) - true dbi) - ) [(and nmeat_ok nupper_ok (or is_real (and ndbi (>= ndbi 0)))) ['env is_real ndbi (concat nmeat [nupper])]]) - (comb? x) (let ([wrap_level de? se variadic params body] (.comb x) - [se_ok nse] (recurse cutoff d se) - [body_ok nbody] (recurse (+ cutoff 1) d body) - ) [(and se_ok body_ok) ['comb wrap_level de? nse variadic params nbody]]) - (prim_comb? x) [true x] - (marked_symbol? x) [true x] - (marked_array? x) (let ([insides_ok insides] (foldl (lambda ([ok r] tx) (let ([tok tr] (recurse cutoff d tx)) [(and ok tok) (concat r [tr])])) [true []] (.marked_array_values x))) - [insides_ok ['marked_array (.marked_array_is_val x) insides]]) - true (error (str "impossible shift_envs value " x)) - )) - increment_envs (lambda (x) (idx (shift_envs 0 1 x) 1)) - decrement_envs (lambda (x) (shift_envs 0 -1 x)) - - ; TODO: instead of returning the later symbols, we could create a new value of a new type - ; ['ref de_bruijn_index_of_env index_into_env] or somesuch. Could really simplify - ; compiling, and I think make partial-eval more efficient. More accurate closes_over analysis too, I think - make_tmp_inner_env (lambda (params de? de) - ['env false 0 (concat (map (lambda (p) [p ['marked_symbol false p]]) params) (if (= nil de?) [] [ [de? ['marked_symbol false de?]] ]) [(increment_envs de)])]) - - - partial_eval_helper (rec-lambda recurse (x env env_stack indent) - (cond (val? x) x - (marked_env? x) (let (dbi (.marked_env_idx x)) - (if dbi (let (new_env (idx env_stack dbi) - ndbi (.marked_env_idx new_env) - ;_ (if (!= dbi ndbi) (error (str (str_strip "same env with different dbis " x) (str_strip " and " new_env)))) - _ (if (!= 0 ndbi) (error (str_strip "new env with non-zero dbis " x))) - _ (println (str_strip "replacing " x) (str_strip " with " new_env)) - ) - (if (= 0 dbi) new_env (idx (shift_envs 0 dbi new_env) 1))) - x)) - - (comb? x) (let ([wrap_level de? se variadic params body] (.comb x)) - (if (or (and (not (marked_env_real? env)) (not (marked_env_real? se))) ; both aren't real, re-evaluation of creation site - (and (marked_env_real? env) (not (marked_env_real? se)))) ; new env real, but se isn't - creation! - (let (inner_env (make_tmp_inner_env params de? env)) - ['comb wrap_level de? env variadic params (recurse body inner_env (cons inner_env env_stack) (+ indent 1))]) - x)) - (prim_comb? x) x - (marked_symbol? x) (if (.marked_symbol_is_val x) x - (env-lookup env (.marked_symbol_value x))) - (marked_array? x) (cond (.marked_array_is_val x) x - (= 0 (len (.marked_array_values x))) (error "Partial eval on empty array") - true (let (values (.marked_array_values x) - ;_ (println (indent_str indent) "partial_evaling comb " (idx values 0)) - _ (print_strip (indent_str indent) "partial_evaling comb " (idx values 0)) - comb (recurse (idx values 0) env env_stack (+ 1 indent)) - literal_params (slice values 1 -1) - _ (println (indent_str indent) "Going to do an array call!") - _ (print_strip (indent_str indent) " total is " x) - _ (print_strip (indent_str indent) " evaled comb is " comb) - ident (+ 1 indent) - ) - (cond (prim_comb? comb) ((.prim_comb comb) env env_stack literal_params (+ 1 indent)) - (comb? comb) (let ( - rp_eval (lambda (p) (recurse p env env_stack (+ 1 indent))) - [wrap_level de? se variadic params body] (.comb comb) - ensure_val_params (map ensure_val literal_params) - [ok appropriatly_evaled_params] ((rec-lambda param-recurse (wrap cparams) - (if (!= 0 wrap) - (let (pre_evaled (map rp_eval cparams) - [ok unval_params] (try_unval_array pre_evaled)) - (if (not ok) [ok nil] - (let (evaled_params (map rp_eval unval_params)) - (param-recurse (- wrap 1) evaled_params)))) - [true cparams]) - ) wrap_level ensure_val_params) - ok_and_non_later (and ok (is_all_values appropriatly_evaled_params)) - ) (if (not ok_and_non_later) ['marked_array false (cons comb (if (> wrap_level 0) (map rp_eval literal_params) - literal_params))] - (let ( - final_params (if variadic (concat (slice appropriatly_evaled_params 0 (- (len params) 1)) - [['marked_array true (slice appropriatly_evaled_params (- (len params) 1) -1)]]) - appropriatly_evaled_params) - [de_real de_entry] (if (!= nil de?) [ (marked_env_real? env) [ [de? (increment_envs env) ] ] ] - [ true []]) - ;_ (println (indent_str indent) "final_params params " final_params) - inner_env ['env (and de_real (marked_env_real? se)) 0 (concat (zip params (map (lambda (x) (increment_envs x)) final_params)) de_entry [(increment_envs se)])] - _ (print_strip (indent_str indent) " with inner_env is " inner_env) - _ (print_strip (indent_str indent) "going to eval " body) - - tmp_func_result (recurse body inner_env (cons inner_env env_stack) (+ 1 indent)) - _ (print_strip (indent_str indent) "evaled result of function call is " tmp_func_result) - [able_to_sub_env func_result] (decrement_envs tmp_func_result) - result_is_later (later? func_result) - _ (print_strip (indent_str indent) "success? " able_to_sub_env " decremented result of function call is " tmp_func_result) - stop_envs ((rec-lambda ser (a e) (if e (ser (cons e a) (idx (.env_marked e) -1)) a)) [] se) - result_closes_over (contains_symbols stop_envs (concat params (if de? [de?] [])) func_result) - _ (println (indent_str indent) "func call able_to_sub: " able_to_sub_env " result is later? " result_is_later " and result_closes_over " result_closes_over) - ; This could be improved to a specialized version of the function - ; just by re-wrapping it in a comb instead if we wanted. - ; Something to think about! - result (if (or (not able_to_sub_env) (and result_is_later result_closes_over)) - ['marked_array false (cons comb (if (> wrap_level 0) (map rp_eval literal_params) - literal_params))] - func_result) - ) result))) - (later? comb) ['marked_array false (cons comb literal_params)] - true (error (str "impossible comb value " x))))) - true (error (str "impossible partial_eval value " x)) - ) - ) - needs_params_val_lambda (vau de (f_sym) (let ( - actual_function (eval f_sym de) - handler (rec-lambda recurse (de env_stack params indent) (let ( - ;_ (println "partial_evaling params in need_params_val_lambda for " f_sym " is " params) - evaled_params (map (lambda (p) (partial_eval_helper p de env_stack (+ 1 indent))) params) - ) - (if (is_all_values evaled_params) (mark (lapply actual_function (map strip evaled_params))) - ['marked_array false (cons ['prim_comb recurse actual_function] evaled_params)]))) - ) [f_sym ['prim_comb handler actual_function]])) - give_up_eval_params (vau de (f_sym) (let ( - actual_function (eval f_sym de) - handler (rec-lambda recurse (de env_stack params indent) (let ( - _ (println "partial_evaling params in give_up_eval_params for " f_sym " is " params) - evaled_params (map (lambda (p) (partial_eval_helper p de env_stack (+ 1 indent))) params) - ) - ['marked_array false (cons ['prim_comb recurse actual_function] evaled_params)])) - ) [f_sym ['prim_comb handler actual_function]])) - - ; !!!!!! - ; ! I think needs_params_val_lambda should be combined with parameters_evaled_proxy - ; !!!!!! - parameters_evaled_proxy (rec-lambda recurse (pasthr_ie inner_f) (lambda (de env_stack params indent) (let ( - _ (println "partial_evaling params in parameters_evaled_proxy is " params) - [evaled_params l] (foldl (lambda ([ac i] p) (let (p (partial_eval_helper p de env_stack (+ 1 indent))) - [(concat ac [p]) (+ i 1)])) - [[] 0] - params) - ) (inner_f (lambda (& args) (lapply (recurse pasthr_ie inner_f) args)) de env_stack evaled_params indent)))) - - root_marked_env ['env true nil [ - ; Ok, so for combinators, it should partial eval the body. - ; It should then check to see if the partial-evaled body has closed over - ; any 'later values from above the combinator. If so, the combinator should - ; evaluate to a ['later [vau de? params (strip partially_evaled_body)]], otherwise it can evaluate to a 'comb. - ; Note that this 'later may be re-evaluated later if the parent function is called. - ['vau ['prim_comb (rec-lambda recurse (de env_stack params indent) (let ( - mde? (if (= 3 (len params)) (idx params 0)) - vau_mde? (if (= nil mde?) [] [mde?]) - de? (if mde? (.marked_symbol_value mde?)) - vau_de? (if (= nil de?) [] [de?]) - raw_marked_params (if (= nil de?) (idx params 0) (idx params 1)) - raw_params (map (lambda (x) (if (not (marked_symbol? x)) (error (str "not a marked symbol " x)) - (.marked_symbol_value x))) (.marked_array_values raw_marked_params)) - [variadic vau_params] (foldl (lambda ([v a] x) (if (= x '&) [true a] [v (concat a [x])])) [false []] raw_params) - body (if (= nil de?) (idx params 1) (idx params 2)) - inner_env (make_tmp_inner_env vau_params de? de) - _ (print_strip (indent_str indent) "in vau, evaluating body with 'later params - " body) - pe_body (partial_eval_helper body inner_env (cons inner_env env_stack) (+ 1 indent)) - _ (print_strip (indent_str indent) "in vau, result of evaluating body was " pe_body) - ) ['comb 0 de? de variadic vau_params pe_body] - )) vau]] - - ['wrap ['prim_comb (parameters_evaled_proxy 0 (lambda (recurse de env_stack [evaled] indent) - (if (comb? evaled) (let ([wrap_level de? se variadic params body] (.comb evaled) - wrapped_marked_fun ['comb (+ 1 wrap_level) de? se variadic params body] - ) wrapped_marked_fun) - ['marked_array false [['prim_comb recurse wrap] evaled]])) - ) wrap]] - ['unwrap ['prim_comb (parameters_evaled_proxy 0 (lambda (recurse de env_stack [evaled] indent) - (if (comb? evaled) (let ([wrap_level de? se variadic params body] (.comb evaled) - unwrapped_marked_fun ['comb (- wrap_level 1) de? se variadic params body] - ) unwrapped_marked_fun) - ['marked_array false [['prim_comb recurse unwrap] evaled]])) - ) unwrap]] - - ['eval ['prim_comb (rec-lambda recurse (de env_stack params indent) (let ( - self ['prim_comb recurse eval] - eval_env (if (= 2 (len params)) (partial_eval_helper (idx params 1) de env_stack (+ 1 indent)) - de) - eval_env_v (if (= 2 (len params)) [eval_env] []) - ) (if (not (marked_env? eval_env)) (do (print_strip (indent_str indent) "eval got not a marked env " eval_env) ['marked_array false (cons self params)]) - (let ( - _ (print_strip (indent_str indent) " partial_evaling_body the first time " (idx params 0)) - body1 (partial_eval_helper (idx params 0) de env_stack (+ 1 indent)) - _ (print_strip (indent_str indent) "after first eval of param " body1) - - ; With this, we don't actually fail as this is always a legitimate uneval - fail_handler (lambda (failed) ['marked_array false (concat [self failed] eval_env_v)]) - [ok unval_body] (try_unval body1 fail_handler) - self_fallback (fail_handler body1) - _ (print_strip (indent_str indent) "partial_evaling body for the second time in eval " unval_body) - body2 (if (= self_fallback unval_body) self_fallback (partial_eval_helper unval_body eval_env env_stack (+ 1 indent))) - _ (print_strip (indent_str indent) "and body2 is " body2) - ) body2)) - )) eval]] - - ;TODO: This could go a lot farther, not stopping after the first 'later, etc - ; Also, GAH on odd params - but only one by one - a later odd param can't be imm_eval cuz it will - ; be frozen if an earlier cond is 'later.... - ['cond ['prim_comb (parameters_evaled_proxy nil (lambda (recurse de env_stack evaled_params indent) - (if (!= 0 (% (len evaled_params) 2)) (error (str "partial eval cond with odd evaled_params " evaled_params)) - ((rec-lambda recurse_inner (i) - (cond (later? (idx evaled_params i)) ['marked_array false (cons ['prim_comb recurse cond] (slice evaled_params i -1))] - (false? (idx evaled_params i)) (recurse_inner (+ 2 i)) - true (idx evaled_params (+ 1 i))) ; we could partially_eval again passing in immediate - ; eval if it was true, to partially counteract the above GAH - ) 0) - ) - )) cond]] - (needs_params_val_lambda symbol?) - (needs_params_val_lambda int?) - (needs_params_val_lambda string?) - ; not even a gah, but kinda! - ['combiner? ['prim_comb (parameters_evaled_proxy nil (lambda (recurse de env_stack [evaled_param] indent) - (cond (comb? evaled_param) ['val true] - (prim_comb? evaled_param) ['val true] - (later? evaled_param) ['marked_array false [['prim_comb recurse combiner?] evaled_param]] - true ['val false] - ) - )) combiner?]] - ; not even a gah, but kinda! - ['env? ['prim_comb (parameters_evaled_proxy nil (lambda (recurse de env_stack [evaled_param] indent) - (cond (marked_env? evaled_param) ['val true] - (later? evaled_param) ['marked_array false [['prim_comb recurse env?] evaled_param]] - true ['val false] - ) - )) env?]] - (needs_params_val_lambda nil?) - (needs_params_val_lambda bool?) - (needs_params_val_lambda str-to-symbol) - (needs_params_val_lambda get-text) - - ['array? ['prim_comb (parameters_evaled_proxy nil (lambda (recurse de env_stack [evaled_param] indent) - (cond - (later? evaled_param) ['marked_array false [['prim_comb recurse array?] evaled_param]] - (marked_array? evaled_param) ['val true] - true ['val false] - ) - )) array?]] - ; This one's sad, might need to come back to it. - ; We need to be able to differentiate between half-and-half arrays - ; for when we ensure_params_values or whatever, because that's super wrong - ['array ['prim_comb (parameters_evaled_proxy nil (lambda (recurse de env_stack evaled_params indent) - (if (is_all_values evaled_params) ['marked_array true evaled_params] - ['marked_array false (cons ['prim_comb recurse array] evaled_params)]) - )) array]] - ['len ['prim_comb (parameters_evaled_proxy nil (lambda (recurse de env_stack [evaled_param] indent) - (cond (later? evaled_param) ['marked_array false [['prim_comb recurse len] evaled_param]] - (marked_array? evaled_param) ['val (len (.marked_array_values evaled_param))] - true (error (str "bad type to len " evaled_param)) - ) - )) len]] - ['idx ['prim_comb (parameters_evaled_proxy nil (lambda (recurse de env_stack [evaled_array evaled_idx] indent) - (cond (and (val? evaled_idx) (marked_array? evaled_array) (.marked_array_is_val evaled_array)) (idx (.marked_array_values evaled_array) (.val evaled_idx)) - true ['marked_array false [['prim_comb recurse idx] evaled_array evaled_idx]] - ) - )) idx]] - ['slice ['prim_comb (parameters_evaled_proxy nil (lambda (recurse de env_stack [evaled_array evaled_begin evaled_end] indent) - (cond (and (val? evaled_begin) (val? evaled_end) (marked_array? evaled_array) (.marked_array_is_val evaled_array)) - ['marked_array true (slice (.marked_array_values evaled_array) (.val evaled_begin) (.val evaled_end))] - true ['marked_array false [['prim_comb recurse slice] evaled_array evaled_idx evaled_begin evaled_end]] - ) - )) slice]] - ['concat ['prim_comb (parameters_evaled_proxy nil (lambda (recurse de env_stack evaled_params indent) - (cond (foldl (lambda (a x) (and a (and (marked_array? x) (.marked_array_is_val x)))) true evaled_params) ['marked_array true (lapply concat (map (lambda (x) - (.marked_array_values x)) - evaled_params))] - true ['marked_array false (cons ['prim_comb recurse concat] evaled_params)] - ) - )) concat]] - - (needs_params_val_lambda +) - (needs_params_val_lambda -) - (needs_params_val_lambda *) - (needs_params_val_lambda /) - (needs_params_val_lambda %) - (needs_params_val_lambda &) - (needs_params_val_lambda |) - (needs_params_val_lambda <<) - (needs_params_val_lambda >>) - (needs_params_val_lambda =) - (needs_params_val_lambda !=) - (needs_params_val_lambda <) - (needs_params_val_lambda <=) - (needs_params_val_lambda >) - (needs_params_val_lambda >=) - - ; these could both be extended to eliminate other known true values except for the end and vice-versa - ['and ['prim_comb (parameters_evaled_proxy nil (lambda (recurse de env_stack evaled_params indent) - ((rec-lambda inner_recurse (i) - (cond (= i (- (len evaled_params) 1)) (idx evaled_params i) - (later? (idx evaled_params i)) ['marked_array false (cons ['prim_comb recurse and] (slice evaled_params i -1))] - (false? (idx evaled_params i)) (idx evaled_params i) - true (inner_recurse (+ 1 i))) - ) 0) - )) and]] - ; see above for improvement - ['or ['prim_comb (parameters_evaled_proxy nil (lambda (recurse de env_stack evaled_params indent) - ((rec-lambda inner_recurse (i) - (cond (= i (- (len evaled_params) 1)) (idx evaled_params i) - (later? (idx evaled_params i)) ['marked_array false (cons ['prim_comb recurse or] (slice evaled_params i -1))] - (false? (idx evaled_params i)) (recurse (+ 1 i)) - true (idx evaled_params i)) - ) 0) - )) or]] - ; should make not a built in and then do here - ; OR not - I think it will actually lower correctly partially evaled - - (needs_params_val_lambda pr-str) - (needs_params_val_lambda str) - (needs_params_val_lambda prn) - (give_up_eval_params println) - ; really do need to figure out if we want to keep meta, and add it if so - (give_up_eval_params meta) - (give_up_eval_params with-meta) - ; if we want to get fancy, we could do error/recover too - (give_up_eval_params error) - (give_up_eval_params recover) - (needs_params_val_lambda read-string) - (give_up_eval_params slurp) - (give_up_eval_params get_line) - (give_up_eval_params write_file) - ['empty_env ['env true nil [nil]]] - nil - ] root_env] - - partial_eval (lambda (x) (partial_eval_helper (mark x) root_marked_env [] 0)) -) - (provide partial_eval strip print_strip) -)) diff --git a/working_files/partial_eval_test.csc b/working_files/partial_eval_test.csc deleted file mode 100644 index ec3a29f..0000000 --- a/working_files/partial_eval_test.csc +++ /dev/null @@ -1,35 +0,0 @@ - - -; Going to set some aliases just for this, the scheme version -; commenting out the first let with it's final ) should make this -; legal kraken -(import (chicken process-context)) -(import (chicken port)) -(load "partial_eval.csc") -(import (partial_eval)) -(let* ( - (array list) - (concat append) - (len length) - (idx list-ref) - - ;(array vector) - ;(concat vector-append) ; only in extension vector library! - ;(len vector-length) - ;(idx vector-ref) - - (= equal?) - ) - -(print (array 1 2 3)) -(print (command-line-arguments)) - -(print (call-with-input-string "'(1 2)" (lambda (p) (read p)))) - -(print partial_eval) - - -) - - - diff --git a/working_files/partial_eval_test.kp b/working_files/partial_eval_test.kp deleted file mode 100644 index 5dd1303..0000000 --- a/working_files/partial_eval_test.kp +++ /dev/null @@ -1,176 +0,0 @@ -(with_import "./partial_eval.kp" -(let ( - test-case (lambda (code) (let ( - _ (println "Code: " code) - ; For right now we only support calling partial_eval in such a way that it partial evals against - ; the root env, but this is could and really should be extended. We could at least check if the env we're called with - ; is the root_env, or if what we look up in whatever env is passed in matches something in the root env - partially_evaled (partial_eval code) - _ (println "Partially evaled: " partially_evaled) - _ (print_strip partially_evaled) - stripped (strip partially_evaled) - _ (println "Stripped: " stripped) - fully_evaled (eval stripped root_env) - _ (println "Fully evaled: " fully_evaled) - fully_evaled_called (if (combiner? fully_evaled) (fully_evaled 1337)) - _ (if (combiner? fully_evaled) (println "..and called " fully_evaled_called)) - - outer_eval (eval code root_env) - _ (println " outer-eval " outer_eval) - outer_called (if (combiner? outer_eval) (outer_eval 1337)) - _ (if (combiner? outer_eval) (println "..and outer called " outer_called)) - _ (cond (or (combiner? fully_evaled) (combiner? outer_eval)) - (if (!= fully_evaled_called outer_called) (error (str "called versions unequal for " code " are " fully_evaled_called " vs " outer_called))) - (!= fully_evaled outer_eval) (error (str "partial-eval versions unequal for " code " are " fully_evaled " vs " outer_eval)) - true nil) - _ (println) - ) fully_evaled)) - - simple_add (read-string "(+ 1 2)") - vau_with_add (read-string "(vau (y) (+ 1 2))") - vau_with_add_called (read-string "((vau (y) (+ 1 2)) 4)") - vau_with_passthrough (read-string "((vau (y) y) 4)") - vau_with_no_eval_add (read-string "((vau (y) (+ 13 2 y)) 4)") - vau_with_wrap_add (read-string "((wrap (vau (y) (+ 13 2 y))) (+ 3 4))") - vau_with_add_p (read-string "(vau de (y) (+ (eval y de) (+ 1 2)))") - vau_with_add_p_called (read-string "((vau de (y) ((vau dde (z) (+ 1 (eval z dde))) y)) 17)") - - cond_test (read-string "(cond false 1 false 2 (+ 1 2) 3 true 1337)") - cond_vau_test (read-string "(vau de (x) (cond false 1 false 2 x 3 true 42))") - cond_vau_test2 (read-string "(vau de (x) (cond false 1 false 2 3 x true 42))") - - combiner_test (read-string "(combiner? true)") - combiner_test2 (read-string "(combiner? (vau de (x) x))") - combiner_test3 (read-string "(vau de (x) (combiner? x))") - - symbol_test (read-string "((vau (x) x) a)") - - env_test (read-string "(env? true)") - ; this doesn't partially eval, but it could with a more percise if the marked values were more percise - env_test2 (read-string "(vau de (x) (env? de))") - env_test3 (read-string "(vau de (x) (env? x))") - env_test4 (read-string "((vau de (x) (env? de)) 1)") - - ; let1 test - - ; ((wrap (vau root_env (quote) ((wrap (vau (let1) ;HERE;)) (vau de (s v b) (eval (array (array vau (array s) b) (eval v de)) de))))) (vau (x) x)) - - ;let1_test (read-string "((wrap (vau root_env (quote) ((wrap (vau (let1) (let1 a 12 (+ a 1)))) (vau de (s v b) (eval (array (array vau (array s) b) (eval v de)) de))))) (vau (x) x))") - let1_test (read-string "((wrap (vau (let1) (let1 a 12 (+ a 1)))) (vau de (s v b) (eval (array (array vau (array s) b) (eval v de)) de)))") - let2_test (read-string "((wrap (vau (let1) (let1 a 12 (vau (x) (+ a 1))))) (vau de (s v b) (eval (array (array vau (array s) b) (eval v de)) de)))") - let3_test (read-string "((wrap (vau (let1) (let1 a 12 (wrap (vau (x) (+ x a 1)))))) (vau de (s v b) (eval (array (array vau (array s) b) (eval v de)) de)))") - let4_test (read-string "((wrap (vau (let1) (let1 a 12 (wrap (vau (x) (let1 y (+ a 1) (+ y x a))))))) (vau de (s v b) (eval (array (array vau (array s) b) (eval v de)) de)))") - - let4.3_test (read-string "((wrap (vau (let1) - (let1 a 12 (wrap (vau (x) (let1 y (+ a 1) (+ y x a)))) - ))) (vau de (s v b) (eval (array (array wrap (array vau (array s) b)) v) de)))") - let4.7_test (read-string "((wrap (vau (let1) - (let1 a 12 (wrap (vau (x) (let1 y (+ x a 1) (+ y x a)))) - ))) (vau de (s v b) (eval (array (array wrap (array vau (array s) b)) v) de)))") - - ;!!!!!!!!!!!!!!!!!!!!!!!!!! - ; Which means we need TODO - ;!!!!!!!!!!!!!!!!!!!!!!!!!! - ; 1) Change from is_val as a bool to is_val as an int, and allow negative values in certain situations - ; If we're not careful about the environment it was evaluated in vs current environment, we'll also have to carry around the environment - ; We might be able to call partial_eval with them, but not pass them any further down, esp into anything that might change the scope. - ; This will at least allow us to decend into and partial eval the other parts of the array calling form so we can partial eval inside the body's of lets - ; where the value being assigned has some later? value. - ; 2) Finish up closes_over_var_from_this_env_marked so it's less finicky - ; - ; I think we'll need both for this to actualy work - ; - let5_test (read-string "((wrap (vau (let1) - (let1 a 12 (wrap (vau (x) (let1 y (+ x a 1) (+ y x a)))) - ))) (vau de (s v b) (eval (array (array vau (array s) b) (eval v de)) de)))") - - lambda1_test (read-string "((wrap (vau (let1) - (let1 lambda (vau se (p b) (wrap (eval (array vau p b) se))) - (lambda (x) x) - ))) (vau de (s v b) (eval (array (array vau (array s) b) (eval v de)) de)))") - lambda2_test (read-string "((wrap (vau (let1) - (let1 lambda (vau se (p b) (wrap (eval (array vau p b) se))) - (let1 a 12 - (lambda (x) (+ a x))) - ))) (vau de (s v b) (eval (array (array vau (array s) b) (eval v de)) de)))") - ;!!!! Ditto to let5_test - lambda3_test (read-string "((wrap (vau (let1) - (let1 lambda (vau se (p b) (wrap (eval (array vau p b) se))) - (let1 a 12 - (lambda (x) (let1 b (+ a x) - (+ a x b)))) - ))) (vau de (s v b) (eval (array (array vau (array s) b) (eval v de)) de)))") - - array_test (read-string "(array 1 2 3 4 5)") - vararg_test (read-string "((wrap (vau (a & rest) rest)) 1 2 3 4 5)") - - ;do1_test (read-string "((wrap (vau (let1) - ; (let1 lambda (vau se (p b) (wrap (eval (array vau p b) se))) - ; (let1 do_helper (lambda (recurse s i se) (cond (= i (len s)) nil - ; (= i (- (len s) 1)) (eval (idx s i) se) - ; (eval (idx s i) se) (recurse recurse s (+ i 1) se) - ; true (recurse recurse s (+ i 1) se))) - ; (let1 do (vau se (& s) (do_helper do_helper s 0 se)) - ; (do (println 1 2 3) - ; (println 4 5 6)) - ; ))))) (vau de (s v b) (eval (array (array vau (array s) b) (eval v de)) de)))") - - ;do2_test (read-string "((wrap (vau (let1) - ; (let1 lambda (vau se (p b) (wrap (eval (array vau p b) se))) - ; (let1 do_helper (lambda (recurse s i se) (cond (= i (len s)) nil - ; (= i (- (len s) 1)) (eval (idx s i) se) - ; (eval (idx s i) se) (recurse recurse s (+ i 1) se) - ; true (recurse recurse s (+ i 1) se))) - ; (let1 do (vau se (& s) (do_helper do_helper s 0 se)) - ; (do (println 1 2 3) - ; (println 4 5 6)) - ; ))))) (vau de (s v b) (eval (array (array vau (array s) b) (eval v de)) de)))") - - - ;big_test1 [[vau ['*ARGV*] (read-string (slurp "./prelude.kp"))] ["" "-C" "1339"]] - ;big_test1 [[vau ['*ARGV*] (read-string (slurp "./prelude.kp"))] ["" "-C" "(let (a 17) (vau (x) a))"]] - big_test1 [[vau ['*ARGV*] (read-string (slurp "./prelude.kp"))] ["" "-C" "(let (a 17) a)"]] - ;big_test1 [[vau ['*ARGV*] (read-string (slurp "./prelude.kp"))] []] - - _ (test-case simple_add) - _ (test-case vau_with_add) - _ (test-case vau_with_add_called) - _ (test-case vau_with_passthrough) - _ (test-case vau_with_no_eval_add) - _ (test-case vau_with_wrap_add) - _ (test-case vau_with_add_p) - _ (test-case vau_with_add_p_called) - _ (test-case cond_test) - _ (test-case cond_vau_test) - _ (test-case cond_vau_test2) - _ (test-case combiner_test) - _ (test-case combiner_test2) - _ (test-case combiner_test3) - _ (test-case symbol_test) - _ (test-case env_test) - _ (test-case env_test2) - _ (test-case env_test3) - _ (test-case env_test4) - - _ (test-case let1_test) - _ (test-case let2_test) - _ (test-case let3_test) - _ (test-case let4_test) - _ (test-case let4.3_test) - _ (test-case let4.7_test) - _ (test-case let5_test) - - _ (test-case lambda1_test) - _ (test-case lambda2_test) - _ (test-case lambda3_test) - - _ (test-case array_test) - _ (test-case vararg_test) - - ;_ (test-case do1_test) - ;_ (test-case do2_test) - - ;_ (println "THE BIG SHOW") - ;_ (println big_test1) - ;_ (test-case big_test1) -) nil)) diff --git a/working_files/partial_eval_test_rec.kp b/working_files/partial_eval_test_rec.kp deleted file mode 100644 index 601b356..0000000 --- a/working_files/partial_eval_test_rec.kp +++ /dev/null @@ -1,40 +0,0 @@ -(with_import "./partial_eval.kp" -(let ( - test-case (lambda (source) (let ( - _ (println "Source: " source) - code (read-string source) - _ (println "Code: " code) - partially_evaled (partial_eval code) - _ (println "Partially evaled: " partially_evaled) - _ (print_strip partially_evaled) - stripped (strip partially_evaled) - _ (println "Stripped: " stripped) - fully_evaled (eval stripped root_env) - _ (println "Fully evaled: " fully_evaled) - fully_evaled_called (if (combiner? fully_evaled) (fully_evaled 1337)) - _ (if (combiner? fully_evaled) (println "..and called " fully_evaled_called)) - - outer_eval (eval code root_env) - _ (println " outer-eval " outer_eval) - outer_called (if (combiner? outer_eval) (outer_eval 1337)) - _ (if (combiner? outer_eval) (println "..and outer called " outer_called)) - _ (cond (or (combiner? fully_evaled) (combiner? outer_eval)) - (if (!= fully_evaled_called outer_called) (error (str "called versions unequal for " code " are " fully_evaled_called " vs " outer_called))) - (!= fully_evaled outer_eval) (error (str "partial-eval versions unequal for " code " are " fully_evaled " vs " outer_eval)) - true nil) - _ (println) - ) fully_evaled)) - - ;_ (test-case "(+ 1 2)") - _ (test-case "((wrap (vau (x n) (x x n))) (wrap (vau (self n) (cond (= n 0) 10 true (self self (- n 1))))) 2)") - - ;_ (test-case "((wrap (vau (let1) - ; (let1 lambda (vau se (p b) (wrap (eval (array vau p b) se))) - ; (let1 current-env (vau de () de) - ; (let1 cons (lambda (h t) (concat (array h) t)) - ; (let1 lapply (lambda (f p) (eval (cons (unwrap f) p) (current-env))) - ; (lambda (x) x) - ; )))))) (vau de (s v b) (eval (array (array vau (array s) b) (eval v de)) de)))") - - -) nil)) diff --git a/working_files/prelude.kp b/working_files/prelude.kp deleted file mode 100644 index 2210045..0000000 --- a/working_files/prelude.kp +++ /dev/null @@ -1,297 +0,0 @@ - -((wrap (vau root_env (quote) -((wrap (vau (let1) - -(let1 lambda (vau se (p b) (wrap (eval (array vau p b) se))) - -(let1 do_helper (lambda (recurse s i se) (cond (= i (len s)) nil - (= i (- (len s) 1)) (eval (idx s i) se) - (eval (idx s i) se) (recurse recurse s (+ i 1) se) - true (recurse recurse s (+ i 1) se))) -(let1 do (vau se (& s) (do_helper do_helper s 0 se)) - -(let1 current-env (vau de () de) -(let1 cons (lambda (h t) (concat (array h) t)) -(let1 lapply (lambda (f p) (eval (cons (unwrap f) p) (current-env))) -(let1 vapply (lambda (f p ede) (eval (cons f p) ede)) -(let1 Y (lambda (f) - ((lambda (x) (x x)) - (lambda (x) (f (lambda (& y) (lapply (x x) y)))))) -(let1 vY (lambda (f) - ((lambda (x) (x x)) - (lambda (x) (f (vau de (& y) (vapply (x x) y de)))))) - -(let1 let (vY (lambda (recurse) (vau de (vs b) (cond (= (len vs) 0) (eval b de) - true (vapply let1 (array (idx vs 0) (idx vs 1) (array recurse (slice vs 2 -1) b)) de))))) - -(let ( - print_through (lambda (x) (do (println x) x)) - - lcompose (lambda (g f) (lambda (& args) (lapply g (array (lapply f args))))) - - rec-lambda (vau se (n p b) (eval (array Y (array lambda (array n) (array lambda p b))) se)) - - if (vau de (con than & else) (cond (eval con de) (eval than de) - (> (len else) 0) (eval (idx else 0) de) - true nil)) - - map (lambda (f l) - (let (helper (rec-lambda recurse (f l n i) - (cond (= i (len l)) n - (<= i (- (len l) 4)) (recurse f l (concat n (array - (f (idx l (+ i 0))) - (f (idx l (+ i 1))) - (f (idx l (+ i 2))) - (f (idx l (+ i 3))) - )) (+ i 4)) - true (recurse f l (concat n (array (f (idx l i)))) (+ i 1))))) - (helper f l (array) 0))) - - map_i (lambda (f l) - (let (helper (rec-lambda recurse (f l n i) - (cond (= i (len l)) n - (<= i (- (len l) 4)) (recurse f l (concat n (array - (f (+ i 0) (idx l (+ i 0))) - (f (+ i 1) (idx l (+ i 1))) - (f (+ i 2) (idx l (+ i 2))) - (f (+ i 3) (idx l (+ i 3))) - )) (+ i 4)) - true (recurse f l (concat n (array (f i (idx l i)))) (+ i 1))))) - (helper f l (array) 0))) - - filter_i (lambda (f l) - (let (helper (rec-lambda recurse (f l n i) - (if (= i (len l)) - n - (if (f i (idx l i)) (recurse f l (concat n (array (idx l i))) (+ i 1)) - (recurse f l n (+ i 1)))))) - (helper f l (array) 0))) - filter (lambda (f l) (filter_i (lambda (i x) (f x)) l)) - - not (lambda (x) (if x false true)) - - - ; Huge thanks to Oleg Kiselyov for his fantastic website - ; http://okmij.org/ftp/Computation/fixed-point-combinators.html - Y* (lambda (& l) - ((lambda (u) (u u)) - (lambda (p) - (map (lambda (li) (lambda (& x) (lapply (lapply li (p p)) x))) l)))) - vY* (lambda (& l) - ((lambda (u) (u u)) - (lambda (p) - (map (lambda (li) (vau ide (& x) (vapply (lapply li (p p)) x ide))) l)))) - - let-rec (vau de (name_func body) - (let (names (filter_i (lambda (i x) (= 0 (% i 2))) name_func) - funcs (filter_i (lambda (i x) (= 1 (% i 2))) name_func) - overwrite_name (idx name_func (- (len name_func) 2))) - (eval (array let (concat (array overwrite_name (concat (array Y*) (map (lambda (f) (array lambda names f)) funcs))) - (lapply concat (map_i (lambda (i n) (array n (array idx overwrite_name i))) names))) - body) de))) - let-vrec (vau de (name_func body) - (let (names (filter_i (lambda (i x) (= 0 (% i 2))) name_func) - funcs (filter_i (lambda (i x) (= 1 (% i 2))) name_func) - overwrite_name (idx name_func (- (len name_func) 2))) - (eval (array let (concat (array overwrite_name (concat (array vY*) (map (lambda (f) (array lambda names f)) funcs))) - (lapply concat (map_i (lambda (i n) (array n (array idx overwrite_name i))) names))) - body) de))) - - flat_map (lambda (f l) - (let (helper (rec-lambda recurse (f l n i) - (if (= i (len l)) - n - (recurse f l (concat n (f (idx l i))) (+ i 1))))) - (helper f l (array) 0))) - flat_map_i (lambda (f l) - (let (helper (rec-lambda recurse (f l n i) - (if (= i (len l)) - n - (recurse f l (concat n (f i (idx l i))) (+ i 1))))) - (helper f l (array) 0))) - ; with all this, we make a destrucutring-capable let - let (let ( - destructure_helper (rec-lambda recurse (vs i r) - (cond (= (len vs) i) r - (array? (idx vs i)) (let (bad_sym (str-to-symbol (str (idx vs i))) - new_vs (flat_map_i (lambda (i x) (array x (array idx bad_sym i))) (slice (idx vs i) 1 -1)) - ) - (recurse (concat new_vs (slice vs (+ i 2) -1)) 0 (concat r (array bad_sym (idx vs (+ i 1)))))) - true (recurse vs (+ i 2) (concat r (slice vs i (+ i 2)))) - ))) (vau de (vs b) (vapply let (array (destructure_helper vs 0 (array)) b) de))) - - ; and a destructuring-capable lambda! - only_symbols (rec-lambda recurse (a i) (cond (= i (len a)) true - (symbol? (idx a i)) (recurse a (+ i 1)) - true false)) - lambda (vau se (p b) (if (only_symbols p 0) (vapply lambda (array p b) se) - (let ( - sym_params (map (lambda (param) (if (symbol? param) param - (str-to-symbol (str param)))) p) - body (array let (flat_map_i (lambda (i x) (array (idx p i) x)) sym_params) b) - ) (wrap (eval (array vau sym_params body) se))))) - - ; and rec-lambda - yes it's the same definition again - rec-lambda (vau se (n p b) (eval (array Y (array lambda (array n) (array lambda p b))) se)) - - - is_pair? (lambda (x) (and (array? x) (> (len x) 0))) - - quasiquote (vY (lambda (recurse) (vau de (x) - (cond (is_pair? x) - (cond (and (symbol? (idx x 0)) (= (get-text (idx x 0)) "unquote")) - (eval (idx x 1) de) - true - (cond (and (is_pair? (idx x 0)) (symbol? (idx (idx x 0) 0)) (= (get-text (idx (idx x 0) 0)) "splice-unquote")) - (concat (eval (idx (idx x 0) 1) de) (vapply recurse (array (slice x 1 -1)) de)) - true - (concat (array (vapply recurse (array (idx x 0)) de)) (vapply recurse (array (slice x 1 -1)) de)))) - true x)))) - - repl (vY (lambda (recurse) (wrap (vau de (grammer start_symbol) - (do (recover (println (eval (read-string (get_line "> ") grammer start_symbol) de)) - captured_error (println "repl caught an exception:" captured_error)) - (eval (array recurse (array quote grammer) (array quote start_symbol)) de)))))) - - - string-to-int (lambda (s) (let ( - c0 (idx "0" 0) - c9 (idx "9" 0) - ca (idx "a" 0) - cz (idx "z" 0) - cA (idx "A" 0) - cZ (idx "Z" 0) - helper (rec-lambda recurse (s i radix result) - (if (< i (len s)) - (let (c (idx s i)) - (cond (<= c0 c c9) (recurse s (+ i 1) radix (+ (* radix result) (- (idx s i) c0))) - (<= ca c cz) (recurse s (+ i 1) radix (+ (* radix result) (+ 10 (- (idx s i) ca)))) - (<= cA c cZ) (recurse s (+ i 1) radix (+ (* radix result) (+ 10 (- (idx s i) cA)))) - true (error "Impossible char in string-to-int")) - ) - result - ) - )) - (cond (= (idx s 0) (idx "-" 0)) (- (helper s 1 10 0)) - (and (> (len s) 2) (or (= "0x" (slice s 0 2)) (= "0X" (slice s 0 2)))) (helper s 2 16 0) - true (helper s 0 10 0)) - )) - - unescape-str (lambda (s) (let ( - helper (rec-lambda recurse (s i r) - (cond (>= (+ 1 i) (len s)) r - (= (idx s i) (idx "\\" 0)) (cond (= (+ i 1) (len s)) "BAD ESCAPE AT END" - (= (idx s (+ i 1)) (idx "n" 0)) (recurse s (+ i 2) (str r "\n")) - (= (idx s (+ i 1)) (idx "t" 0)) (recurse s (+ i 2) (str r "\t")) - (= (idx s (+ i 1)) (idx "0" 0)) (recurse s (+ i 2) (str r "\0")) - (= (idx s (+ i 1)) (idx "\\" 0)) (recurse s (+ i 2) (str r "\\")) - (= (idx s (+ i 1)) (idx "\"" 0)) (recurse s (+ i 2) (str r "\"")) - true "BAD ESCAPE IS NORMAL CHAR" - ) - true (recurse s (+ i 1) (str r (slice s i (+ i 1)))) - ) - )) (helper s 1 ""))) - - basic_rules (array - (array (quote WS) (array "( | | -|(;[ -~]* -))+") (lambda (x) nil)) - (array (quote number) (array "(0(x|X)([0-9]|[a-f]|[A-F])+)|(-?[0-9]+)") (lambda (x) (string-to-int x))) - (array (quote string) (array "\"([#-[]| |[]-~]|(\\\\\\\\)|(\\\\n)|(\\\\t)|(\\*)|(\\\\0)| -|[ -!]|(\\\\\"))*\"") (lambda (x) (unescape-str x))) - (array (quote bool_nil_symbol) (array "-|(([a-z]|[A-Z]|_|\\*|/|\\?|\\+|!|=|&|\\||<|>|%|$|\\.)([a-z]|[A-Z]|_|[0-9]|\\*|\\?|\\+|-|!|=|&|\\||<|>|%|$|\\.)*)") (lambda (x) (cond (= "true" x) true - (= "false" x) false - (= "nil" x) nil - true (str-to-symbol x)))) - ) - - provide (vau de (& items) (array let - (flat_map (lambda (item) (array item (array quote (eval item de)))) items))) - scope_let_sans_import_gram (provide - root_env - current-env - lambda - rec-lambda - let - let-rec - let-vrec - do - if - cons - map - map_i - flat_map - flat_map_i - filter_i - filter - not - lapply - vapply - lcompose - Y - vY - Y* - quote - quasiquote - repl - provide - print_through - basic_rules - ) - insert_into_scope_let (lambda (scope_let name item) (array (idx scope_let 0) (concat (idx scope_let 1) (array name (array quote item))))) - - scope_let (let-vrec ( - with_import (vau de (lib_path code) - (let (imported_scope_let (eval (concat - (insert_into_scope_let - (insert_into_scope_let scope_let_sans_import_gram (quote standard_grammar) (gen_standard_grammar)) - (quote with_import) with_import) - (array (read-string (slurp (eval lib_path de)) (gen_standard_grammar) (quote start_symbol)))) root_env)) - (eval (concat imported_scope_let (array code)) de))) - gen_standard_grammar (vau de () (concat basic_rules (array - (array (quote form) (array (quote number)) (lambda (x) x)) - (array (quote form) (array (quote string)) (lambda (x) x)) - (array (quote form) (array (quote bool_nil_symbol)) (lambda (x) x)) - (array (quote form) (array "\\(" (quote WS) * "\\)" ) (lambda (_ _ _) (array))) - (array (quote form) (array "\\(" (quote WS) * (quote form) (array (quote WS) + (quote form)) * (quote WS) * "\\)" ) (lambda (_ _ head tail _ _) (concat (array head) (map (lambda (x) (idx x 1)) tail)))) - - (array (quote form) (array "\\[" (quote WS) * "\\]" ) (lambda (_ _ _) (array array))) - (array (quote form) (array "\\[" (quote WS) * (quote form) (array (quote WS) + (quote form)) * (quote WS) * "\\]" ) (lambda (_ _ head tail _ _) (concat (array array head) (map (lambda (x) (idx x 1)) tail)))) - (array (quote form) (array "'" (quote WS) * (quote form)) (lambda (_ _ x) (array quote x))) - (array (quote form) (array "`" (quote WS) * (quote form)) (lambda (_ _ x) (array quasiquote x))) - (array (quote form) (array "~" (quote WS) * (quote form)) (lambda (_ _ x) (array (quote unquote) x))) - (array (quote form) (array "," (quote WS) * (quote form)) (lambda (_ _ x) (array (quote splice-unquote) x))) - (array (quote start_symbol) (array (quote WS) * (quote form) (quote WS) *) (lambda (_ f _) f)) - (array (quote start_symbol) (array (quote WS) * "#lang" (quote WS) (quote form) (quote WS) (quote form) "([ -~]| -)*") - (lambda (_ _ _ gram _ symbol source) (do (println "gonna do that # yo") (read-string source - (eval (concat - (insert_into_scope_let - (insert_into_scope_let scope_let_sans_import_gram (quote standard_grammar) (gen_standard_grammar)) - (quote with_import) with_import) - (array gram)) root_env) - symbol)))) - ))) - ) - (insert_into_scope_let - (insert_into_scope_let scope_let_sans_import_gram (quote standard_grammar) (gen_standard_grammar)) - (quote with_import) with_import) - ) - standard_grammar (eval (concat scope_let (array (quote standard_grammar))) root_env) - ) - - (do - (println "Welcome to Kraken! Parameters were" *ARGV*) - (cond (and (>= (len *ARGV*) 3) (= "-C" (idx *ARGV* 1))) (eval (concat scope_let (array (read-string (idx *ARGV* 2) standard_grammar (quote start_symbol)))) root_env) - (> (len *ARGV*) 1) (eval (concat scope_let (array (read-string (slurp (idx *ARGV* 1)) standard_grammar (quote start_symbol)))) root_env) - true (eval (concat scope_let (array (array repl (array quote standard_grammar) (array quote (quote start_symbol))))) root_env) - ) - ) -) -)))))))))) ; end of all the let1's - -; impl of let1 -)) (vau de (s v b) (eval (array (array vau (array s) b) (eval v de)) de))) -; impl of quote -)) (vau (x) x)) - diff --git a/working_files/rb.kp b/working_files/rb.kp deleted file mode 100644 index d6615c2..0000000 --- a/working_files/rb.kp +++ /dev/null @@ -1,132 +0,0 @@ - -(with_import "./match.kp" -(let ( - ; This is based on https://www.cs.cornell.edu/courses/cs3110/2020sp/a4/deletion.pdf - ; and the figure references refer to it - ; Insert is taken from the same paper, but is origional to Okasaki, I belive - - ; The tree has been modified slightly to take in a comparison function - ; and override if insert replaces or not to allow use as a set or as a map - - ; I think this is actually pretty cool - instead of having a bunch of seperate ['B] - ; be our leaf node, we use ['B] with all nils. This allows us to not use -B, as - ; both leaf and non-leaf 'BB has the same structure with children! Also, we make - ; sure to use empty itself so we don't make a ton of empties... - empty ['B nil nil nil] - E empty - EE ['BB nil nil nil] - - size (rec-lambda recurse (t) (match t - ~E 0 - [c a x b] (+ 1 (recurse a) (recurse b)))) - - generic-foldl (rec-lambda recurse (f z t) (match t - ~E z - [c a x b] (recurse f (f (recurse f z a) x) b))) - - generic-contains? (rec-lambda recurse (t cmp v found not-found) (match t - ~E (not-found) - [c a x b] (match (cmp v x) '< (recurse a cmp v found not-found) - '= (found x) - '> (recurse b cmp v found not-found)))) - - blacken (lambda (t) (match t - ['R a x b] ['B a x b] - t t)) - balance (lambda (t) (match t - ; figures 1 and 2 - ['B ['R ['R a x b] y c] z d] ['R ['B a x b] y ['B c z d]] - ['B ['R a x ['R b y c]] z d] ['R ['B a x b] y ['B c z d]] - ['B a x ['R ['R b y c] z d]] ['R ['B a x b] y ['B c z d]] - ['B a x ['R b y ['R c z d]]] ['R ['B a x b] y ['B c z d]] - ; figure 8, double black cases - ['BB ['R a x ['R b y c]] z d] ['B ['B a x b] y ['B c z d]] - ['BB a x ['R ['R b y c] z d]] ['B ['B a x b] y ['B c z d]] - ; already balenced - t t)) - generic-insert (lambda (t cmp v replace) (let ( - ins (rec-lambda ins (t) (match t - ~E ['R t v t] - [c a x b] (match (cmp v x) '< (balance [c (ins a) x b]) - '= (if replace [c a v b] - t) - '> (balance [c a x (ins b)])))) - ) (blacken (ins t)))) - - rotate (lambda (t) (match t - ; case 1, fig 6 - ['R ['BB a x b] y ['B c z d]] (balance ['B ['R ['B a x b] y c] z d]) - ['R ['B a x b] y ['BB c z d]] (balance ['B a x ['R b y ['B c z d]]]) - ; case 2, figure 7 - ['B ['BB a x b] y ['B c z d]] (balance ['BB ['R ['B a x b] y c] z d]) - ['B ['B a x b] y ['BB c z d]] (balance ['BB a x ['R b y ['B c z d]]]) - ; case 3, figure 9 - ['B ['BB a w b] x ['R ['B c y d] z e]] ['B (balance ['B ['R ['B a w b] x c] y d]) z e] - ['B ['R a w ['B b x c]] y ['BB d z e]] ['B a w (balance ['B b x ['R c y ['B d z e]]])] - ; fall through - t t)) - - redden (lambda (t) (match t - ['B a x b] (if (and (= 'B (idx a 0)) (= 'B (idx b 0))) ['R a x b] - t) - t t)) - - min_delete (rec-lambda recurse (t) (match t - ~E (error "min_delete empty tree") - ['R ~E x ~E] [x E] - ['B ~E x ~E] [x EE] - ['B ~E x ['R a y b]] [x ['B a y b]] - [c a x b] (let ((v ap) (recurse a)) [v (rotate [c ap x b])]))) - generic-delete (lambda (t cmp v) (let ( - del (rec-lambda del (t v) (match t - ; figure 3 - ~E t - ; figure 4 - ['R ~E x ~E] (match (cmp v x) '= E - _ t) - ['B ['R a x b] y ~E] (match (cmp v y) '< (rotate ['B (del ['R a x b] v) y ~E]) - '= ['B a x b] - '> t) - ; figure 5 - ['B ~E x ~E] (match (cmp v x) '= EE - _ t) - [c a x b] (match (cmp v x) '< (rotate [c (del a v) x b]) - '= (let ([vp bp] (min_delete b)) - (rotate [c a vp bp])) - '> (rotate [c a x (del b v)])))) - ) (del (redden t) v))) - - - set-cmp (lambda (a b) (cond (< a b) '< - (= a b) '= - true '>)) - set-empty empty - set-foldl generic-foldl - set-insert (lambda (t x) (generic-insert t set-cmp x false)) - set-contains? (lambda (t x) (generic-contains? t set-cmp x (lambda (f) true) (lambda () false))) - set-remove (lambda (t x) (generic-delete t set-cmp x)) - - map-cmp (lambda (a b) (let (ak (idx a 0) - bk (idx b 0)) - (cond (< ak bk) '< - (= ak bk) '= - true '>))) - map-empty empty - map-insert (lambda (t k v) (generic-insert t map-cmp [k v] true)) - map-contains-key? (lambda (t k) (generic-contains? t map-cmp [k nil] (lambda (f) true) (lambda () false))) - map-get (lambda (t k) (generic-contains? t map-cmp [k nil] (lambda (f) (idx f 1)) (lambda () (error (str "didn't find key " k " in map " t))))) - map-get-or-default (lambda (t k d) (generic-contains? t map-cmp [k nil] (lambda (f) (idx f 1)) (lambda () d))) - map-get-with-default (lambda (t k d) (generic-contains? t map-cmp [k nil] (lambda (f) (idx f 1)) (lambda () (d)))) - map-remove (lambda (t k) (generic-delete t map-cmp [k nil])) - - ; This could be 2x as efficent by being implmented on generic instead of map, - ; as we wouldn't have to traverse once to find and once to insert - multimap-empty map-empty - multimap-insert (lambda (t k v) (map-insert t k (set-insert (map-get-or-default t k set-empty) v))) - multimap-get (lambda (t k) (map-get-or-default t k set-empty)) -) - (provide set-empty set-foldl set-insert set-contains? set-remove - map-empty map-insert map-contains-key? map-get map-get-or-default map-get-with-default map-remove - multimap-empty multimap-insert multimap-get - size) -)) diff --git a/working_files/rb_profile.txt b/working_files/rb_profile.txt deleted file mode 100644 index 34e0bb3..0000000 --- a/working_files/rb_profile.txt +++ /dev/null @@ -1,29 +0,0 @@ -Samples: 27K of event 'cycles:u', Event count (approx.): 16890753964 -Overhead Command Shared Object Symbol - 33.05% wasmtime jitted-1267703-13.so [.] wasm::wasm-function[16] - 12.64% wasmtime jitted-1267703-12.so [.] wasm::wasm-function[15] - 10.48% wasmtime jitted-1267703-2.so [.] wasm::wasm-function[5] - 10.11% wasmtime jitted-1267703-0.so [.] wasm::wasm-function[3] - 9.95% wasmtime jitted-1267703-528.so [.] wasm::wasm-function[531] - 4.12% wasmtime jitted-1267703-526.so [.] wasm::wasm-function[529] - 4.02% wasmtime jitted-1267703-85.so [.] wasm::wasm-function[88] - 3.01% wasmtime jitted-1267703-39.so [.] wasm::wasm-function[42] - 2.42% wasmtime jitted-1267703-1.so [.] wasm::wasm-function[4] - 1.19% wasmtime jitted-1267703-87.so [.] wasm::wasm-function[90] - 1.18% wasmtime jitted-1267703-37.so [.] wasm::wasm-function[40] - 0.97% wasmtime jitted-1267703-3.so [.] wasm::wasm-function[6] - 0.88% wasmtime jitted-1267703-23.so [.] wasm::wasm-function[26] - 0.83% wasmtime jitted-1267703-134.so [.] wasm::wasm-function[137] - 0.79% wasmtime jitted-1267703-582.so [.] wasm::wasm-function[585] - 0.63% wasmtime jitted-1267703-132.so [.] wasm::wasm-function[135] - 0.49% wasmtime jitted-1267703-99.so [.] wasm::wasm-function[102] - 0.30% wasmtime jitted-1267703-524.so [.] wasm::wasm-function[527] - 0.29% wasmtime jitted-1267703-14.so [.] wasm::wasm-function[17] - 0.28% wasmtime jitted-1267703-133.so [.] wasm::wasm-function[136] - 0.24% wasmtime jitted-1267703-525.so [.] wasm::wasm-function[528] - 0.23% wasmtime jitted-1267703-41.so [.] wasm::wasm-function[44] - 0.17% wasmtime jitted-1267703-581.so [.] wasm::wasm-function[584] - 0.14% wasmtime jitted-1267703-488.so [.] wasm::wasm-function[491] - 0.14% wasmtime jitted-1267703-523.so [.] wasm::wasm-function[526] - 0.12% wasmtime jitted-1267703-131.so [.] wasm::wasm-function[134] - diff --git a/working_files/rb_test.kp b/working_files/rb_test.kp deleted file mode 100644 index a9b5003..0000000 --- a/working_files/rb_test.kp +++ /dev/null @@ -1,50 +0,0 @@ -(with_import "./rb.kp" -(let ( - first set-empty - _ (println first " set-contains? " 1 " ? " (set-contains? first 1) " size " (size first)) - second (set-insert first 1) - _ (println second " set-contains? " 1 " ? " (set-contains? second 1) " size " (size second)) - third (set-insert second 2) - _ (println third " set-contains? " 1 " ? " (set-contains? third 1) " size " (size third)) - _ (println third " set-contains? " 2 " ? " (set-contains? third 2) " size " (size third)) - fourth (set-insert third 3) - _ (println fourth " set-contains? " 1 " ? " (set-contains? fourth 1) " size " (size fourth)) - _ (println fourth " set-contains? " 2 " ? " (set-contains? fourth 2) " size " (size fourth)) - _ (println fourth " set-contains? " 3 " ? " (set-contains? fourth 3) " size " (size fourth)) - _ (println fourth " set-contains? " 4 " ? " (set-contains? fourth 4) " size " (size fourth)) - _ (println fourth " foldl with + " (set-foldl + 0 fourth)) - fifth (set-remove fourth 1) - _ (println fifth " set-contains? " 1 " ? " (set-contains? fifth 1) " size " (size fifth)) - _ (println fifth " set-contains? " 2 " ? " (set-contains? fifth 2) " size " (size fifth)) - _ (println fifth " set-contains? " 3 " ? " (set-contains? fifth 3) " size " (size fifth)) - _ (println fifth " set-contains? " 4 " ? " (set-contains? fifth 4) " size " (size fifth)) - sixth (set-remove fifth 3) - _ (println sixth " set-contains? " 1 " ? " (set-contains? sixth 1) " size " (size sixth)) - _ (println sixth " set-contains? " 2 " ? " (set-contains? sixth 2) " size " (size sixth)) - _ (println sixth " set-contains? " 3 " ? " (set-contains? sixth 3) " size " (size sixth)) - _ (println sixth " set-contains? " 4 " ? " (set-contains? sixth 4) " size " (size sixth)) - seventh (set-remove sixth 2) - _ (println seventh " set-contains? " 1 " ? " (set-contains? seventh 1) " size " (size seventh)) - _ (println seventh " set-contains? " 2 " ? " (set-contains? seventh 2) " size " (size seventh)) - _ (println seventh " set-contains? " 3 " ? " (set-contains? seventh 3) " size " (size seventh)) - _ (println seventh " set-contains? " 4 " ? " (set-contains? seventh 4) " size " (size seventh)) - - first map-empty - _ (println first " map-contains-key? " 1 " ? " (map-contains-key? first 1) " size " (size first)) - second (map-insert first 1 "hello") - _ (println second " map-contains-key? " 1 " ? " (map-contains-key? second 1) " size " (size second)) - _ (println second " map-get " 1 " ? " (map-get second 1) " size " (size second)) - third (map-insert second 1 "goodbye") - _ (println third " map-contains-key? " 1 " ? " (map-contains-key? third 1) " size " (size third)) - _ (println third " map-get " 1 " ? " (map-get third 1) " size " (size third)) - fourth (map-insert third 2 "hmmm") - _ (println fourth " map-contains-key? " 2 " ? " (map-contains-key? fourth 2) " size " (size fourth)) - _ (println fourth " map-get " 2 " ? " (map-get fourth 2) " size " (size fourth)) - _ (println fourth " map-contains-key? " 1 " ? " (map-contains-key? fourth 1) " size " (size fourth)) - _ (println fourth " map-get " 1 " ? " (map-get fourth 1) " size " (size fourth)) - _ (println fourth " map-contains-key? " 3 " ? " (map-contains-key? fourth 3) " size " (size fourth)) - _ (println fourth " map-get-or-default " 3 " 'hi ? " (map-get-or-default fourth 3 'hi) " size " (size fourth)) - _ (println fourth " map-get-with-default " 3 " (lambda () 'bye) ? " (map-get-with-default fourth 3 (lambda () 'bye)) " size " (size fourth)) - fifth (map-remove fourth 2) - _ (println fifth " map-contains-key? " 2 " ? " (map-contains-key? fifth 2) " size " (size fifth)) -) nil)) diff --git a/working_files/sierpinski.kp b/working_files/sierpinski.kp deleted file mode 100644 index e3a9f36..0000000 --- a/working_files/sierpinski.kp +++ /dev/null @@ -1,38 +0,0 @@ -(with_import "./collections.kp" -(let ( - to_bpm (lambda (x) (let ( - rows (len x) - cols (len (idx x 0)) - file "P1" - file (str file "\n" cols " " rows) - file (foldl (lambda (a row) - (str a "\n" (foldl (lambda (a x) - (str a " " x) - ) "" row)) - ) file x) - ) file)) - - stack concat - - side (lambda (a b) (foldl (lambda (a b c) (concat a [(concat b c) ])) - [] a b)) - - padding (rec-lambda recurse (r c) - (cond (and (= 1 r) (= 1 c)) [ [ 0 ] ] - (= 1 c) (let (x (recurse (/ r 2) c)) (stack x x)) - true (let (x (recurse r (/ c 2))) (side x x)))) - - shape [ [ 1 1 ] - [ 1 1 ] ] - - sierpinski (rec-lambda recurse (depth) - (if (= depth 1) shape - (let (s (recurse (/ depth 2)) - p (padding depth (/ depth 2)) - ) (stack (side (side p s) p) - (side s s)))) - ) - - img (to_bpm (sierpinski 64)) -) (write_file "./sierpinski.pbm" img) -)) diff --git a/working_files/smaller_new_kraken_test.kp b/working_files/smaller_new_kraken_test.kp deleted file mode 100644 index e647145..0000000 --- a/working_files/smaller_new_kraken_test.kp +++ /dev/null @@ -1,15 +0,0 @@ -#lang (with_import "./new_kraken.kp" new_kraken_untyped) new_kraken_start_symbol -let my_var = 1337 -println("Hello world!") -println("my_var is:" my_var) -println($"empty string interp") -println($"var string interp: $my_var") -println($"var expr interp: ${+(2 3)}") -fun test() { - let plus_1 = |x| { +(3 1) } - let a = 1 - let b = plus_1(a) - println("some" b) - 1338 -} -println("test is:" test()) diff --git a/working_files/test.csc b/working_files/test.csc deleted file mode 100644 index ec3a29f..0000000 --- a/working_files/test.csc +++ /dev/null @@ -1,35 +0,0 @@ - - -; Going to set some aliases just for this, the scheme version -; commenting out the first let with it's final ) should make this -; legal kraken -(import (chicken process-context)) -(import (chicken port)) -(load "partial_eval.csc") -(import (partial_eval)) -(let* ( - (array list) - (concat append) - (len length) - (idx list-ref) - - ;(array vector) - ;(concat vector-append) ; only in extension vector library! - ;(len vector-length) - ;(idx vector-ref) - - (= equal?) - ) - -(print (array 1 2 3)) -(print (command-line-arguments)) - -(print (call-with-input-string "'(1 2)" (lambda (p) (read p)))) - -(print partial_eval) - - -) - - - diff --git a/working_files/test_parse_in b/working_files/test_parse_in deleted file mode 100644 index 5e0f042..0000000 --- a/working_files/test_parse_in +++ /dev/null @@ -1,3 +0,0 @@ -(false (true "a\"b\tc\\d\nefg" 1336 -1337 1338 0xDEAD 0xBEEF 0b101 0b1111 0b0 -0b101 hmmmm -; a -haaaa drat trueeee 'hehe '(ho ho ho 12 333 "a" true false) () true) true) diff --git a/working_files/test_parse_in_large b/working_files/test_parse_in_large deleted file mode 100644 index 1842327..0000000 --- a/working_files/test_parse_in_large +++ /dev/null @@ -1 +0,0 @@ -(false (true "a\"b\tc\\d\nefg" 1336 -1337 1338 0xDEAD 0xBEEF 0b101 0b1111 0b0 -0b101 hmmmm haaaa drat trueeee 'hehe '(ho ho ho 12 333 "a" true false) () true) true) diff --git a/working_files/test_ystar_vau.kp b/working_files/test_ystar_vau.kp deleted file mode 100644 index 2ece4ae..0000000 --- a/working_files/test_ystar_vau.kp +++ /dev/null @@ -1,6 +0,0 @@ -(let-vrec ( - first (vau de (n) (eval n de)) - second (vau de (n) (eval n de)) - ) - (first (second "Hi!")) -) diff --git a/working_files/types.kp b/working_files/types.kp deleted file mode 100644 index b7e2e48..0000000 --- a/working_files/types.kp +++ /dev/null @@ -1,141 +0,0 @@ -(let ( - ; First quick lookup function, since maps are not built in - lookup (let (lookup-helper (rec-lambda recurse (dict key i) (if (>= i (len dict)) - nil - (if (= key (idx (idx dict i) 0)) - (idx (idx dict i) 1) - (recurse dict key (+ i 1)))))) - (lambda (dict key) (lookup-helper dict key 0))) - - contains (let (contains-helper (rec-lambda recurse (s x i) (cond (= i (len s)) false - (= x (idx s i)) true - true (recurse s x (+ i 1))))) - (lambda (s x) (contains-helper s x 0))) - - applyST (rec-lambda recurse (S t) - (cond - ; I think x should be (idx x 0) - (meta t) (with-meta (recurse (filter (lambda (x) (not (contains (meta t) x))) S) (with-meta t nil)) (meta t)) - (int? t) (or (lookup S t) t) - (array? t) (map (lambda (x) (recurse S x)) t) - true t - )) - applySE (lambda (S env) (map (lambda (x) [(idx x 0) (applyST S (idx x 1))]) env)) - applySS (lambda (S_0 S_1) (let (r (concat S_0 (applySE S_0 S_1)) _ (println "applySS of " S_0 " and " S_1 " is " r)) r)) - fvT (rec-lambda recurse (t) (cond (meta t) (filter (lambda (x) (not (contains (meta t) x))) (recurse (with-meta t nil))) - (int? t) [t] - (array? t) (flat_map recurse t) - true [] - )) - fvE (lambda (env) (flat_map (lambda (x) (fvT (idx x 1))) env)) - varBind (lambda (a b) (cond - (= a b) [] - (contains (fvT b) a) (error "Contains check failed for " a " and " b) - true [ [a b] ])) - mgu (rec-lambda mgu (a b) (let (r (cond - (and (array? a) (array? b) (= (len a) (len b))) ((rec-lambda recurse (S i) (if (= i (len a)) S - (recurse (applySS (mgu (idx a i) (idx b i)) S) (+ 1 i)))) [] 0) - (int? a) (varBind a b) - (int? b) (varBind b a) - (= a b) [] - true (error (str "Cannot unify " a " and " b)) - ) _ (println "mgu of " a " and " b " is " r)) r)) - - generalize (lambda (env t) (do (println "generalize " t " with respect to " env) (let (free_T (fvT t) - free_E (fvE env)) - (with-meta t (filter (lambda (x) (not (contains free_E x))) free_T))))) - instantiate (lambda (sigma idn) (do (println "instantiate " sigma " meta is " (meta sigma)) [(applyST (map_i (lambda (x i) [x (+ i idn)]) (meta sigma)) (with-meta sigma nil)) (+ idn (len (meta sigma)))])) - - execute_type_com (lambda (tc e idn) (tc e idn)) - - simple_type_com (lambda (exp typ) (lambda (env idn) [exp typ [] idn])) - symbol_type_com (lambda (sym) (lambda (env idn) (let ( - (t idn) (instantiate (lookup env sym) idn)) - [sym t [] idn]))) - - call_type_com (lambda (innards) - (lambda (env idn) - (if (= 0 (len innards)) (error "stlc_error: Can't have a 0-length call") - (let ( - (f_e f_t S_0 idn) (execute_type_com (idx innards 0) env idn) - across_params (rec-lambda recurse (env S idn params i out_e out_t) - (if (= i (len params)) [out_e out_t S idn] - (let ( - (p_e p_t S_i idn) (execute_type_com (idx params i) env idn) - ) (recurse (applySE S_i env) (applySS S_i S) idn params (+ 1 i) (concat out_e [p_e]) (concat out_t [p_t]))))) - (p_es p_ts S_ps idn) (across_params (applySE S_0 env) [] idn (slice innards 1 -1) 0 [] []) - (r_t idn) [idn (+ 1 idn)] - S_f (mgu (applyST S_ps f_t) [p_ts r_t]) - _ (println "mgu of " (applyST S_ps f_t) " and " [p_ts r_t] " produces substitution " S_f) - _ (println "For this call: " (cons f_e p_es) " the return type " r_t " transformed by " S_f " is " (applyST S_f r_t)) - ) [(cons f_e p_es) (applyST S_f r_t) (applySS S_f (applySS S_ps S_0)) idn]) - ) - ) - ) - - lambda_type_com (lambda (p t b) - (lambda (env idn) - (let ( - (p_t idn) (if (= nil t) [idn (+ 1 idn)] - [t idn]) - extended_env (cons [p (with-meta p_t [])] env) - (b_e b_t S idn) (execute_type_com b extended_env idn) - f_e [lambda [p] b_e] - f_t [[ (applyST S p_t) ] b_t] - ) [f_e f_t S idn]) - ) - ) - - let_type_com (lambda (x e1 e2) - (lambda (env0 idn) - (let ( - (e1_e e1_t S_0 idn) (execute_type_com e1 env0 idn) - env1 (applySE S_0 env0) - e1_sigma (generalize env1 e1_t) - extended_env (cons [x e1_sigma] env1) - (e2_e e2_t S_1 idn) (execute_type_com e2 extended_env idn) - l_e [[lambda [x] e2_e] e1_e] - l_t e2_t - ) [l_e l_t (applySS S_1 S_0) idn]) - ) - ) - - base_env [ - [ '+ (with-meta [['int 'int] 'int] []) ] - [ '- (with-meta [['int 'int] 'int] []) ] - [ '< (with-meta [['int 'int] 'bool] []) ] - [ '> (with-meta [['int 'int] 'bool] []) ] - [ 'println (with-meta [['str] 'void] []) ] - ] - current_env (vau de () de) - syms (map (lambda (x) (idx x 0)) base_env) - builtin_real_env (eval (concat (vapply provide syms root_env) [[current_env]]) empty_env) - top-level-erase-and-check (lambda (e) (let ( - (e t S idn) (execute_type_com e base_env 0) - _ (println "Type of program is " t " with sub " S) - _ (println "expression code is " e) - ) e)) - - stlc (concat basic_rules [ - - [ 'expr [ 'number ] (lambda (x) (simple_type_com x 'int)) ] - [ 'expr [ 'string ] (lambda (x) (simple_type_com x 'str)) ] - [ 'expr [ 'bool_nil_symbol ] (lambda (x) (cond (= x true) (simple_type_com x 'bool) - (= x false) (simple_type_com x 'bool) - (= x nil) (simple_type_com x 'nil) - true (symbol_type_com x) - ) - ) ] - [ 'expr [ "\\\\" 'WS * 'bool_nil_symbol 'WS * ":" 'WS * 'bool_nil_symbol 'WS * "." 'WS * 'expr ] (lambda (_ _ p _ _ _ t _ _ _ b) (lambda_type_com p t b)) ] - [ 'expr [ "\\\\" 'WS * 'bool_nil_symbol 'WS * "." 'WS * 'expr ] (lambda (_ _ p _ _ _ b) (lambda_type_com p nil b)) ] - - - [ 'call_innards [ 'WS * ] (lambda (_) []) ] - [ 'call_innards [ 'expr [ 'WS 'expr ] * ] (lambda (f r) (cons f (map (lambda (x) (idx x 1)) r))) ] - [ 'expr [ "\\(" 'call_innards "\\)" ] (lambda (_ innards _) (call_type_com innards)) ] - - [ 'stlc_start_symbol [ 'WS * 'expr 'WS * ] (lambda (_ e _) [eval (top-level-erase-and-check e) builtin_real_env]) ] - - ])) - (provide stlc) -) diff --git a/working_files/types_test.kp b/working_files/types_test.kp deleted file mode 100644 index d732da0..0000000 --- a/working_files/types_test.kp +++ /dev/null @@ -1,2 +0,0 @@ -#lang (with_import "./types.kp" stlc) stlc_start_symbol -(\ id . ((id println) (id "woo"))) \ x . x diff --git a/working_files/wasm.kp b/working_files/wasm.kp deleted file mode 100644 index b234a6c..0000000 --- a/working_files/wasm.kp +++ /dev/null @@ -1,384 +0,0 @@ -(with_import "./collections.kp" -(let ( - - ; Vectors and Values - ; Bytes encode themselves - encode_LEB128_helper (rec-lambda recurse (allow_neg x) - (cond (and allow_neg (< x 0x80)) [x] - (< x 0x40) [x] - true (cons (| (& x 0x7F) 0x80) (recurse true (>> x 7)))) - ) - encode_u_LEB128 (lambda (x) (encode_LEB128_helper true x)) - encode_s8_LEB128 (lambda (x) (encode_LEB128_helper (< x 0) (& x 0xFF))) - encode_s32_LEB128 (lambda (x) (encode_LEB128_helper (< x 0) (& x 0xFFFFFFFF))) - encode_s33_LEB128 (lambda (x) (encode_LEB128_helper (< x 0) (& x 0x1FFFFFFFF))) - encode_s64_LEB128 (lambda (x) (encode_LEB128_helper (< x 0) (& x 0xFFFFFFFFFFFFFFFF))) - encode_vector (lambda (enc v) - (concat (encode_u_LEB128 (len v)) (flat_map enc v) ) - ) - encode_floating_point (lambda (x) (error "unimplemented")) - encode_name (lambda (name) - (encode_vector (lambda (x) [x]) name) - ) - encode_bytes encode_name - - ; Types - ; TODO - encode_limits (lambda (x) - (cond (= 1 (len x)) (concat [0x00] (encode_u_LEB128 (idx x 0))) - (= 2 (len x)) (concat [0x01] (encode_u_LEB128 (idx x 0)) (encode_u_LEB128 (idx x 1))) - true (error "trying to encode bad limits")) - ) - encode_number_type (lambda (x) - (cond (= x 'i32) [0x7F] - (= x 'i64) [0x7E] - (= x 'f32) [0x7D] - (= x 'f64) [0x7C] - true (error (str "bad number type " x))) - ) - encode_valtype (lambda (x) - ; we don't handle reference types yet - (encode_number_type x) - ) - encode_result_type (lambda (x) - (encode_vector encode_valtype x) - ) - encode_function_type (lambda (x) - (concat [0x60] (encode_result_type (idx x 0)) - (encode_result_type (idx x 1))) - ) - - ; Modules - encode_type_section (lambda (x) - (let ( - encoded (encode_vector encode_function_type x) - ) (concat [0x01] (encode_u_LEB128 (len encoded)) encoded )) - ) - encode_import (lambda (import) - (let ( - (mod_name name type idx) import - ) (concat (encode_name mod_name) - (encode_name name) - (cond (= type 'func) (concat [0x00] (encode_u_LEB128 idx)) - (= type 'table) (concat [0x01] (error "can't encode table type")) - (= type 'memory) (concat [0x02] (error "can't encode memory type")) - (= type 'global) (concat [0x03] (error "can't encode global type")) - true (error (str "bad import type" type)))) - ) - ) - encode_import_section (lambda (x) - (let ( - encoded (encode_vector encode_import x) - ) (concat [0x02] (encode_u_LEB128 (len encoded)) encoded )) - ) - - encode_ref_type (lambda (t) (cond (= t 'funcref) [0x70] - (= t 'externref) [0x6F] - true (error (str "Bad ref type " t)))) - - encode_table_type (lambda (t) (concat (encode_ref_type (idx t 0)) (encode_limits (idx t 1)))) - - encode_table_section (lambda (x) - (let ( - encoded (encode_vector encode_table_type x) - ) (concat [0x04] (encode_u_LEB128 (len encoded)) encoded )) - ) - encode_memory_section (lambda (x) - (let ( - encoded (encode_vector encode_limits x) - ) (concat [0x05] (encode_u_LEB128 (len encoded)) encoded )) - ) - encode_export (lambda (export) - (let ( - (name type idx) export - ) (concat (encode_name name) - (cond (= type 'func) [0x00] - (= type 'table) [0x01] - (= type 'memory) [0x02] - (= type 'global) [0x03] - true (error "bad export type")) - (encode_u_LEB128 idx) - )) - ) - encode_export_section (lambda (x) - (let ( - encoded (encode_vector encode_export x) - ) (concat [0x07] (encode_u_LEB128 (len encoded)) encoded )) - ) - - encode_start_section (lambda (x) - (cond (= 0 (len x)) [] - (= 1 (len x)) (let (encoded (encode_u_LEB128 (idx x 0))) (concat [0x08] (encode_u_LEB128 (len encoded)) encoded )) - true (error (str "bad lenbgth for start section " (len x) " was " x))) - ) - - encode_function_section (lambda (x) - (let ( ; nil functions are placeholders for improted functions - _ (println "encoding function section " x) - filtered (filter (lambda (i) (!= nil i)) x) - _ (println "post filtered " filtered) - encoded (encode_vector encode_u_LEB128 filtered) - ) (concat [0x03] (encode_u_LEB128 (len encoded)) encoded )) - ) - encode_blocktype (lambda (type) (cond (symbol? type) (encode_valtype type) - (= [] type) [0x40] ; empty type - true (encode_s33_LEB128 typ) - )) - encode_ins (rec-lambda recurse (ins) - (let ( - op (idx ins 0) - ) (cond (= op 'unreachable) [0x00] - (= op 'nop) [0x01] - (= op 'block) (concat [0x02] (encode_blocktype (idx ins 1)) (flat_map recurse (idx ins 2)) [0x0B]) - (= op 'loop) (concat [0x03] (encode_blocktype (idx ins 1)) (flat_map recurse (idx ins 2)) [0x0B]) - (= op 'if) (concat [0x04] (encode_blocktype (idx ins 1)) (flat_map recurse (idx ins 2)) (if (!= 3 (len ins)) (concat [0x05] (flat_map recurse (idx ins 3))) - []) [0x0B]) - (= op 'br) (concat [0x0C] (encode_u_LEB128 (idx ins 1))) - (= op 'br_if) (concat [0x0D] (encode_u_LEB128 (idx ins 1))) - ;... - (= op 'return) [0x0F] - (= op 'call) (concat [0x10] (encode_u_LEB128 (idx ins 1))) - ; call_indirect - ; skipping a bunch - ; Parametric Instructions - (= op 'drop) [0x1A] - ; skip - ; Variable Instructions - (= op 'local.get) (concat [0x20] (encode_u_LEB128 (idx ins 1))) - (= op 'local.set) (concat [0x21] (encode_u_LEB128 (idx ins 1))) - (= op 'local.tee) (concat [0x22] (encode_u_LEB128 (idx ins 1))) - (= op 'global.get) (concat [0x23] (encode_u_LEB128 (idx ins 1))) - (= op 'global.set) (concat [0x24] (encode_u_LEB128 (idx ins 1))) - ; table - ; memory - (= op 'i32.load) (concat [0x28] (encode_u_LEB128 (idx ins 1)) (encode_u_LEB128 (idx ins 2))) - (= op 'i64.load) (concat [0x29] (encode_u_LEB128 (idx ins 1)) (encode_u_LEB128 (idx ins 2))) - (= op 'i32.store) (concat [0x36] (encode_u_LEB128 (idx ins 1)) (encode_u_LEB128 (idx ins 2))) - (= op 'i64.store) (concat [0x37] (encode_u_LEB128 (idx ins 1)) (encode_u_LEB128 (idx ins 2))) - ; Numeric Instructions - (= op 'i32.const) (concat [0x41] (encode_s32_LEB128 (idx ins 1))) - (= op 'i64.const) (concat [0x42] (encode_s64_LEB128 (idx ins 1))) - ; skip - (= op 'i32.add) [0x6A] - )) - ) - encode_expr (lambda (expr) (concat (flat_map encode_ins expr) [0x0B])) - encode_code (lambda (x) - (let ( - (locals body) x - enc_locals (encode_vector (lambda (loc) - (concat (encode_u_LEB128 (idx loc 0)) (encode_valtype (idx loc 1)))) locals) - enc_expr (encode_expr body) - code_bytes (concat enc_locals enc_expr) - ) (concat (encode_u_LEB128 (len code_bytes)) code_bytes)) - ) - encode_code_section (lambda (x) - (let ( - encoded (encode_vector encode_code x) - ) (concat [0x0A] (encode_u_LEB128 (len encoded)) encoded )) - ) - - encode_global_type (lambda (t) (concat (encode_valtype (idx t 0)) (cond (= (idx t 1) 'const) [0x00] - (= (idx t 1) 'mut) [0x01] - true (error (str "bad mutablity " (idx t 1)))))) - encode_global_section (lambda (global_section) - (let ( - encoded (encode_vector (lambda (x) (concat (encode_global_type (idx x 0)) (encode_expr (idx x 1)))) global_section) - ) (concat [0x06] (encode_u_LEB128 (len encoded)) encoded )) - ) - - ; only supporting one type of element section for now, active funcrefs with offset - encode_element (lambda (x) (concat [0x00] (encode_expr (idx x 0)) (encode_vector encode_u_LEB128 (idx x 1)))) - encode_element_section (lambda (x) - (let ( - encoded (encode_vector encode_element x) - ) (concat [0x09] (encode_u_LEB128 (len encoded)) encoded )) - ) - - encode_data (lambda (data) (cond (= 2 (len data)) (concat [0x00] (encode_expr (idx data 0)) (encode_bytes (idx data 1))) - (= 1 (len data)) (concat [0x01] (encode_bytes (idx data 0))) - (= 3 (len data)) (concat [0x02] (encode_u_LEB128 (idx data 0)) (encode_expr (idx data 1)) (encode_bytes (idx data 2))) - true (error (str "bad data" data)))) - encode_data_section (lambda (x) - (let ( - encoded (encode_vector encode_data x) - ) (concat [0x0B] (encode_u_LEB128 (len encoded)) encoded )) - ) - - - wasm_to_binary (lambda (wasm_code) - (let ( - (type_section import_section function_section table_section memory_section global_section export_section start_section element_section code_section data_section) wasm_code - _ (println "type_section" type_section "import_section" import_section "function_section" function_section "memory_section" memory_section "global_section" global_section "export_section" export_section "start_section" start_section "element_section" element_section "code_section" code_section "data_section" data_section) - magic [ 0x00 0x61 0x73 0x6D ] - version [ 0x01 0x00 0x00 0x00 ] - type (encode_type_section type_section) - import (encode_import_section import_section) - function (encode_function_section function_section) - table (encode_table_section table_section) - memory (encode_memory_section memory_section) - global (encode_global_section global_section) - export (encode_export_section export_section) - start (encode_start_section start_section) - elem (encode_element_section element_section) - code (encode_code_section code_section) - data (encode_data_section data_section) - ;data_count (let (body (encode_u_LEB128 (len data_section))) (concat [0x0C] (encode_u_LEB128 (len body)) body)) - data_count [] - ) (concat magic version type import function table memory global export data_count start elem code data)) - ) - - module (lambda (& args) (let ( - helper (rec-lambda recurse (entries i name_dict type import function table memory global export start elem code data) - (if (= i (len entries)) [ type import function table memory global export start elem code data] - (let ( - (n_d t im f ta m g e s elm c d) ((idx entries i) name_dict type import function table memory global export start elem code data) - ) (recurse entries (+ i 1) n_d t im f ta m g e s elm c d)))) - ) (helper args 0 empty_dict [] [] [] [] [] [] [] [] [] [] []))) - - table (vau de (idx_name & limits_type) (lambda (name_dict type import function table memory global export start elem code data) - [ (put name_dict idx_name (len table)) type import function (concat table [[ (idx limits_type -1) (map (lambda (x) (eval x de)) (slice limits_type 0 -2)) ]]) memory global export start elem code data ])) - - memory (vau de (idx_name & limits) (lambda (name_dict type import function table memory global export start elem code data) - [ (put name_dict idx_name (len memory)) type import function table (concat memory [(map (lambda (x) (eval x de)) limits)]) global export start elem code data ])) - - func (vau de (name & inside) (lambda (name_dict type import function table memory global export start elem code data) - (let ( - (params result locals body) ((rec-lambda recurse (i pe re) - (cond (and (= nil pe) (< i (len inside)) (array? (idx inside i)) (< 0 (len (idx inside i))) (= 'param (idx (idx inside i) 0))) - (recurse (+ i 1) pe re) - (and (= nil pe) (= nil re) (< i (len inside)) (array? (idx inside i)) (< 0 (len (idx inside i))) (= 'result (idx (idx inside i) 0))) - ; only one result possible - (recurse (+ i 1) i (+ i 1)) - (and (= nil re) (< i (len inside)) (array? (idx inside i)) (< 0 (len (idx inside i))) (= 'result (idx (idx inside i) 0))) - ; only one result possible - (recurse (+ i 1) pe (+ i 1)) - (and (< i (len inside)) (array? (idx inside i)) (< 0 (len (idx inside i))) (= 'local (idx (idx inside i) 0))) - (recurse (+ i 1) pe re) - true [ (slice inside 0 (or pe 0)) (slice inside (or pe 0) (or re pe 0)) (slice inside (or re pe 0) i) (slice inside i -1) ] - ) - ) 0 nil nil) - result (if (!= 0 (len result)) (idx result 0) - result) - _ (println "params " params " result " result " locals " locals " body " body) - outer_name_dict (put name_dict name (len function)) - (num_params inner_name_dict) (foldl (lambda (a x) [(+ (idx a 0) 1) (put (idx a 1) (idx x 1) (idx a 0))]) [ 0 outer_name_dict ] params) - (num_locals inner_name_dict) (foldl (lambda (a x) [(+ (idx a 0) 1) (put (idx a 1) (idx x 1) (idx a 0))]) [ num_params inner_name_dict ] locals) - _ (println "inner name dict" inner_name_dict) - compressed_locals ((rec-lambda recurse (cur_list cur_typ cur_num i) - (cond (and (= i (len locals)) (= 0 cur_num)) cur_list - (= i (len locals)) (concat cur_list [ [cur_num cur_typ] ]) - (= cur_typ (idx (idx locals i) 2)) (recurse cur_list cur_typ (+ 1 cur_num) (+ 1 i)) - (= nil cur_typ) (recurse cur_list (idx (idx locals i) 2) 1 (+ 1 i)) - true (recurse (concat cur_list [[cur_num cur_typ]]) (idx (idx locals i) 2) 1 (+ 1 i))) - ) [] nil 0 0) - inner_env (add-dict-to-env de (put inner_name_dict 'depth 0)) - our_type [ (map (lambda (x) (idx x 2)) params) (slice result 1 -1) ] - _ (println "about to get our_code") - our_code (flat_map (lambda (x) (let (ins (eval x inner_env)) - (cond (array? ins) ins - true (ins) ; un-evaled function, bare WAT - ))) - body) - _ (println "resulting code " our_code) - ) [ - outer_name_dict - ; type - (concat type [ our_type ]) - ; import - import - ; function - (concat function [ (len function) ]) - ; table - table - ; memory - memory - ; global - global - ; export - export - ; start - start - ; element - elem - ; code - (concat code [ [ compressed_locals our_code ] ]) - ; data - data - ]) - )) - drop (lambda () [['drop]]) - i32.const (lambda (const) [['i32.const const]]) - i64.const (lambda (const) [['i64.const const]]) - local.get (lambda (const) [['local.get const]]) - i32.add (lambda (& flatten) (concat (flat_map (lambda (x) x) flatten) [['i32.add]])) - i32.load (lambda (& flatten) (concat (flat_map (lambda (x) x) flatten) [['i32.load 2 0]])) - i64.load (lambda (& flatten) (concat (flat_map (lambda (x) x) flatten) [['i64.load 3 0]])) - i32.store (lambda (& flatten) (concat (flat_map (lambda (x) x) flatten) [['i32.store 2 0]])) - i64.store (lambda (& flatten) (concat (flat_map (lambda (x) x) flatten) [['i64.store 3 0]])) - flat_eval_ins (lambda (instructions de) (flat_map (lambda (x) (let (ins (eval x de)) (cond (array? ins) ins - true (ins)))) instructions)) - block_like_body (lambda (name de inner) (let ( - new_depth (+ 1 (eval 'depth de)) - inner_env (add-dict-to-env de [[ name [new_depth] ] [ 'depth new_depth ]]) - ) (flat_eval_ins inner inner_env))) - block (vau de (name & inner) [['block [] (block_like_body name de inner)]]) - loop (vau de (name & inner) [['loop [] (block_like_body name de inner)]]) - _if (vau de (name & inner) (let ( - (end_idx else_section) (if (= 'else (idx (idx inner -1) 0)) [ -2 (slice (idx inner -1) 1 -1) ] - [ -1 nil ]) - (end_idx then_section) (if (= 'then (idx (idx inner end_idx) 0)) [ (- end_idx 1) (slice (idx inner end_idx) 1 -1) ] - [ (- end_idx 1) [ (idx inner end_idx) ] ]) - flattened (flat_eval_ins (slice inner 0 end_idx) de) - _ (println "flattened " flattened " then_section " then_section " else_section " else_section) - then_block (block_like_body name de then_section) - else_block (if (!= nil else_section) [(block_like_body name de else_section)] - []) - ) (concat flattened [(concat ['if [] then_block] else_block)]))) - - br (vau de (b) (let (block (eval b de)) (if (int? block) [['br block]] - [['br (eval [- 'depth (idx block 0)] de)]]))) - br_if (vau de (b & flatten) (let (block (eval b de) - block_val (if (int? block) block - (eval [- 'depth (idx block 0)] de)) - rest (flat_eval_ins flatten de) - ) (concat rest [['br_if block_val]]))) - call (lambda (f & flatten) (concat (flat_map (lambda (x) x) flatten) [['call f]])) - import (vau de (mod_name name t_idx_typ) (lambda (name_dict type import function table memory global export start elem code data) (let ( - _ (if (!= 'func (idx t_idx_typ 0)) (error "only supporting importing functions rn")) - (import_type idx_name param_type result_type) t_idx_typ - actual_type_idx (len type) - actual_type [ (slice param_type 1 -1) (slice result_type 1 -1) ] - ) - [ (put name_dict idx_name (len function)) (concat type [actual_type]) (concat import [ [mod_name name import_type actual_type_idx] ]) (concat function [nil]) table memory global export start elem code data ]) - )) - - global (vau de (idx_name global_type expr) (lambda (name_dict type import function table memory global export start elem code data) - [ (put name_dict idx_name (len global)) - type import function table memory - (concat global [[(if (array? global_type) (reverse global_type) [global_type 'const]) (eval expr de) ]]) - export start elem code data ] - )) - - export (vau de (name t_v) (lambda (name_dict type import function table memory global export start elem code data) - [ name_dict type import function table memory global (concat export [ [ name (idx t_v 0) (get-value name_dict (idx t_v 1)) ] ]) start elem code data ] - )) - - start (vau de (name) (lambda (name_dict type import function table memory global export start elem code data) - [ name_dict type import function table memory global export (concat start [(get-value name_dict name)]) elem code data ] - )) - - elem (vau de (offset & entries) (lambda (name_dict type import function table memory global export start elem code data) - [ name_dict type import function table memory global export start (concat elem [[(eval offset de) (map (lambda (x) (get-value name_dict x)) entries)]]) code data ] - )) - - data (lambda (& it) (lambda (name_dict type import function table memory global export start elem code data) - [name_dict type import function table memory global export start elem code (concat data [it])])) -) - (provide wasm_to_binary - module import table memory start elem func global export data - drop i32.const i64.const local.get i32.add - i32.load i64.load - i32.store i64.store - block loop _if br br_if call) -))