+34

devShells.nix

reviewed

··· 1 1 + { mkShell, beam } @ pkgs: { 2 2 + livebook = pkgs.mkShell { 3 3 + packages = with beam.packages.erlang; [ 4 4 + livebook 5 5 + ]; 6 6 + 7 7 + LIVEBOOK_TOKEN_ENABLED = "false"; 8 8 + }; 9 9 + 10 10 + erlang = with beam.packages.erlang; 11 11 + mkShell { 12 12 + packages = [ 13 13 + erlang 14 14 + rebar3 15 15 + erlang-ls 16 16 + ]; 17 17 + }; 18 18 + 19 19 + elixir = with beam.packages.erlang; 20 20 + pkgs.mkShell { 21 21 + packages = [ 22 22 + elixir 23 23 + elixir_ls 24 24 + ]; 25 25 + }; 26 26 + 27 27 + rust = mkShell { 28 28 + packages = [ 29 29 + pkgs.cargo 30 30 + pkgs.rustc 31 31 + pkgs.rust-analyzer 32 32 + ]; 33 33 + }; 34 34 + }

+2

git/.config/git/config

reviewed

··· 36 36 37 37 [pretty] 38 38 simple-oneline = "%C(yellow)%h%C(auto)%d %s [%C(green)%aN <%aE>%C(reset)] (%C(blue)%ar%C(reset))" 39 39 + simple-oneline-sign = "%C(yellow)%h%C(auto)%d %s [%C(green)%aN <%aE>%C(reset)] (%C(blue)%ar%C(reset)) %G?" 39 40 40 41 [merge] 41 42 conflictstyle = diff3 ··· 55 56 [rebase] 56 57 autostash = true 57 58 autosquash = true 59 59 + updateRefs = true 58 60 [fetch] 59 61 prune = true 60 62 [help]

+29

modules/nvim.nix

reviewed

··· 1 1 + { config 2 2 + , pkgs 3 3 + , ... 4 4 + }: 5 5 + let 6 6 + nvim = pkgs.neovim.override { 7 7 + configure = { 8 8 + # Add Fennel to Lua path and require basic implementation 9 9 + customRC = '' 10 10 + lua << EOF 11 11 + package.path = package.path .. ";${pkgs.luajitPackages.fennel}/share/lua/5.1/?.lua" 12 12 + require('basic') 13 13 + EOF 14 14 + ''; 15 15 + packages.vimPackages = with pkgs.vimPlugins; { 16 16 + start = [ 17 17 + packer-nvim 18 18 + nvim-treesitter.withAllGrammars 19 19 + ]; 20 20 + 21 21 + opt = [ ]; 22 22 + }; 23 23 + }; 24 24 + }; 25 25 + in 26 26 + { 27 27 + environment.variables.EDITOR = "nvim"; 28 28 + environment.systemPackages = [ nvim ]; 29 29 + }

+1 -18

nix/environment.nix

reviewed

··· 2 2 , pkgs 3 3 , ... 4 4 }: { 5 5 - documentation.enable = false; 6 6 - 7 5 # List packages installed in system profile. To search by name, run: 8 6 # $ nix search nixpkgs wget 9 7 environment.systemPackages = with pkgs; let ··· 16 14 rg -l -t "$1" "" | entr -p echo /_ 17 15 ''; 18 16 }; 19 19 - nvim = neovim.override { 20 20 - configure = { 21 21 - customRC = '' 22 22 - lua require('basic') 23 23 - ''; 24 24 - packages.vimPackages = with pkgs.vimPlugins; { 25 25 - start = [ 26 26 - packer-nvim 27 27 - nvim-treesitter.withAllGrammars 28 28 - ]; 29 29 - 30 30 - opt = [ ]; 31 31 - }; 32 32 - }; 33 33 - }; 34 17 in 35 18 [ 36 19 # _1password ··· 68 51 neovim-remote 69 52 nix-direnv-flakes 70 53 noti 71 71 - nvim 72 54 pinentry_mac 73 55 # qmk 74 56 ripgrep ··· 87 69 ERL_FLAGS = "-kernel shell_history enabled"; 88 70 }; 89 71 72 72 + programs.nix-index.enable = true; 90 73 programs.zsh.enable = true; 91 74 programs.fish = { 92 75 enable = true;

+3 -1

nix/nix.nix

reviewed

··· 14 14 auto-optimise-store = true 15 15 16 16 keep-outputs = true 17 17 - # keep-derivations = true 17 17 + keep-derivations = true 18 18 19 19 experimental-features = nix-command flakes 20 20 ''; ··· 28 28 "/private/var/tmp" 29 29 "/usr/bin/env" 30 30 ]; 31 31 + 32 32 + nix.settings.allowed-users = [ "@admin" "@builder" "hauleth" ]; 31 33 }

+5

nix/security.nix

reviewed

··· 1 1 + { config 2 2 + , ... 3 3 + }: { 4 4 + security.pam.enableSudoTouchIdAuth = true; 5 5 + }

+2

pkgs/default.nix

reviewed

··· 13 13 livebook = eprev.livebook.override { elixir = efinal.elixir_1_14; }; 14 14 }); 15 15 }; 16 16 + 17 17 + livebook = final.beam.packages.livebook; 16 18 }

+1

utils/dotfiles.nix

reviewed

··· 1 1 + { darwin, self }: {}

+3

vim/.config/nvim/after/queries/erlang/highlights.scm

reviewed

··· 1 1 + ;; extends 2 2 + 3 3 + ("?" (variable) @constant)

+5 -2

vim/.config/nvim/fnl/langclient.fnl

reviewed

··· 7 7 (import-macros {: augroup} :nvim) 8 8 9 9 (fn on_attach [client] 10 10 + (cmd.packadd! :fidget.nvim) 10 11 (logger.inspect client) 11 12 (local capable? 12 13 (fn [capability] 13 14 (. client.server_capabilities capability))) 14 14 - (augroup lsp-diagnostics (on CursorHold "*" (vim.diagnostic.open_float nil))) 15 15 + (augroup lsp-diagnostics 16 16 + (on CursorHold "*" (vim.diagnostic.open_float {:focus false})) 17 17 + (on BufEnter,CursorHold,InsertLeave "*" (vim.lsp.codelens.refresh))) 15 18 (when (capable? :hoverProvider) 16 19 (bmap :n :K #(vim.lsp.buf.hover))) 17 20 (when (capable? :declarationProvider) ··· 29 32 30 33 (vim.diagnostic.config {:virtual_text false}) 31 34 32 32 - (lspconfig.rust_analyzer.setup {:settings {:trace {:server :verbose}}}) 35 35 + (lspconfig.rust_analyzer.setup {:settings {:rust-analyzer {:files {:excludeDirs [".direnv"]}}}}) 33 36 34 37 (lspconfig.elixirls.setup {:cmd [:elixir-ls] 35 38 :settings {:elixirLS {:dialyzerEnabled false}}})

+18 -14

vim/.config/nvim/fnl/nvim/init.fnl

reviewed

··· 1 1 ; (import-macros logger :nvim.logger) 2 2 3 3 - (local {: make-func : maybe-join} (require :nvim.utils)) 3 3 + (fn maybe-join [value] 4 4 + (if (= (type value) :table) 5 5 + (table.concat value ",") 6 6 + value)) 4 7 5 8 (fn filter [t cb] 6 9 (collect [k v (pairs t)] ··· 18 21 (try #(and (not (vim.endswith (: $1 :lower) :<cr>)) (. opts :cr)) 19 22 #(.. $1 :<cr>))) 20 23 rhs) 21 21 - (.. "<cmd>lua " (make-func rhs) "()<CR>"))) 24 24 + rhs)) 22 25 23 26 (fn plug-map? [rhs] 24 27 (and (= (type rhs) :string) (vim.startswith (rhs:lower) :<plug>))) 25 28 26 26 - (fn make-map [cb] 29 29 + (fn make-map [buffer] 27 30 (lambda [modes lhs rhs ?opts] 28 28 - (let [options (vim.tbl_extend :force 29 29 - {:noremap (not (plug-map? rhs)) 30 30 - :selection false 31 31 - :cr true} 32 32 - (or ?opts {})) 33 33 - map-opts (filter options #(not (or (= $1 :selection) (= $1 :cr)))) 34 34 - normalised-rhs (normalise-map rhs options)] 35 31 (when (= modes "") 36 32 (error "At least one mode must be specified")) 37 37 - (each [mode (modes:gmatch ".")] 38 38 - (cb mode lhs normalised-rhs map-opts))))) 33 33 + (let [options (vim.tbl_extend :force 34 34 + {:noremap (not (plug-map? rhs)) 35 35 + :selection false 36 36 + :cr true 37 37 + :buffer buffer} 38 38 + (or ?opts {})) 39 39 + map-opts (filter options #(not (or (= $1 :selection) (= $1 :cr)))) 40 40 + normalised-rhs (normalise-map rhs options) 41 41 + modes (icollect [m (modes:gmatch ".")] m)] 42 42 + (vim.keymap.set modes lhs normalised-rhs map-opts)))) 39 43 40 44 (local api (setmetatable {} 41 45 {:__index (fn [_ key] ··· 73 77 vim.o)) 74 78 75 79 ;; Exports 76 76 - (setmetatable {:map (make-map api.set_keymap) 77 77 - :buf-map (make-map #(api.buf_set_keymap 0 $...)) 80 80 + (setmetatable {:map (make-map false) 81 81 + :buf-map (make-map true) 78 82 : api 79 83 :fun vim.fn 80 84 : opt} {:__index vim})

+1 -1

vim/.config/nvim/fnl/nvim/logger.fnl

reviewed

··· 1 1 (fn inspect [data] 2 2 `(let [v# ,data] 3 3 (when vim.g.debug 4 4 - (print (vim.inspect v#))) 4 4 + (print (fennel.view v#))) 5 5 v#)) 6 6 7 7 {: inspect}

-13

vim/.config/nvim/fnl/nvim/utils.fnl

reviewed

··· 1 1 - (global __nvim_functions__ {}) 2 2 - 3 3 - (fn maybe-join [value] 4 4 - (if (= (type value) :table) 5 5 - (table.concat value ",") 6 6 - value)) 7 7 - 8 8 - (fn make-func [func] 9 9 - (let [idx (+ (length __nvim_functions__) 1)] 10 10 - (tset __nvim_functions__ idx func) 11 11 - (.. "__nvim_functions__[" idx "]"))) 12 12 - 13 13 - {: maybe-join : make-func}

+21 -19

vim/.config/nvim/fnl/picker.fnl

reviewed

··· 1 1 (import-macros {: use} :relude) 2 2 3 3 - (use telescope) 4 4 - (use telescope.themes) 3 3 + (use nvim {: cmd}) 5 4 6 6 - (let [opts {:vimgrep_arguments [:rg 7 7 - :--vimgrep 8 8 - :--smart-case 9 9 - :--hidden 10 10 - :--glob=!.git]}] 11 11 - (telescope.setup {:defaults (themes.get_dropdown opts)})) 5 5 + (fn finder [name] 6 6 + (cmd.packadd! :telescope.nvim) 7 7 + (use telescope) 8 8 + (use telescope.themes) 12 9 13 13 - (telescope.load_extension :fzy_native) 10 10 + (let [opts {:vimgrep_arguments [:rg 11 11 + :--vimgrep 12 12 + :--smart-case 13 13 + :--hidden 14 14 + :--glob=!.git]}] 15 15 + (telescope.setup {:defaults (themes.get_dropdown opts)})) 14 16 15 15 - (fn finder [name] 17 17 + (telescope.load_extension :fzy_native) 16 18 (. (require :telescope.builtin) name)) 17 19 18 18 - (fn find_files [opts] 20 20 + (fn find-files [opts] 19 21 (let [defaults {:find_command [:rg 20 20 - :--hidden 21 21 - :--ignore 22 22 - :--files 23 23 - :--glob=!.git 24 24 - :--glob=!*.lock] 25 25 - :previewer false} 26 26 - options (vim.tbl_extend :force defaults (or opts {}))] 22 22 + :--hidden 23 23 + :--ignore 24 24 + :--files 25 25 + :--glob=!.git 26 26 + :--glob=!*.lock] 27 27 + :previewer false} 28 28 + options (vim.tbl_extend :force defaults (or opts {}))] 27 29 ((finder :find_files) options))) 28 30 29 29 - (setmetatable {: find_files} 31 31 + (setmetatable {: find-files} 30 32 {:__index (fn [_ key] 31 33 (finder key))})

+24 -19

vim/.config/nvim/fnl/plugins.fnl

reviewed

··· 3 3 (use packer) 4 4 5 5 (fn config [cb] 6 6 - (packer.startup (fn [-pkg -pkg-rocks] 6 6 + (packer.startup (fn [-pkg] 7 7 (let [super (fn [f] 8 8 (fn [name ?opts] 9 9 (f (vim.tbl_extend :keep {1 name} 10 10 (or ?opts {}))))) 11 11 - pkg (super -pkg) 12 12 - pkg-rocks (super -pkg-rocks)] 13 13 - (cb pkg pkg-rocks))) 11 11 + pkg (super -pkg)] 12 12 + (cb pkg))) 14 13 {:options {}})) 15 14 16 15 ;; fnlfmt: skip ··· 26 25 (pkg :tpope/vim-eunuch) 27 26 28 27 ; File picker 29 29 - (pkg :nvim-lua/plenary.nvim) 30 30 - (pkg :nvim-telescope/telescope.nvim) 31 31 - (pkg :nvim-telescope/telescope-fzy-native.nvim) 28 28 + (pkg :nvim-telescope/telescope.nvim { 29 29 + :opt true 30 30 + :requires [(pkg :nvim-telescope/telescope-fzy-native.nvim) 31 31 + (pkg :nvim-lua/plenary.nvim)]}) 32 32 33 33 ; Git 34 34 (pkg :tpope/vim-fugitive) 35 35 - (pkg :pwntester/octo.nvim) 35 35 + (pkg :pwntester/octo.nvim 36 36 + {:cmd [:Octo]}) 36 37 37 38 ; Languages 38 38 - (pkg :elixir-editors/vim-elixir) 39 39 + (pkg :elixir-editors/vim-elixir 40 40 + {:ft [:elixir :eex :heex]}) 39 41 ;(pkg :nvim-orgmode/orgmode) 40 42 41 43 ; Language Protocol 42 44 (pkg :neovim/nvim-lspconfig) 43 43 - (pkg :nvim-treesitter/playground) 44 44 - (pkg :j-hui/fidget.nvim) 45 45 + (pkg :nvim-treesitter/playground 46 46 + {:cmd [:TSPlaygroundToggle]}) 47 47 + (pkg :j-hui/fidget.nvim {:opt true}) 45 48 46 49 ; Code manipulation 47 47 - (pkg :AndrewRadev/splitjoin.vim) 50 50 + (pkg :AndrewRadev/splitjoin.vim 51 51 + {:keys [:gS :gJ]}) 48 52 (pkg :hauleth/sad.vim) 49 53 (pkg :tommcdo/vim-exchange) 50 54 ··· 56 60 (pkg :igemnace/vim-makery) 57 61 58 62 ; Windows 59 59 - (pkg :t9md/vim-choosewin) 63 63 + (pkg :t9md/vim-choosewin 64 64 + {:keys ["<plug>(choosewin)"]}) 60 65 61 66 ; Utils 62 67 (pkg :andymass/vim-matchup) 63 68 (pkg :direnv/direnv.vim) 64 64 - (pkg :hauleth/vim-backscratch) 69 69 + (pkg :hauleth/vim-backscratch {:cmd [:Scratch]}) 65 70 (pkg "https://gitlab.com/hauleth/qfx.vim.git") 66 71 (pkg "https://gitlab.com/hauleth/smart.vim.git") 67 72 (pkg :sgur/vim-editorconfig) 68 68 - (pkg :mbbill/undotree) 69 69 - (pkg :tpope/vim-characterize) 70 70 - (pkg :tpope/vim-dadbod) 73 73 + (pkg :mbbill/undotree 74 74 + {:cmd [:UndotreeShow :UndotreeToggle]}) 75 75 + (pkg :tpope/vim-characterize {:keys [:ga]}) 76 76 + (pkg :tpope/vim-dadbod {:cmd [:DB]}) 71 77 (pkg :tpope/vim-repeat) 72 72 - (pkg :tpope/vim-rsi) 73 73 - (pkg :andweeb/presence.nvim))) 78 78 + (pkg :tpope/vim-rsi)))

-5

vim/.config/nvim/fnl/startify.fnl

reviewed

··· 1 1 - (fn setup [opts] 2 2 - (each [k v (pairs opts)] 3 3 - (tset vim.g (.. :startify_ (k:gsub "-" "_")) v))) 4 4 - 5 5 - {: setup}

+1

vim/.config/nvim/ftdetect/custom.vim

reviewed

··· 2 2 au BufRead,BufNewFile rebar.config,rebar.config.script,*.app.src setf erlang 3 3 au BufRead,BufNewFile *.dhall setf dhall 4 4 au BufRead,BufNewFile PULLREQ_EDITMSG setf gitcommit 5 5 + au BufRead,BufNewFile *.livemd setf markdown

+8 -9

vim/.config/nvim/init.fnl

reviewed

··· 2 2 3 3 (use nvim {: map : fun : api : opt : cmd}) 4 4 5 5 + (require :plugins) 6 6 + 5 7 (use picker) 6 8 (import-macros {: augroup : defcommand} :nvim) 7 7 - 8 8 - (require :plugins) 9 9 10 10 (set opt.shell :fish) 11 11 ··· 108 108 :completeopt [:menuone :noselect :noinsert]})) 109 109 110 110 (do ; Clap 111 111 - (map :n :<Space><Space> #(picker.find_files))) 111 111 + (map :n :<Space><Space> #(picker.find-files))) 112 112 113 113 (do ; Frequently used unimpaired mappings 114 114 (let [unimpaired (fn [char left right] ··· 236 236 :replace :cs 237 237 :update_n_lines ""}}) 238 238 (setup :nvim-treesitter.configs 239 239 - {:highlight {:enable true} 239 239 + {:highlight {:enable true 240 240 + ; Currently disable as it do not work as expected 241 241 + :disable [:erlang :make]} 240 242 :matchup {:enable true} 241 241 - :indent {:enable true}}) 242 242 - (setup :fidget {})) ; Presence requires to call `:setup` instead of `.setup 243 243 - (: (require :presence) :setup 244 244 - {:auto_update true :buttons false :blacklist [:Workspace/forte]})) 243 243 + :indent {:enable true}}))) 244 244 + ; (setup :fidget {}))) 245 245 246 246 (defcommand Bd "b#|bd#") 247 247 (defcommand BClean (->> (fun.getbufinfo {:buflisted true}) ··· 270 270 271 271 (defcommand Dash {:nargs "?"} (fun.dash#open q-args)) 272 272 273 273 - (require :startify) 274 273 (require :langclient)

-5831

vim/.config/nvim/lua/fennel.lua

reviewed

··· 1 1 - package.preload["fennel.repl"] = package.preload["fennel.repl"] or function(...) 2 2 - local utils = require("fennel.utils") 3 3 - local parser = require("fennel.parser") 4 4 - local compiler = require("fennel.compiler") 5 5 - local specials = require("fennel.specials") 6 6 - local view = require("fennel.view") 7 7 - local unpack = (table.unpack or _G.unpack) 8 8 - local function default_read_chunk(parser_state) 9 9 - local function _620_() 10 10 - if (0 < parser_state["stack-size"]) then 11 11 - return ".." 12 12 - else 13 13 - return ">> " 14 14 - end 15 15 - end 16 16 - io.write(_620_()) 17 17 - io.flush() 18 18 - local input = io.read() 19 19 - return (input and (input .. "\n")) 20 20 - end 21 21 - local function default_on_values(xs) 22 22 - io.write(table.concat(xs, "\9")) 23 23 - return io.write("\n") 24 24 - end 25 25 - local function default_on_error(errtype, err, lua_source) 26 26 - local function _622_() 27 27 - local _621_ = errtype 28 28 - if (_621_ == "Lua Compile") then 29 29 - return ("Bad code generated - likely a bug with the compiler:\n" .. "--- Generated Lua Start ---\n" .. lua_source .. "--- Generated Lua End ---\n") 30 30 - elseif (_621_ == "Runtime") then 31 31 - return (compiler.traceback(tostring(err), 4) .. "\n") 32 32 - elseif true then 33 33 - local _ = _621_ 34 34 - return ("%s error: %s\n"):format(errtype, tostring(err)) 35 35 - else 36 36 - return nil 37 37 - end 38 38 - end 39 39 - return io.write(_622_()) 40 40 - end 41 41 - local save_source = " ___replLocals___['%s'] = %s" 42 42 - local function splice_save_locals(env, lua_source, scope) 43 43 - local spliced_source = {} 44 44 - local bind = "local %s = ___replLocals___['%s']" 45 45 - for line in lua_source:gmatch("([^\n]+)\n?") do 46 46 - table.insert(spliced_source, line) 47 47 - end 48 48 - for name in pairs(env.___replLocals___) do 49 49 - table.insert(spliced_source, 1, bind:format(name, name)) 50 50 - end 51 51 - if ((1 < #spliced_source) and (spliced_source[#spliced_source]):match("^ *return .*$")) then 52 52 - for _, name in pairs(scope.manglings) do 53 53 - table.insert(spliced_source, #spliced_source, save_source:format(name, name)) 54 54 - end 55 55 - else 56 56 - end 57 57 - return table.concat(spliced_source, "\n") 58 58 - end 59 59 - local function completer(env, scope, text) 60 60 - local max_items = 2000 61 61 - local seen = {} 62 62 - local matches = {} 63 63 - local input_fragment = text:gsub(".*[%s)(]+", "") 64 64 - local stop_looking_3f = false 65 65 - local function add_partials(input, tbl, prefix) 66 66 - local scope_first_3f = ((tbl == env) or (tbl == env.___replLocals___)) 67 67 - local tbl_14_auto = matches 68 68 - local i_15_auto = #tbl_14_auto 69 69 - local function _625_() 70 70 - if scope_first_3f then 71 71 - return scope.manglings 72 72 - else 73 73 - return tbl 74 74 - end 75 75 - end 76 76 - for k, is_mangled in utils.allpairs(_625_()) do 77 77 - if (max_items <= #matches) then break end 78 78 - local val_16_auto 79 79 - do 80 80 - local lookup_k 81 81 - if scope_first_3f then 82 82 - lookup_k = is_mangled 83 83 - else 84 84 - lookup_k = k 85 85 - end 86 86 - if ((type(k) == "string") and (input == k:sub(0, #input)) and not seen[k] and ((":" ~= prefix:sub(-1)) or ("function" == type(tbl[lookup_k])))) then 87 87 - seen[k] = true 88 88 - val_16_auto = (prefix .. k) 89 89 - else 90 90 - val_16_auto = nil 91 91 - end 92 92 - end 93 93 - if (nil ~= val_16_auto) then 94 94 - i_15_auto = (i_15_auto + 1) 95 95 - do end (tbl_14_auto)[i_15_auto] = val_16_auto 96 96 - else 97 97 - end 98 98 - end 99 99 - return tbl_14_auto 100 100 - end 101 101 - local function descend(input, tbl, prefix, add_matches, method_3f) 102 102 - local splitter 103 103 - if method_3f then 104 104 - splitter = "^([^:]+):(.*)" 105 105 - else 106 106 - splitter = "^([^.]+)%.(.*)" 107 107 - end 108 108 - local head, tail = input:match(splitter) 109 109 - local raw_head = (scope.manglings[head] or head) 110 110 - if (type(tbl[raw_head]) == "table") then 111 111 - stop_looking_3f = true 112 112 - if method_3f then 113 113 - return add_partials(tail, tbl[raw_head], (prefix .. head .. ":")) 114 114 - else 115 115 - return add_matches(tail, tbl[raw_head], (prefix .. head)) 116 116 - end 117 117 - else 118 118 - return nil 119 119 - end 120 120 - end 121 121 - local function add_matches(input, tbl, prefix) 122 122 - local prefix0 123 123 - if prefix then 124 124 - prefix0 = (prefix .. ".") 125 125 - else 126 126 - prefix0 = "" 127 127 - end 128 128 - if (not input:find("%.") and input:find(":")) then 129 129 - return descend(input, tbl, prefix0, add_matches, true) 130 130 - elseif not input:find("%.") then 131 131 - return add_partials(input, tbl, prefix0) 132 132 - else 133 133 - return descend(input, tbl, prefix0, add_matches, false) 134 134 - end 135 135 - end 136 136 - for _, source in ipairs({scope.specials, scope.macros, (env.___replLocals___ or {}), env, env._G}) do 137 137 - if stop_looking_3f then break end 138 138 - add_matches(input_fragment, source) 139 139 - end 140 140 - return matches 141 141 - end 142 142 - local commands = {} 143 143 - local function command_3f(input) 144 144 - return input:match("^%s*,") 145 145 - end 146 146 - local function command_docs() 147 147 - local _634_ 148 148 - do 149 149 - local tbl_14_auto = {} 150 150 - local i_15_auto = #tbl_14_auto 151 151 - for name, f in pairs(commands) do 152 152 - local val_16_auto = (" ,%s - %s"):format(name, ((compiler.metadata):get(f, "fnl/docstring") or "undocumented")) 153 153 - if (nil ~= val_16_auto) then 154 154 - i_15_auto = (i_15_auto + 1) 155 155 - do end (tbl_14_auto)[i_15_auto] = val_16_auto 156 156 - else 157 157 - end 158 158 - end 159 159 - _634_ = tbl_14_auto 160 160 - end 161 161 - return table.concat(_634_, "\n") 162 162 - end 163 163 - commands.help = function(_, _0, on_values) 164 164 - return on_values({("Welcome to Fennel.\nThis is the REPL where you can enter code to be evaluated.\nYou can also run these repl commands:\n\n" .. command_docs() .. "\n ,exit - Leave the repl.\n\nUse ,doc something to see descriptions for individual macros and special forms.\n\nFor more information about the language, see https://fennel-lang.org/reference")}) 165 165 - end 166 166 - do end (compiler.metadata):set(commands.help, "fnl/docstring", "Show this message.") 167 167 - local function reload(module_name, env, on_values, on_error) 168 168 - local _636_, _637_ = pcall(specials["load-code"]("return require(...)", env), module_name) 169 169 - if ((_636_ == true) and (nil ~= _637_)) then 170 170 - local old = _637_ 171 171 - local _ 172 172 - package.loaded[module_name] = nil 173 173 - _ = nil 174 174 - local ok, new = pcall(require, module_name) 175 175 - local new0 176 176 - if not ok then 177 177 - on_values({new}) 178 178 - new0 = old 179 179 - else 180 180 - new0 = new 181 181 - end 182 182 - specials["macro-loaded"][module_name] = nil 183 183 - if ((type(old) == "table") and (type(new0) == "table")) then 184 184 - for k, v in pairs(new0) do 185 185 - old[k] = v 186 186 - end 187 187 - for k in pairs(old) do 188 188 - if (nil == (new0)[k]) then 189 189 - old[k] = nil 190 190 - else 191 191 - end 192 192 - end 193 193 - package.loaded[module_name] = old 194 194 - else 195 195 - end 196 196 - return on_values({"ok"}) 197 197 - elseif ((_636_ == false) and (nil ~= _637_)) then 198 198 - local msg = _637_ 199 199 - if (specials["macro-loaded"])[module_name] then 200 200 - specials["macro-loaded"][module_name] = nil 201 201 - return nil 202 202 - else 203 203 - local function _642_() 204 204 - local _641_ = msg:gsub("\n.*", "") 205 205 - return _641_ 206 206 - end 207 207 - return on_error("Runtime", _642_()) 208 208 - end 209 209 - else 210 210 - return nil 211 211 - end 212 212 - end 213 213 - local function run_command(read, on_error, f) 214 214 - local _645_, _646_, _647_ = pcall(read) 215 215 - if ((_645_ == true) and (_646_ == true) and (nil ~= _647_)) then 216 216 - local val = _647_ 217 217 - return f(val) 218 218 - elseif (_645_ == false) then 219 219 - return on_error("Parse", "Couldn't parse input.") 220 220 - else 221 221 - return nil 222 222 - end 223 223 - end 224 224 - commands.reload = function(env, read, on_values, on_error) 225 225 - local function _649_(_241) 226 226 - return reload(tostring(_241), env, on_values, on_error) 227 227 - end 228 228 - return run_command(read, on_error, _649_) 229 229 - end 230 230 - do end (compiler.metadata):set(commands.reload, "fnl/docstring", "Reload the specified module.") 231 231 - commands.reset = function(env, _, on_values) 232 232 - env.___replLocals___ = {} 233 233 - return on_values({"ok"}) 234 234 - end 235 235 - do end (compiler.metadata):set(commands.reset, "fnl/docstring", "Erase all repl-local scope.") 236 236 - commands.complete = function(env, read, on_values, on_error, scope, chars) 237 237 - local function _650_() 238 238 - return on_values(completer(env, scope, string.char(unpack(chars)):gsub(",complete +", ""):sub(1, -2))) 239 239 - end 240 240 - return run_command(read, on_error, _650_) 241 241 - end 242 242 - do end (compiler.metadata):set(commands.complete, "fnl/docstring", "Print all possible completions for a given input symbol.") 243 243 - local function apropos_2a(pattern, tbl, prefix, seen, names) 244 244 - for name, subtbl in pairs(tbl) do 245 245 - if (("string" == type(name)) and (package ~= subtbl)) then 246 246 - local _651_ = type(subtbl) 247 247 - if (_651_ == "function") then 248 248 - if ((prefix .. name)):match(pattern) then 249 249 - table.insert(names, (prefix .. name)) 250 250 - else 251 251 - end 252 252 - elseif (_651_ == "table") then 253 253 - if not seen[subtbl] then 254 254 - local _654_ 255 255 - do 256 256 - local _653_ = seen 257 257 - _653_[subtbl] = true 258 258 - _654_ = _653_ 259 259 - end 260 260 - apropos_2a(pattern, subtbl, (prefix .. name:gsub("%.", "/") .. "."), _654_, names) 261 261 - else 262 262 - end 263 263 - else 264 264 - end 265 265 - else 266 266 - end 267 267 - end 268 268 - return names 269 269 - end 270 270 - local function apropos(pattern) 271 271 - local names = apropos_2a(pattern, package.loaded, "", {}, {}) 272 272 - local tbl_14_auto = {} 273 273 - local i_15_auto = #tbl_14_auto 274 274 - for _, name in ipairs(names) do 275 275 - local val_16_auto = name:gsub("^_G%.", "") 276 276 - if (nil ~= val_16_auto) then 277 277 - i_15_auto = (i_15_auto + 1) 278 278 - do end (tbl_14_auto)[i_15_auto] = val_16_auto 279 279 - else 280 280 - end 281 281 - end 282 282 - return tbl_14_auto 283 283 - end 284 284 - commands.apropos = function(_env, read, on_values, on_error, _scope) 285 285 - local function _659_(_241) 286 286 - return on_values(apropos(tostring(_241))) 287 287 - end 288 288 - return run_command(read, on_error, _659_) 289 289 - end 290 290 - do end (compiler.metadata):set(commands.apropos, "fnl/docstring", "Print all functions matching a pattern in all loaded modules.") 291 291 - local function apropos_follow_path(path) 292 292 - local paths 293 293 - do 294 294 - local tbl_14_auto = {} 295 295 - local i_15_auto = #tbl_14_auto 296 296 - for p in path:gmatch("[^%.]+") do 297 297 - local val_16_auto = p 298 298 - if (nil ~= val_16_auto) then 299 299 - i_15_auto = (i_15_auto + 1) 300 300 - do end (tbl_14_auto)[i_15_auto] = val_16_auto 301 301 - else 302 302 - end 303 303 - end 304 304 - paths = tbl_14_auto 305 305 - end 306 306 - local tgt = package.loaded 307 307 - for _, path0 in ipairs(paths) do 308 308 - if (nil == tgt) then break end 309 309 - local _662_ 310 310 - do 311 311 - local _661_ = path0:gsub("%/", ".") 312 312 - _662_ = _661_ 313 313 - end 314 314 - tgt = tgt[_662_] 315 315 - end 316 316 - return tgt 317 317 - end 318 318 - local function apropos_doc(pattern) 319 319 - local tbl_14_auto = {} 320 320 - local i_15_auto = #tbl_14_auto 321 321 - for _, path in ipairs(apropos(".*")) do 322 322 - local val_16_auto 323 323 - do 324 324 - local tgt = apropos_follow_path(path) 325 325 - if ("function" == type(tgt)) then 326 326 - local _663_ = (compiler.metadata):get(tgt, "fnl/docstring") 327 327 - if (nil ~= _663_) then 328 328 - local docstr = _663_ 329 329 - val_16_auto = (docstr:match(pattern) and path) 330 330 - else 331 331 - val_16_auto = nil 332 332 - end 333 333 - else 334 334 - val_16_auto = nil 335 335 - end 336 336 - end 337 337 - if (nil ~= val_16_auto) then 338 338 - i_15_auto = (i_15_auto + 1) 339 339 - do end (tbl_14_auto)[i_15_auto] = val_16_auto 340 340 - else 341 341 - end 342 342 - end 343 343 - return tbl_14_auto 344 344 - end 345 345 - commands["apropos-doc"] = function(_env, read, on_values, on_error, _scope) 346 346 - local function _667_(_241) 347 347 - return on_values(apropos_doc(tostring(_241))) 348 348 - end 349 349 - return run_command(read, on_error, _667_) 350 350 - end 351 351 - do end (compiler.metadata):set(commands["apropos-doc"], "fnl/docstring", "Print all functions that match the pattern in their docs") 352 352 - local function apropos_show_docs(on_values, pattern) 353 353 - for _, path in ipairs(apropos(pattern)) do 354 354 - local tgt = apropos_follow_path(path) 355 355 - if (("function" == type(tgt)) and (compiler.metadata):get(tgt, "fnl/docstring")) then 356 356 - on_values(specials.doc(tgt, path)) 357 357 - on_values() 358 358 - else 359 359 - end 360 360 - end 361 361 - return nil 362 362 - end 363 363 - commands["apropos-show-docs"] = function(_env, read, on_values, on_error) 364 364 - local function _669_(_241) 365 365 - return apropos_show_docs(on_values, tostring(_241)) 366 366 - end 367 367 - return run_command(read, on_error, _669_) 368 368 - end 369 369 - do end (compiler.metadata):set(commands["apropos-show-docs"], "fnl/docstring", "Print all documentations matching a pattern in function name") 370 370 - local function resolve(identifier, _670_, scope) 371 371 - local _arg_671_ = _670_ 372 372 - local ___replLocals___ = _arg_671_["___replLocals___"] 373 373 - local env = _arg_671_ 374 374 - local e 375 375 - local function _672_(_241, _242) 376 376 - return (___replLocals___[_242] or env[_242]) 377 377 - end 378 378 - e = setmetatable({}, {__index = _672_}) 379 379 - local _673_, _674_ = pcall(compiler["compile-string"], tostring(identifier), {scope = scope}) 380 380 - if ((_673_ == true) and (nil ~= _674_)) then 381 381 - local code = _674_ 382 382 - return specials["load-code"](code, e)() 383 383 - else 384 384 - return nil 385 385 - end 386 386 - end 387 387 - commands.find = function(env, read, on_values, on_error, scope) 388 388 - local function _676_(_241) 389 389 - local _677_ 390 390 - do 391 391 - local _678_ = utils["sym?"](_241) 392 392 - if (nil ~= _678_) then 393 393 - local _679_ = resolve(_678_, env, scope) 394 394 - if (nil ~= _679_) then 395 395 - _677_ = debug.getinfo(_679_) 396 396 - else 397 397 - _677_ = _679_ 398 398 - end 399 399 - else 400 400 - _677_ = _678_ 401 401 - end 402 402 - end 403 403 - if ((_G.type(_677_) == "table") and ((_677_).what == "Lua") and (nil ~= (_677_).source) and (nil ~= (_677_).linedefined) and (nil ~= (_677_).short_src)) then 404 404 - local source = (_677_).source 405 405 - local line = (_677_).linedefined 406 406 - local src = (_677_).short_src 407 407 - local fnlsrc 408 408 - do 409 409 - local t_682_ = compiler.sourcemap 410 410 - if (nil ~= t_682_) then 411 411 - t_682_ = (t_682_)[source] 412 412 - else 413 413 - end 414 414 - if (nil ~= t_682_) then 415 415 - t_682_ = (t_682_)[line] 416 416 - else 417 417 - end 418 418 - if (nil ~= t_682_) then 419 419 - t_682_ = (t_682_)[2] 420 420 - else 421 421 - end 422 422 - fnlsrc = t_682_ 423 423 - end 424 424 - return on_values({string.format("%s:%s", src, (fnlsrc or line))}) 425 425 - elseif (_677_ == nil) then 426 426 - return on_error("Repl", "Unknown value") 427 427 - elseif true then 428 428 - local _ = _677_ 429 429 - return on_error("Repl", "No source info") 430 430 - else 431 431 - return nil 432 432 - end 433 433 - end 434 434 - return run_command(read, on_error, _676_) 435 435 - end 436 436 - do end (compiler.metadata):set(commands.find, "fnl/docstring", "Print the filename and line number for a given function") 437 437 - commands.doc = function(env, read, on_values, on_error, scope) 438 438 - local function _687_(_241) 439 439 - local name = tostring(_241) 440 440 - local path = (utils["multi-sym?"](name) or {name}) 441 441 - local ok_3f, target = nil, nil 442 442 - local function _688_() 443 443 - return (utils["get-in"](scope.specials, path) or utils["get-in"](scope.macros, path) or resolve(name, env, scope)) 444 444 - end 445 445 - ok_3f, target = pcall(_688_) 446 446 - if ok_3f then 447 447 - return on_values({specials.doc(target, name)}) 448 448 - else 449 449 - return on_error("Repl", "Could not resolve value for docstring lookup") 450 450 - end 451 451 - end 452 452 - return run_command(read, on_error, _687_) 453 453 - end 454 454 - do end (compiler.metadata):set(commands.doc, "fnl/docstring", "Print the docstring and arglist for a function, macro, or special form.") 455 455 - commands.compile = function(env, read, on_values, on_error, scope) 456 456 - local function _690_(_241) 457 457 - local allowedGlobals = specials["current-global-names"](env) 458 458 - local ok_3f, result = pcall(compiler.compile, _241, {env = env, scope = scope, allowedGlobals = allowedGlobals}) 459 459 - if ok_3f then 460 460 - return on_values({result}) 461 461 - else 462 462 - return on_error("Repl", ("Error compiling expression: " .. result)) 463 463 - end 464 464 - end 465 465 - return run_command(read, on_error, _690_) 466 466 - end 467 467 - do end (compiler.metadata):set(commands.compile, "fnl/docstring", "compiles the expression into lua and prints the result.") 468 468 - local function load_plugin_commands(plugins) 469 469 - for _, plugin in ipairs((plugins or {})) do 470 470 - for name, f in pairs(plugin) do 471 471 - local _692_ = name:match("^repl%-command%-(.*)") 472 472 - if (nil ~= _692_) then 473 473 - local cmd_name = _692_ 474 474 - commands[cmd_name] = (commands[cmd_name] or f) 475 475 - else 476 476 - end 477 477 - end 478 478 - end 479 479 - return nil 480 480 - end 481 481 - local function run_command_loop(input, read, loop, env, on_values, on_error, scope, chars) 482 482 - local command_name = input:match(",([^%s/]+)") 483 483 - do 484 484 - local _694_ = commands[command_name] 485 485 - if (nil ~= _694_) then 486 486 - local command = _694_ 487 487 - command(env, read, on_values, on_error, scope, chars) 488 488 - elseif true then 489 489 - local _ = _694_ 490 490 - if ("exit" ~= command_name) then 491 491 - on_values({"Unknown command", command_name}) 492 492 - else 493 493 - end 494 494 - else 495 495 - end 496 496 - end 497 497 - if ("exit" ~= command_name) then 498 498 - return loop() 499 499 - else 500 500 - return nil 501 501 - end 502 502 - end 503 503 - local function try_readline_21(opts, ok, readline) 504 504 - if ok then 505 505 - if readline.set_readline_name then 506 506 - readline.set_readline_name("fennel") 507 507 - else 508 508 - end 509 509 - do 510 510 - local rl_opts 511 511 - do 512 512 - local tbl_11_auto = {keeplines = 1000, histfile = ""} 513 513 - for k, v in pairs(readline.set_options({})) do 514 514 - local _699_, _700_ = k, v 515 515 - if ((nil ~= _699_) and (nil ~= _700_)) then 516 516 - local k_12_auto = _699_ 517 517 - local v_13_auto = _700_ 518 518 - tbl_11_auto[k_12_auto] = v_13_auto 519 519 - else 520 520 - end 521 521 - end 522 522 - rl_opts = tbl_11_auto 523 523 - end 524 524 - readline.set_options(rl_opts) 525 525 - end 526 526 - opts.readChunk = function(parser_state) 527 527 - local prompt 528 528 - if (0 < parser_state["stack-size"]) then 529 529 - prompt = ".. " 530 530 - else 531 531 - prompt = ">> " 532 532 - end 533 533 - local str = readline.readline(prompt) 534 534 - if str then 535 535 - return (str .. "\n") 536 536 - else 537 537 - return nil 538 538 - end 539 539 - end 540 540 - local completer0 = nil 541 541 - opts.registerCompleter = function(repl_completer) 542 542 - completer0 = repl_completer 543 543 - return nil 544 544 - end 545 545 - local function repl_completer(text, from, to) 546 546 - if completer0 then 547 547 - readline.set_completion_append_character("") 548 548 - return completer0(text:sub(from, to)) 549 549 - else 550 550 - return {} 551 551 - end 552 552 - end 553 553 - readline.set_complete_function(repl_completer) 554 554 - return readline 555 555 - else 556 556 - return nil 557 557 - end 558 558 - end 559 559 - local function should_use_readline_3f(opts) 560 560 - return (("dumb" ~= os.getenv("TERM")) and not opts.readChunk and not opts.registerCompleter) 561 561 - end 562 562 - local function repl(_3foptions) 563 563 - local old_root_options = utils.root.options 564 564 - local opts = ((_3foptions and utils.copy(_3foptions)) or {}) 565 565 - local readline = (should_use_readline_3f(opts) and try_readline_21(opts, pcall(require, "readline"))) 566 566 - local env = specials["wrap-env"]((opts.env or rawget(_G, "_ENV") or _G)) 567 567 - local save_locals_3f = (opts.saveLocals ~= false) 568 568 - local read_chunk = (opts.readChunk or default_read_chunk) 569 569 - local on_values = (opts.onValues or default_on_values) 570 570 - local on_error = (opts.onError or default_on_error) 571 571 - local pp = (opts.pp or view) 572 572 - local byte_stream, clear_stream = parser.granulate(read_chunk) 573 573 - local chars = {} 574 574 - local read, reset = nil, nil 575 575 - local function _706_(parser_state) 576 576 - local c = byte_stream(parser_state) 577 577 - table.insert(chars, c) 578 578 - return c 579 579 - end 580 580 - read, reset = parser.parser(_706_) 581 581 - opts.env, opts.scope = env, compiler["make-scope"]() 582 582 - opts.useMetadata = (opts.useMetadata ~= false) 583 583 - if (opts.allowedGlobals == nil) then 584 584 - opts.allowedGlobals = specials["current-global-names"](env) 585 585 - else 586 586 - end 587 587 - if opts.registerCompleter then 588 588 - local function _710_() 589 589 - local _708_ = env 590 590 - local _709_ = opts.scope 591 591 - local function _711_(...) 592 592 - return completer(_708_, _709_, ...) 593 593 - end 594 594 - return _711_ 595 595 - end 596 596 - opts.registerCompleter(_710_()) 597 597 - else 598 598 - end 599 599 - load_plugin_commands(opts.plugins) 600 600 - if save_locals_3f then 601 601 - local function newindex(t, k, v) 602 602 - if opts.scope.unmanglings[k] then 603 603 - return rawset(t, k, v) 604 604 - else 605 605 - return nil 606 606 - end 607 607 - end 608 608 - env.___replLocals___ = setmetatable({}, {__newindex = newindex}) 609 609 - else 610 610 - end 611 611 - local function print_values(...) 612 612 - local vals = {...} 613 613 - local out = {} 614 614 - env._, env.__ = vals[1], vals 615 615 - for i = 1, select("#", ...) do 616 616 - table.insert(out, pp(vals[i])) 617 617 - end 618 618 - return on_values(out) 619 619 - end 620 620 - local function loop() 621 621 - for k in pairs(chars) do 622 622 - chars[k] = nil 623 623 - end 624 624 - reset() 625 625 - local ok, not_eof_3f, x = pcall(read) 626 626 - local src_string = string.char(unpack(chars)) 627 627 - if not ok then 628 628 - on_error("Parse", not_eof_3f) 629 629 - clear_stream() 630 630 - return loop() 631 631 - elseif command_3f(src_string) then 632 632 - return run_command_loop(src_string, read, loop, env, on_values, on_error, opts.scope, chars) 633 633 - else 634 634 - if not_eof_3f then 635 635 - do 636 636 - local _715_, _716_ = nil, nil 637 637 - local function _718_() 638 638 - local _717_ = opts 639 639 - _717_["source"] = src_string 640 640 - return _717_ 641 641 - end 642 642 - _715_, _716_ = pcall(compiler.compile, x, _718_()) 643 643 - if ((_715_ == false) and (nil ~= _716_)) then 644 644 - local msg = _716_ 645 645 - clear_stream() 646 646 - on_error("Compile", msg) 647 647 - elseif ((_715_ == true) and (nil ~= _716_)) then 648 648 - local src = _716_ 649 649 - local src0 650 650 - if save_locals_3f then 651 651 - src0 = splice_save_locals(env, src, opts.scope) 652 652 - else 653 653 - src0 = src 654 654 - end 655 655 - local _720_, _721_ = pcall(specials["load-code"], src0, env) 656 656 - if ((_720_ == false) and (nil ~= _721_)) then 657 657 - local msg = _721_ 658 658 - clear_stream() 659 659 - on_error("Lua Compile", msg, src0) 660 660 - elseif (true and (nil ~= _721_)) then 661 661 - local _ = _720_ 662 662 - local chunk = _721_ 663 663 - local function _722_() 664 664 - return print_values(chunk()) 665 665 - end 666 666 - local function _723_() 667 667 - local function _724_(...) 668 668 - return on_error("Runtime", ...) 669 669 - end 670 670 - return _724_ 671 671 - end 672 672 - xpcall(_722_, _723_()) 673 673 - else 674 674 - end 675 675 - else 676 676 - end 677 677 - end 678 678 - utils.root.options = old_root_options 679 679 - return loop() 680 680 - else 681 681 - return nil 682 682 - end 683 683 - end 684 684 - end 685 685 - loop() 686 686 - if readline then 687 687 - return readline.save_history() 688 688 - else 689 689 - return nil 690 690 - end 691 691 - end 692 692 - return repl 693 693 - end 694 694 - package.preload["fennel.specials"] = package.preload["fennel.specials"] or function(...) 695 695 - local utils = require("fennel.utils") 696 696 - local view = require("fennel.view") 697 697 - local parser = require("fennel.parser") 698 698 - local compiler = require("fennel.compiler") 699 699 - local unpack = (table.unpack or _G.unpack) 700 700 - local SPECIALS = compiler.scopes.global.specials 701 701 - local function wrap_env(env) 702 702 - local function _415_(_, key) 703 703 - if utils["string?"](key) then 704 704 - return env[compiler["global-unmangling"](key)] 705 705 - else 706 706 - return env[key] 707 707 - end 708 708 - end 709 709 - local function _417_(_, key, value) 710 710 - if utils["string?"](key) then 711 711 - env[compiler["global-unmangling"](key)] = value 712 712 - return nil 713 713 - else 714 714 - env[key] = value 715 715 - return nil 716 716 - end 717 717 - end 718 718 - local function _419_() 719 719 - local function putenv(k, v) 720 720 - local _420_ 721 721 - if utils["string?"](k) then 722 722 - _420_ = compiler["global-unmangling"](k) 723 723 - else 724 724 - _420_ = k 725 725 - end 726 726 - return _420_, v 727 727 - end 728 728 - return next, utils.kvmap(env, putenv), nil 729 729 - end 730 730 - return setmetatable({}, {__index = _415_, __newindex = _417_, __pairs = _419_}) 731 731 - end 732 732 - local function current_global_names(_3fenv) 733 733 - local mt 734 734 - do 735 735 - local _422_ = getmetatable(_3fenv) 736 736 - if ((_G.type(_422_) == "table") and (nil ~= (_422_).__pairs)) then 737 737 - local mtpairs = (_422_).__pairs 738 738 - local tbl_11_auto = {} 739 739 - for k, v in mtpairs(_3fenv) do 740 740 - local _423_, _424_ = k, v 741 741 - if ((nil ~= _423_) and (nil ~= _424_)) then 742 742 - local k_12_auto = _423_ 743 743 - local v_13_auto = _424_ 744 744 - tbl_11_auto[k_12_auto] = v_13_auto 745 745 - else 746 746 - end 747 747 - end 748 748 - mt = tbl_11_auto 749 749 - elseif (_422_ == nil) then 750 750 - mt = (_3fenv or _G) 751 751 - else 752 752 - mt = nil 753 753 - end 754 754 - end 755 755 - return (mt and utils.kvmap(mt, compiler["global-unmangling"])) 756 756 - end 757 757 - local function load_code(code, _3fenv, _3ffilename) 758 758 - local env = (_3fenv or rawget(_G, "_ENV") or _G) 759 759 - local _427_, _428_ = rawget(_G, "setfenv"), rawget(_G, "loadstring") 760 760 - if ((nil ~= _427_) and (nil ~= _428_)) then 761 761 - local setfenv = _427_ 762 762 - local loadstring = _428_ 763 763 - local f = assert(loadstring(code, _3ffilename)) 764 764 - local _429_ = f 765 765 - setfenv(_429_, env) 766 766 - return _429_ 767 767 - elseif true then 768 768 - local _ = _427_ 769 769 - return assert(load(code, _3ffilename, "t", env)) 770 770 - else 771 771 - return nil 772 772 - end 773 773 - end 774 774 - local function doc_2a(tgt, name) 775 775 - if not tgt then 776 776 - return (name .. " not found") 777 777 - else 778 778 - local docstring = (((compiler.metadata):get(tgt, "fnl/docstring") or "#<undocumented>")):gsub("\n$", ""):gsub("\n", "\n ") 779 779 - local mt = getmetatable(tgt) 780 780 - if ((type(tgt) == "function") or ((type(mt) == "table") and (type(mt.__call) == "function"))) then 781 781 - local arglist = table.concat(((compiler.metadata):get(tgt, "fnl/arglist") or {"#<unknown-arguments>"}), " ") 782 782 - local _431_ 783 783 - if (0 < #arglist) then 784 784 - _431_ = " " 785 785 - else 786 786 - _431_ = "" 787 787 - end 788 788 - return string.format("(%s%s%s)\n %s", name, _431_, arglist, docstring) 789 789 - else 790 790 - return string.format("%s\n %s", name, docstring) 791 791 - end 792 792 - end 793 793 - end 794 794 - local function doc_special(name, arglist, docstring, body_form_3f) 795 795 - compiler.metadata[SPECIALS[name]] = {["fnl/arglist"] = arglist, ["fnl/docstring"] = docstring, ["fnl/body-form?"] = body_form_3f} 796 796 - return nil 797 797 - end 798 798 - local function compile_do(ast, scope, parent, _3fstart) 799 799 - local start = (_3fstart or 2) 800 800 - local len = #ast 801 801 - local sub_scope = compiler["make-scope"](scope) 802 802 - for i = start, len do 803 803 - compiler.compile1(ast[i], sub_scope, parent, {nval = 0}) 804 804 - end 805 805 - return nil 806 806 - end 807 807 - SPECIALS["do"] = function(ast, scope, parent, opts, _3fstart, _3fchunk, _3fsub_scope, _3fpre_syms) 808 808 - local start = (_3fstart or 2) 809 809 - local sub_scope = (_3fsub_scope or compiler["make-scope"](scope)) 810 810 - local chunk = (_3fchunk or {}) 811 811 - local len = #ast 812 812 - local retexprs = {returned = true} 813 813 - local function compile_body(outer_target, outer_tail, outer_retexprs) 814 814 - if (len < start) then 815 815 - compiler.compile1(nil, sub_scope, chunk, {tail = outer_tail, target = outer_target}) 816 816 - else 817 817 - for i = start, len do 818 818 - local subopts = {nval = (((i ~= len) and 0) or opts.nval), tail = (((i == len) and outer_tail) or nil), target = (((i == len) and outer_target) or nil)} 819 819 - local _ = utils["propagate-options"](opts, subopts) 820 820 - local subexprs = compiler.compile1(ast[i], sub_scope, chunk, subopts) 821 821 - if (i ~= len) then 822 822 - compiler["keep-side-effects"](subexprs, parent, nil, ast[i]) 823 823 - else 824 824 - end 825 825 - end 826 826 - end 827 827 - compiler.emit(parent, chunk, ast) 828 828 - compiler.emit(parent, "end", ast) 829 829 - utils.hook("do", ast, sub_scope) 830 830 - return (outer_retexprs or retexprs) 831 831 - end 832 832 - if (opts.target or (opts.nval == 0) or opts.tail) then 833 833 - compiler.emit(parent, "do", ast) 834 834 - return compile_body(opts.target, opts.tail) 835 835 - elseif opts.nval then 836 836 - local syms = {} 837 837 - for i = 1, opts.nval do 838 838 - local s = ((_3fpre_syms and (_3fpre_syms)[i]) or compiler.gensym(scope)) 839 839 - do end (syms)[i] = s 840 840 - retexprs[i] = utils.expr(s, "sym") 841 841 - end 842 842 - local outer_target = table.concat(syms, ", ") 843 843 - compiler.emit(parent, string.format("local %s", outer_target), ast) 844 844 - compiler.emit(parent, "do", ast) 845 845 - return compile_body(outer_target, opts.tail) 846 846 - else 847 847 - local fname = compiler.gensym(scope) 848 848 - local fargs 849 849 - if scope.vararg then 850 850 - fargs = "..." 851 851 - else 852 852 - fargs = "" 853 853 - end 854 854 - compiler.emit(parent, string.format("local function %s(%s)", fname, fargs), ast) 855 855 - return compile_body(nil, true, utils.expr((fname .. "(" .. fargs .. ")"), "statement")) 856 856 - end 857 857 - end 858 858 - doc_special("do", {"..."}, "Evaluate multiple forms; return last value.", true) 859 859 - SPECIALS.values = function(ast, scope, parent) 860 860 - local len = #ast 861 861 - local exprs = {} 862 862 - for i = 2, len do 863 863 - local subexprs = compiler.compile1(ast[i], scope, parent, {nval = ((i ~= len) and 1)}) 864 864 - table.insert(exprs, subexprs[1]) 865 865 - if (i == len) then 866 866 - for j = 2, #subexprs do 867 867 - table.insert(exprs, subexprs[j]) 868 868 - end 869 869 - else 870 870 - end 871 871 - end 872 872 - return exprs 873 873 - end 874 874 - doc_special("values", {"..."}, "Return multiple values from a function. Must be in tail position.") 875 875 - local function deep_tostring(x, key_3f) 876 876 - if utils["list?"](x) then 877 877 - local _440_ 878 878 - do 879 879 - local tbl_14_auto = {} 880 880 - local i_15_auto = #tbl_14_auto 881 881 - for _, v in ipairs(x) do 882 882 - local val_16_auto = deep_tostring(v) 883 883 - if (nil ~= val_16_auto) then 884 884 - i_15_auto = (i_15_auto + 1) 885 885 - do end (tbl_14_auto)[i_15_auto] = val_16_auto 886 886 - else 887 887 - end 888 888 - end 889 889 - _440_ = tbl_14_auto 890 890 - end 891 891 - return ("(" .. table.concat(_440_, " ") .. ")") 892 892 - elseif utils["sequence?"](x) then 893 893 - local _442_ 894 894 - do 895 895 - local tbl_14_auto = {} 896 896 - local i_15_auto = #tbl_14_auto 897 897 - for _, v in ipairs(x) do 898 898 - local val_16_auto = deep_tostring(v) 899 899 - if (nil ~= val_16_auto) then 900 900 - i_15_auto = (i_15_auto + 1) 901 901 - do end (tbl_14_auto)[i_15_auto] = val_16_auto 902 902 - else 903 903 - end 904 904 - end 905 905 - _442_ = tbl_14_auto 906 906 - end 907 907 - return ("[" .. table.concat(_442_, " ") .. "]") 908 908 - elseif utils["table?"](x) then 909 909 - local _444_ 910 910 - do 911 911 - local tbl_14_auto = {} 912 912 - local i_15_auto = #tbl_14_auto 913 913 - for k, v in utils.stablepairs(x) do 914 914 - local val_16_auto = (deep_tostring(k, true) .. " " .. deep_tostring(v)) 915 915 - if (nil ~= val_16_auto) then 916 916 - i_15_auto = (i_15_auto + 1) 917 917 - do end (tbl_14_auto)[i_15_auto] = val_16_auto 918 918 - else 919 919 - end 920 920 - end 921 921 - _444_ = tbl_14_auto 922 922 - end 923 923 - return ("{" .. table.concat(_444_, " ") .. "}") 924 924 - elseif (key_3f and utils["string?"](x) and x:find("^[-%w?\\^_!$%&*+./@:|<=>]+$")) then 925 925 - return (":" .. x) 926 926 - elseif utils["string?"](x) then 927 927 - return string.format("%q", x):gsub("\\\"", "\\\\\""):gsub("\"", "\\\"") 928 928 - else 929 929 - return tostring(x) 930 930 - end 931 931 - end 932 932 - local function set_fn_metadata(arg_list, docstring, parent, fn_name) 933 933 - if utils.root.options.useMetadata then 934 934 - local args 935 935 - local function _447_(_241) 936 936 - return ("\"%s\""):format(deep_tostring(_241)) 937 937 - end 938 938 - args = utils.map(arg_list, _447_) 939 939 - local meta_fields = {"\"fnl/arglist\"", ("{" .. table.concat(args, ", ") .. "}")} 940 940 - if docstring then 941 941 - table.insert(meta_fields, "\"fnl/docstring\"") 942 942 - table.insert(meta_fields, ("\"" .. docstring:gsub("%s+$", ""):gsub("\\", "\\\\"):gsub("\n", "\\n"):gsub("\"", "\\\"") .. "\"")) 943 943 - else 944 944 - end 945 945 - local meta_str = ("require(\"%s\").metadata"):format((utils.root.options.moduleName or "fennel")) 946 946 - return compiler.emit(parent, ("pcall(function() %s:setall(%s, %s) end)"):format(meta_str, fn_name, table.concat(meta_fields, ", "))) 947 947 - else 948 948 - return nil 949 949 - end 950 950 - end 951 951 - local function get_fn_name(ast, scope, fn_name, multi) 952 952 - if (fn_name and (fn_name[1] ~= "nil")) then 953 953 - local _450_ 954 954 - if not multi then 955 955 - _450_ = compiler["declare-local"](fn_name, {}, scope, ast) 956 956 - else 957 957 - _450_ = (compiler["symbol-to-expression"](fn_name, scope))[1] 958 958 - end 959 959 - return _450_, not multi, 3 960 960 - else 961 961 - return nil, true, 2 962 962 - end 963 963 - end 964 964 - local function compile_named_fn(ast, f_scope, f_chunk, parent, index, fn_name, local_3f, arg_name_list, f_metadata) 965 965 - for i = (index + 1), #ast do 966 966 - compiler.compile1(ast[i], f_scope, f_chunk, {nval = (((i ~= #ast) and 0) or nil), tail = (i == #ast)}) 967 967 - end 968 968 - local _453_ 969 969 - if local_3f then 970 970 - _453_ = "local function %s(%s)" 971 971 - else 972 972 - _453_ = "%s = function(%s)" 973 973 - end 974 974 - compiler.emit(parent, string.format(_453_, fn_name, table.concat(arg_name_list, ", ")), ast) 975 975 - compiler.emit(parent, f_chunk, ast) 976 976 - compiler.emit(parent, "end", ast) 977 977 - set_fn_metadata(f_metadata["fnl/arglist"], f_metadata["fnl/docstring"], parent, fn_name) 978 978 - utils.hook("fn", ast, f_scope) 979 979 - return utils.expr(fn_name, "sym") 980 980 - end 981 981 - local function compile_anonymous_fn(ast, f_scope, f_chunk, parent, index, arg_name_list, f_metadata, scope) 982 982 - local fn_name = compiler.gensym(scope) 983 983 - return compile_named_fn(ast, f_scope, f_chunk, parent, index, fn_name, true, arg_name_list, f_metadata) 984 984 - end 985 985 - local function get_function_metadata(ast, arg_list, index) 986 986 - local f_metadata = {["fnl/arglist"] = arg_list} 987 987 - local index_2a = (index + 1) 988 988 - local expr = ast[index_2a] 989 989 - if (utils["string?"](expr) and (index_2a < #ast)) then 990 990 - local _456_ 991 991 - do 992 992 - local _455_ = f_metadata 993 993 - _455_["fnl/docstring"] = expr 994 994 - _456_ = _455_ 995 995 - end 996 996 - return _456_, index_2a 997 997 - elseif (utils["table?"](expr) and (index_2a < #ast)) then 998 998 - local _457_ 999 999 - do 1000 1000 - local tbl_11_auto = f_metadata 1001 1001 - for k, v in pairs(expr) do 1002 1002 - local _458_, _459_ = k, v 1003 1003 - if ((nil ~= _458_) and (nil ~= _459_)) then 1004 1004 - local k_12_auto = _458_ 1005 1005 - local v_13_auto = _459_ 1006 1006 - tbl_11_auto[k_12_auto] = v_13_auto 1007 1007 - else 1008 1008 - end 1009 1009 - end 1010 1010 - _457_ = tbl_11_auto 1011 1011 - end 1012 1012 - return _457_, index_2a 1013 1013 - else 1014 1014 - return f_metadata, index 1015 1015 - end 1016 1016 - end 1017 1017 - SPECIALS.fn = function(ast, scope, parent) 1018 1018 - local f_scope 1019 1019 - do 1020 1020 - local _462_ = compiler["make-scope"](scope) 1021 1021 - do end (_462_)["vararg"] = false 1022 1022 - f_scope = _462_ 1023 1023 - end 1024 1024 - local f_chunk = {} 1025 1025 - local fn_sym = utils["sym?"](ast[2]) 1026 1026 - local multi = (fn_sym and utils["multi-sym?"](fn_sym[1])) 1027 1027 - local fn_name, local_3f, index = get_fn_name(ast, scope, fn_sym, multi) 1028 1028 - local arg_list = compiler.assert(utils["table?"](ast[index]), "expected parameters table", ast) 1029 1029 - compiler.assert((not multi or not multi["multi-sym-method-call"]), ("unexpected multi symbol " .. tostring(fn_name)), fn_sym) 1030 1030 - local function get_arg_name(arg) 1031 1031 - if utils["varg?"](arg) then 1032 1032 - compiler.assert((arg == arg_list[#arg_list]), "expected vararg as last parameter", ast) 1033 1033 - f_scope.vararg = true 1034 1034 - return "..." 1035 1035 - elseif (utils["sym?"](arg) and (tostring(arg) ~= "nil") and not utils["multi-sym?"](tostring(arg))) then 1036 1036 - return compiler["declare-local"](arg, {}, f_scope, ast) 1037 1037 - elseif utils["table?"](arg) then 1038 1038 - local raw = utils.sym(compiler.gensym(scope)) 1039 1039 - local declared = compiler["declare-local"](raw, {}, f_scope, ast) 1040 1040 - compiler.destructure(arg, raw, ast, f_scope, f_chunk, {declaration = true, nomulti = true, symtype = "arg"}) 1041 1041 - return declared 1042 1042 - else 1043 1043 - return compiler.assert(false, ("expected symbol for function parameter: %s"):format(tostring(arg)), ast[index]) 1044 1044 - end 1045 1045 - end 1046 1046 - local arg_name_list = utils.map(arg_list, get_arg_name) 1047 1047 - local f_metadata, index0 = get_function_metadata(ast, arg_list, index) 1048 1048 - if fn_name then 1049 1049 - return compile_named_fn(ast, f_scope, f_chunk, parent, index0, fn_name, local_3f, arg_name_list, f_metadata) 1050 1050 - else 1051 1051 - return compile_anonymous_fn(ast, f_scope, f_chunk, parent, index0, arg_name_list, f_metadata, scope) 1052 1052 - end 1053 1053 - end 1054 1054 - doc_special("fn", {"name?", "args", "docstring?", "..."}, "Function syntax. May optionally include a name and docstring or a metadata table.\nIf a name is provided, the function will be bound in the current scope.\nWhen called with the wrong number of args, excess args will be discarded\nand lacking args will be nil, use lambda for arity-checked functions.", true) 1055 1055 - SPECIALS.lua = function(ast, _, parent) 1056 1056 - compiler.assert(((#ast == 2) or (#ast == 3)), "expected 1 or 2 arguments", ast) 1057 1057 - local _466_ 1058 1058 - do 1059 1059 - local _465_ = utils["sym?"](ast[2]) 1060 1060 - if (nil ~= _465_) then 1061 1061 - _466_ = tostring(_465_) 1062 1062 - else 1063 1063 - _466_ = _465_ 1064 1064 - end 1065 1065 - end 1066 1066 - if ("nil" ~= _466_) then 1067 1067 - table.insert(parent, {ast = ast, leaf = tostring(ast[2])}) 1068 1068 - else 1069 1069 - end 1070 1070 - local _470_ 1071 1071 - do 1072 1072 - local _469_ = utils["sym?"](ast[3]) 1073 1073 - if (nil ~= _469_) then 1074 1074 - _470_ = tostring(_469_) 1075 1075 - else 1076 1076 - _470_ = _469_ 1077 1077 - end 1078 1078 - end 1079 1079 - if ("nil" ~= _470_) then 1080 1080 - return tostring(ast[3]) 1081 1081 - else 1082 1082 - return nil 1083 1083 - end 1084 1084 - end 1085 1085 - local function dot(ast, scope, parent) 1086 1086 - compiler.assert((1 < #ast), "expected table argument", ast) 1087 1087 - local len = #ast 1088 1088 - local _let_473_ = compiler.compile1(ast[2], scope, parent, {nval = 1}) 1089 1089 - local lhs = _let_473_[1] 1090 1090 - if (len == 2) then 1091 1091 - return tostring(lhs) 1092 1092 - else 1093 1093 - local indices = {} 1094 1094 - for i = 3, len do 1095 1095 - local index = ast[i] 1096 1096 - if (utils["string?"](index) and utils["valid-lua-identifier?"](index)) then 1097 1097 - table.insert(indices, ("." .. index)) 1098 1098 - else 1099 1099 - local _let_474_ = compiler.compile1(index, scope, parent, {nval = 1}) 1100 1100 - local index0 = _let_474_[1] 1101 1101 - table.insert(indices, ("[" .. tostring(index0) .. "]")) 1102 1102 - end 1103 1103 - end 1104 1104 - if (tostring(lhs):find("[{\"0-9]") or ("nil" == tostring(lhs))) then 1105 1105 - return ("(" .. tostring(lhs) .. ")" .. table.concat(indices)) 1106 1106 - else 1107 1107 - return (tostring(lhs) .. table.concat(indices)) 1108 1108 - end 1109 1109 - end 1110 1110 - end 1111 1111 - SPECIALS["."] = dot 1112 1112 - doc_special(".", {"tbl", "key1", "..."}, "Look up key1 in tbl table. If more args are provided, do a nested lookup.") 1113 1113 - SPECIALS.global = function(ast, scope, parent) 1114 1114 - compiler.assert((#ast == 3), "expected name and value", ast) 1115 1115 - compiler.destructure(ast[2], ast[3], ast, scope, parent, {forceglobal = true, nomulti = true, symtype = "global"}) 1116 1116 - return nil 1117 1117 - end 1118 1118 - doc_special("global", {"name", "val"}, "Set name as a global with val.") 1119 1119 - SPECIALS.set = function(ast, scope, parent) 1120 1120 - compiler.assert((#ast == 3), "expected name and value", ast) 1121 1121 - compiler.destructure(ast[2], ast[3], ast, scope, parent, {noundef = true, symtype = "set"}) 1122 1122 - return nil 1123 1123 - end 1124 1124 - doc_special("set", {"name", "val"}, "Set a local variable to a new value. Only works on locals using var.") 1125 1125 - local function set_forcibly_21_2a(ast, scope, parent) 1126 1126 - compiler.assert((#ast == 3), "expected name and value", ast) 1127 1127 - compiler.destructure(ast[2], ast[3], ast, scope, parent, {forceset = true, symtype = "set"}) 1128 1128 - return nil 1129 1129 - end 1130 1130 - SPECIALS["set-forcibly!"] = set_forcibly_21_2a 1131 1131 - local function local_2a(ast, scope, parent) 1132 1132 - compiler.assert((#ast == 3), "expected name and value", ast) 1133 1133 - compiler.destructure(ast[2], ast[3], ast, scope, parent, {declaration = true, nomulti = true, symtype = "local"}) 1134 1134 - return nil 1135 1135 - end 1136 1136 - SPECIALS["local"] = local_2a 1137 1137 - doc_special("local", {"name", "val"}, "Introduce new top-level immutable local.") 1138 1138 - SPECIALS.var = function(ast, scope, parent) 1139 1139 - compiler.assert((#ast == 3), "expected name and value", ast) 1140 1140 - compiler.destructure(ast[2], ast[3], ast, scope, parent, {declaration = true, isvar = true, nomulti = true, symtype = "var"}) 1141 1141 - return nil 1142 1142 - end 1143 1143 - doc_special("var", {"name", "val"}, "Introduce new mutable local.") 1144 1144 - local function kv_3f(t) 1145 1145 - local _478_ 1146 1146 - do 1147 1147 - local tbl_14_auto = {} 1148 1148 - local i_15_auto = #tbl_14_auto 1149 1149 - for k in pairs(t) do 1150 1150 - local val_16_auto 1151 1151 - if ("number" ~= type(k)) then 1152 1152 - val_16_auto = k 1153 1153 - else 1154 1154 - val_16_auto = nil 1155 1155 - end 1156 1156 - if (nil ~= val_16_auto) then 1157 1157 - i_15_auto = (i_15_auto + 1) 1158 1158 - do end (tbl_14_auto)[i_15_auto] = val_16_auto 1159 1159 - else 1160 1160 - end 1161 1161 - end 1162 1162 - _478_ = tbl_14_auto 1163 1163 - end 1164 1164 - return (_478_)[1] 1165 1165 - end 1166 1166 - SPECIALS.let = function(ast, scope, parent, opts) 1167 1167 - local bindings = ast[2] 1168 1168 - local pre_syms = {} 1169 1169 - compiler.assert((utils["table?"](bindings) and not kv_3f(bindings)), "expected binding sequence", bindings) 1170 1170 - compiler.assert(((#bindings % 2) == 0), "expected even number of name/value bindings", ast[2]) 1171 1171 - compiler.assert((3 <= #ast), "expected body expression", ast[1]) 1172 1172 - for _ = 1, (opts.nval or 0) do 1173 1173 - table.insert(pre_syms, compiler.gensym(scope)) 1174 1174 - end 1175 1175 - local sub_scope = compiler["make-scope"](scope) 1176 1176 - local sub_chunk = {} 1177 1177 - for i = 1, #bindings, 2 do 1178 1178 - compiler.destructure(bindings[i], bindings[(i + 1)], ast, sub_scope, sub_chunk, {declaration = true, nomulti = true, symtype = "let"}) 1179 1179 - end 1180 1180 - return SPECIALS["do"](ast, scope, parent, opts, 3, sub_chunk, sub_scope, pre_syms) 1181 1181 - end 1182 1182 - doc_special("let", {"[name1 val1 ... nameN valN]", "..."}, "Introduces a new scope in which a given set of local bindings are used.", true) 1183 1183 - local function get_prev_line(parent) 1184 1184 - if ("table" == type(parent)) then 1185 1185 - return get_prev_line((parent.leaf or parent[#parent])) 1186 1186 - else 1187 1187 - return (parent or "") 1188 1188 - end 1189 1189 - end 1190 1190 - local function disambiguate_3f(rootstr, parent) 1191 1191 - local function _483_() 1192 1192 - local _482_ = get_prev_line(parent) 1193 1193 - if (nil ~= _482_) then 1194 1194 - local prev_line = _482_ 1195 1195 - return prev_line:match("%)$") 1196 1196 - else 1197 1197 - return nil 1198 1198 - end 1199 1199 - end 1200 1200 - return (rootstr:match("^{") or _483_()) 1201 1201 - end 1202 1202 - SPECIALS.tset = function(ast, scope, parent) 1203 1203 - compiler.assert((3 < #ast), "expected table, key, and value arguments", ast) 1204 1204 - local root = (compiler.compile1(ast[2], scope, parent, {nval = 1}))[1] 1205 1205 - local keys = {} 1206 1206 - for i = 3, (#ast - 1) do 1207 1207 - local _let_485_ = compiler.compile1(ast[i], scope, parent, {nval = 1}) 1208 1208 - local key = _let_485_[1] 1209 1209 - table.insert(keys, tostring(key)) 1210 1210 - end 1211 1211 - local value = (compiler.compile1(ast[#ast], scope, parent, {nval = 1}))[1] 1212 1212 - local rootstr = tostring(root) 1213 1213 - local fmtstr 1214 1214 - if disambiguate_3f(rootstr, parent) then 1215 1215 - fmtstr = "do end (%s)[%s] = %s" 1216 1216 - else 1217 1217 - fmtstr = "%s[%s] = %s" 1218 1218 - end 1219 1219 - return compiler.emit(parent, fmtstr:format(rootstr, table.concat(keys, "]["), tostring(value)), ast) 1220 1220 - end 1221 1221 - doc_special("tset", {"tbl", "key1", "...", "keyN", "val"}, "Set the value of a table field. Can take additional keys to set\nnested values, but all parents must contain an existing table.") 1222 1222 - local function calculate_target(scope, opts) 1223 1223 - if not (opts.tail or opts.target or opts.nval) then 1224 1224 - return "iife", true, nil 1225 1225 - elseif (opts.nval and (opts.nval ~= 0) and not opts.target) then 1226 1226 - local accum = {} 1227 1227 - local target_exprs = {} 1228 1228 - for i = 1, opts.nval do 1229 1229 - local s = compiler.gensym(scope) 1230 1230 - do end (accum)[i] = s 1231 1231 - target_exprs[i] = utils.expr(s, "sym") 1232 1232 - end 1233 1233 - return "target", opts.tail, table.concat(accum, ", "), target_exprs 1234 1234 - else 1235 1235 - return "none", opts.tail, opts.target 1236 1236 - end 1237 1237 - end 1238 1238 - local function if_2a(ast, scope, parent, opts) 1239 1239 - compiler.assert((2 < #ast), "expected condition and body", ast) 1240 1240 - local do_scope = compiler["make-scope"](scope) 1241 1241 - local branches = {} 1242 1242 - local wrapper, inner_tail, inner_target, target_exprs = calculate_target(scope, opts) 1243 1243 - local body_opts = {nval = opts.nval, tail = inner_tail, target = inner_target} 1244 1244 - local function compile_body(i) 1245 1245 - local chunk = {} 1246 1246 - local cscope = compiler["make-scope"](do_scope) 1247 1247 - compiler["keep-side-effects"](compiler.compile1(ast[i], cscope, chunk, body_opts), chunk, nil, ast[i]) 1248 1248 - return {chunk = chunk, scope = cscope} 1249 1249 - end 1250 1250 - if (1 == (#ast % 2)) then 1251 1251 - table.insert(ast, utils.sym("nil")) 1252 1252 - else 1253 1253 - end 1254 1254 - for i = 2, (#ast - 1), 2 do 1255 1255 - local condchunk = {} 1256 1256 - local res = compiler.compile1(ast[i], do_scope, condchunk, {nval = 1}) 1257 1257 - local cond = res[1] 1258 1258 - local branch = compile_body((i + 1)) 1259 1259 - branch.cond = cond 1260 1260 - branch.condchunk = condchunk 1261 1261 - branch.nested = ((i ~= 2) and (next(condchunk, nil) == nil)) 1262 1262 - table.insert(branches, branch) 1263 1263 - end 1264 1264 - local else_branch = compile_body(#ast) 1265 1265 - local s = compiler.gensym(scope) 1266 1266 - local buffer = {} 1267 1267 - local last_buffer = buffer 1268 1268 - for i = 1, #branches do 1269 1269 - local branch = branches[i] 1270 1270 - local fstr 1271 1271 - if not branch.nested then 1272 1272 - fstr = "if %s then" 1273 1273 - else 1274 1274 - fstr = "elseif %s then" 1275 1275 - end 1276 1276 - local cond = tostring(branch.cond) 1277 1277 - local cond_line = fstr:format(cond) 1278 1278 - if branch.nested then 1279 1279 - compiler.emit(last_buffer, branch.condchunk, ast) 1280 1280 - else 1281 1281 - for _, v in ipairs(branch.condchunk) do 1282 1282 - compiler.emit(last_buffer, v, ast) 1283 1283 - end 1284 1284 - end 1285 1285 - compiler.emit(last_buffer, cond_line, ast) 1286 1286 - compiler.emit(last_buffer, branch.chunk, ast) 1287 1287 - if (i == #branches) then 1288 1288 - compiler.emit(last_buffer, "else", ast) 1289 1289 - compiler.emit(last_buffer, else_branch.chunk, ast) 1290 1290 - compiler.emit(last_buffer, "end", ast) 1291 1291 - elseif not (branches[(i + 1)]).nested then 1292 1292 - local next_buffer = {} 1293 1293 - compiler.emit(last_buffer, "else", ast) 1294 1294 - compiler.emit(last_buffer, next_buffer, ast) 1295 1295 - compiler.emit(last_buffer, "end", ast) 1296 1296 - last_buffer = next_buffer 1297 1297 - else 1298 1298 - end 1299 1299 - end 1300 1300 - if (wrapper == "iife") then 1301 1301 - local iifeargs = ((scope.vararg and "...") or "") 1302 1302 - compiler.emit(parent, ("local function %s(%s)"):format(tostring(s), iifeargs), ast) 1303 1303 - compiler.emit(parent, buffer, ast) 1304 1304 - compiler.emit(parent, "end", ast) 1305 1305 - return utils.expr(("%s(%s)"):format(tostring(s), iifeargs), "statement") 1306 1306 - elseif (wrapper == "none") then 1307 1307 - for i = 1, #buffer do 1308 1308 - compiler.emit(parent, buffer[i], ast) 1309 1309 - end 1310 1310 - return {returned = true} 1311 1311 - else 1312 1312 - compiler.emit(parent, ("local %s"):format(inner_target), ast) 1313 1313 - for i = 1, #buffer do 1314 1314 - compiler.emit(parent, buffer[i], ast) 1315 1315 - end 1316 1316 - return target_exprs 1317 1317 - end 1318 1318 - end 1319 1319 - SPECIALS["if"] = if_2a 1320 1320 - doc_special("if", {"cond1", "body1", "...", "condN", "bodyN"}, "Conditional form.\nTakes any number of condition/body pairs and evaluates the first body where\nthe condition evaluates to truthy. Similar to cond in other lisps.") 1321 1321 - local function remove_until_condition(bindings) 1322 1322 - local last_item = bindings[(#bindings - 1)] 1323 1323 - if ((utils["sym?"](last_item) and (tostring(last_item) == "&until")) or ("until" == last_item)) then 1324 1324 - table.remove(bindings, (#bindings - 1)) 1325 1325 - return table.remove(bindings) 1326 1326 - else 1327 1327 - return nil 1328 1328 - end 1329 1329 - end 1330 1330 - local function compile_until(condition, scope, chunk) 1331 1331 - if condition then 1332 1332 - local _let_494_ = compiler.compile1(condition, scope, chunk, {nval = 1}) 1333 1333 - local condition_lua = _let_494_[1] 1334 1334 - return compiler.emit(chunk, ("if %s then break end"):format(tostring(condition_lua)), utils.expr(condition, "expression")) 1335 1335 - else 1336 1336 - return nil 1337 1337 - end 1338 1338 - end 1339 1339 - SPECIALS.each = function(ast, scope, parent) 1340 1340 - compiler.assert((3 <= #ast), "expected body expression", ast[1]) 1341 1341 - local binding = compiler.assert(utils["table?"](ast[2]), "expected binding table", ast) 1342 1342 - local _ = compiler.assert((2 <= #binding), "expected binding and iterator", binding) 1343 1343 - local until_condition = remove_until_condition(binding) 1344 1344 - local iter = table.remove(binding, #binding) 1345 1345 - local destructures = {} 1346 1346 - local new_manglings = {} 1347 1347 - local sub_scope = compiler["make-scope"](scope) 1348 1348 - local function destructure_binding(v) 1349 1349 - compiler.assert(not utils["string?"](v), ("unexpected iterator clause " .. tostring(v)), binding) 1350 1350 - if utils["sym?"](v) then 1351 1351 - return compiler["declare-local"](v, {}, sub_scope, ast, new_manglings) 1352 1352 - else 1353 1353 - local raw = utils.sym(compiler.gensym(sub_scope)) 1354 1354 - do end (destructures)[raw] = v 1355 1355 - return compiler["declare-local"](raw, {}, sub_scope, ast) 1356 1356 - end 1357 1357 - end 1358 1358 - local bind_vars = utils.map(binding, destructure_binding) 1359 1359 - local vals = compiler.compile1(iter, scope, parent) 1360 1360 - local val_names = utils.map(vals, tostring) 1361 1361 - local chunk = {} 1362 1362 - compiler.emit(parent, ("for %s in %s do"):format(table.concat(bind_vars, ", "), table.concat(val_names, ", ")), ast) 1363 1363 - for raw, args in utils.stablepairs(destructures) do 1364 1364 - compiler.destructure(args, raw, ast, sub_scope, chunk, {declaration = true, nomulti = true, symtype = "each"}) 1365 1365 - end 1366 1366 - compiler["apply-manglings"](sub_scope, new_manglings, ast) 1367 1367 - compile_until(until_condition, sub_scope, chunk) 1368 1368 - compile_do(ast, sub_scope, chunk, 3) 1369 1369 - compiler.emit(parent, chunk, ast) 1370 1370 - return compiler.emit(parent, "end", ast) 1371 1371 - end 1372 1372 - doc_special("each", {"[key value (iterator)]", "..."}, "Runs the body once for each set of values provided by the given iterator.\nMost commonly used with ipairs for sequential tables or pairs for undefined\norder, but can be used with any iterator.", true) 1373 1373 - local function while_2a(ast, scope, parent) 1374 1374 - local len1 = #parent 1375 1375 - local condition = (compiler.compile1(ast[2], scope, parent, {nval = 1}))[1] 1376 1376 - local len2 = #parent 1377 1377 - local sub_chunk = {} 1378 1378 - if (len1 ~= len2) then 1379 1379 - for i = (len1 + 1), len2 do 1380 1380 - table.insert(sub_chunk, parent[i]) 1381 1381 - do end (parent)[i] = nil 1382 1382 - end 1383 1383 - compiler.emit(parent, "while true do", ast) 1384 1384 - compiler.emit(sub_chunk, ("if not %s then break end"):format(condition[1]), ast) 1385 1385 - else 1386 1386 - compiler.emit(parent, ("while " .. tostring(condition) .. " do"), ast) 1387 1387 - end 1388 1388 - compile_do(ast, compiler["make-scope"](scope), sub_chunk, 3) 1389 1389 - compiler.emit(parent, sub_chunk, ast) 1390 1390 - return compiler.emit(parent, "end", ast) 1391 1391 - end 1392 1392 - SPECIALS["while"] = while_2a 1393 1393 - doc_special("while", {"condition", "..."}, "The classic while loop. Evaluates body until a condition is non-truthy.", true) 1394 1394 - local function for_2a(ast, scope, parent) 1395 1395 - local ranges = compiler.assert(utils["table?"](ast[2]), "expected binding table", ast) 1396 1396 - local until_condition = remove_until_condition(ast[2]) 1397 1397 - local binding_sym = table.remove(ast[2], 1) 1398 1398 - local sub_scope = compiler["make-scope"](scope) 1399 1399 - local range_args = {} 1400 1400 - local chunk = {} 1401 1401 - compiler.assert(utils["sym?"](binding_sym), ("unable to bind %s %s"):format(type(binding_sym), tostring(binding_sym)), ast[2]) 1402 1402 - compiler.assert((3 <= #ast), "expected body expression", ast[1]) 1403 1403 - compiler.assert((#ranges <= 3), "unexpected arguments", ranges[4]) 1404 1404 - for i = 1, math.min(#ranges, 3) do 1405 1405 - range_args[i] = tostring((compiler.compile1(ranges[i], scope, parent, {nval = 1}))[1]) 1406 1406 - end 1407 1407 - compiler.emit(parent, ("for %s = %s do"):format(compiler["declare-local"](binding_sym, {}, sub_scope, ast), table.concat(range_args, ", ")), ast) 1408 1408 - compile_until(until_condition, sub_scope, chunk) 1409 1409 - compile_do(ast, sub_scope, chunk, 3) 1410 1410 - compiler.emit(parent, chunk, ast) 1411 1411 - return compiler.emit(parent, "end", ast) 1412 1412 - end 1413 1413 - SPECIALS["for"] = for_2a 1414 1414 - doc_special("for", {"[index start stop step?]", "..."}, "Numeric loop construct.\nEvaluates body once for each value between start and stop (inclusive).", true) 1415 1415 - local function native_method_call(ast, _scope, _parent, target, args) 1416 1416 - local _let_498_ = ast 1417 1417 - local _ = _let_498_[1] 1418 1418 - local _0 = _let_498_[2] 1419 1419 - local method_string = _let_498_[3] 1420 1420 - local call_string 1421 1421 - if ((target.type == "literal") or (target.type == "varg") or (target.type == "expression")) then 1422 1422 - call_string = "(%s):%s(%s)" 1423 1423 - else 1424 1424 - call_string = "%s:%s(%s)" 1425 1425 - end 1426 1426 - return utils.expr(string.format(call_string, tostring(target), method_string, table.concat(args, ", ")), "statement") 1427 1427 - end 1428 1428 - local function nonnative_method_call(ast, scope, parent, target, args) 1429 1429 - local method_string = tostring((compiler.compile1(ast[3], scope, parent, {nval = 1}))[1]) 1430 1430 - local args0 = {tostring(target), unpack(args)} 1431 1431 - return utils.expr(string.format("%s[%s](%s)", tostring(target), method_string, table.concat(args0, ", ")), "statement") 1432 1432 - end 1433 1433 - local function double_eval_protected_method_call(ast, scope, parent, target, args) 1434 1434 - local method_string = tostring((compiler.compile1(ast[3], scope, parent, {nval = 1}))[1]) 1435 1435 - local call = "(function(tgt, m, ...) return tgt[m](tgt, ...) end)(%s, %s)" 1436 1436 - table.insert(args, 1, method_string) 1437 1437 - return utils.expr(string.format(call, tostring(target), table.concat(args, ", ")), "statement") 1438 1438 - end 1439 1439 - local function method_call(ast, scope, parent) 1440 1440 - compiler.assert((2 < #ast), "expected at least 2 arguments", ast) 1441 1441 - local _let_500_ = compiler.compile1(ast[2], scope, parent, {nval = 1}) 1442 1442 - local target = _let_500_[1] 1443 1443 - local args = {} 1444 1444 - for i = 4, #ast do 1445 1445 - local subexprs 1446 1446 - local _501_ 1447 1447 - if (i ~= #ast) then 1448 1448 - _501_ = 1 1449 1449 - else 1450 1450 - _501_ = nil 1451 1451 - end 1452 1452 - subexprs = compiler.compile1(ast[i], scope, parent, {nval = _501_}) 1453 1453 - utils.map(subexprs, tostring, args) 1454 1454 - end 1455 1455 - if (utils["string?"](ast[3]) and utils["valid-lua-identifier?"](ast[3])) then 1456 1456 - return native_method_call(ast, scope, parent, target, args) 1457 1457 - elseif (target.type == "sym") then 1458 1458 - return nonnative_method_call(ast, scope, parent, target, args) 1459 1459 - else 1460 1460 - return double_eval_protected_method_call(ast, scope, parent, target, args) 1461 1461 - end 1462 1462 - end 1463 1463 - SPECIALS[":"] = method_call 1464 1464 - doc_special(":", {"tbl", "method-name", "..."}, "Call the named method on tbl with the provided args.\nMethod name doesn't have to be known at compile-time; if it is, use\n(tbl:method-name ...) instead.") 1465 1465 - SPECIALS.comment = function(ast, _, parent) 1466 1466 - local els = {} 1467 1467 - for i = 2, #ast do 1468 1468 - table.insert(els, view(ast[i], {["one-line?"] = true})) 1469 1469 - end 1470 1470 - return compiler.emit(parent, ("--[[ " .. table.concat(els, " ") .. " ]]"), ast) 1471 1471 - end 1472 1472 - doc_special("comment", {"..."}, "Comment which will be emitted in Lua output.", true) 1473 1473 - local function hashfn_max_used(f_scope, i, max) 1474 1474 - local max0 1475 1475 - if f_scope.symmeta[("$" .. i)].used then 1476 1476 - max0 = i 1477 1477 - else 1478 1478 - max0 = max 1479 1479 - end 1480 1480 - if (i < 9) then 1481 1481 - return hashfn_max_used(f_scope, (i + 1), max0) 1482 1482 - else 1483 1483 - return max0 1484 1484 - end 1485 1485 - end 1486 1486 - SPECIALS.hashfn = function(ast, scope, parent) 1487 1487 - compiler.assert((#ast == 2), "expected one argument", ast) 1488 1488 - local f_scope 1489 1489 - do 1490 1490 - local _506_ = compiler["make-scope"](scope) 1491 1491 - do end (_506_)["vararg"] = false 1492 1492 - _506_["hashfn"] = true 1493 1493 - f_scope = _506_ 1494 1494 - end 1495 1495 - local f_chunk = {} 1496 1496 - local name = compiler.gensym(scope) 1497 1497 - local symbol = utils.sym(name) 1498 1498 - local args = {} 1499 1499 - compiler["declare-local"](symbol, {}, scope, ast) 1500 1500 - for i = 1, 9 do 1501 1501 - args[i] = compiler["declare-local"](utils.sym(("$" .. i)), {}, f_scope, ast) 1502 1502 - end 1503 1503 - local function walker(idx, node, parent_node) 1504 1504 - if (utils["sym?"](node) and (tostring(node) == "$...")) then 1505 1505 - parent_node[idx] = utils.varg() 1506 1506 - f_scope.vararg = true 1507 1507 - return nil 1508 1508 - else 1509 1509 - return (utils["list?"](node) or utils["table?"](node)) 1510 1510 - end 1511 1511 - end 1512 1512 - utils["walk-tree"](ast[2], walker) 1513 1513 - compiler.compile1(ast[2], f_scope, f_chunk, {tail = true}) 1514 1514 - local max_used = hashfn_max_used(f_scope, 1, 0) 1515 1515 - if f_scope.vararg then 1516 1516 - compiler.assert((max_used == 0), "$ and $... in hashfn are mutually exclusive", ast) 1517 1517 - else 1518 1518 - end 1519 1519 - local arg_str 1520 1520 - if f_scope.vararg then 1521 1521 - arg_str = tostring(utils.varg()) 1522 1522 - else 1523 1523 - arg_str = table.concat(args, ", ", 1, max_used) 1524 1524 - end 1525 1525 - compiler.emit(parent, string.format("local function %s(%s)", name, arg_str), ast) 1526 1526 - compiler.emit(parent, f_chunk, ast) 1527 1527 - compiler.emit(parent, "end", ast) 1528 1528 - return utils.expr(name, "sym") 1529 1529 - end 1530 1530 - doc_special("hashfn", {"..."}, "Function literal shorthand; args are either $... OR $1, $2, etc.") 1531 1531 - local function maybe_short_circuit_protect(ast, i, name, _510_) 1532 1532 - local _arg_511_ = _510_ 1533 1533 - local mac = _arg_511_["macros"] 1534 1534 - local call = (utils["list?"](ast) and tostring(ast[1])) 1535 1535 - if ((("or" == name) or ("and" == name)) and (1 < i) and (mac[call] or ("set" == call) or ("tset" == call) or ("global" == call))) then 1536 1536 - return utils.list(utils.sym("do"), ast) 1537 1537 - else 1538 1538 - return ast 1539 1539 - end 1540 1540 - end 1541 1541 - local function arithmetic_special(name, zero_arity, unary_prefix, ast, scope, parent) 1542 1542 - local len = #ast 1543 1543 - local operands = {} 1544 1544 - local padded_op = (" " .. name .. " ") 1545 1545 - for i = 2, len do 1546 1546 - local subast = maybe_short_circuit_protect(ast[i], i, name, scope) 1547 1547 - local subexprs = compiler.compile1(subast, scope, parent) 1548 1548 - if (i == len) then 1549 1549 - utils.map(subexprs, tostring, operands) 1550 1550 - else 1551 1551 - table.insert(operands, tostring(subexprs[1])) 1552 1552 - end 1553 1553 - end 1554 1554 - local _514_ = #operands 1555 1555 - if (_514_ == 0) then 1556 1556 - local _516_ 1557 1557 - do 1558 1558 - local _515_ = zero_arity 1559 1559 - compiler.assert(_515_, "Expected more than 0 arguments", ast) 1560 1560 - _516_ = _515_ 1561 1561 - end 1562 1562 - return utils.expr(_516_, "literal") 1563 1563 - elseif (_514_ == 1) then 1564 1564 - if unary_prefix then 1565 1565 - return ("(" .. unary_prefix .. padded_op .. operands[1] .. ")") 1566 1566 - else 1567 1567 - return operands[1] 1568 1568 - end 1569 1569 - elseif true then 1570 1570 - local _ = _514_ 1571 1571 - return ("(" .. table.concat(operands, padded_op) .. ")") 1572 1572 - else 1573 1573 - return nil 1574 1574 - end 1575 1575 - end 1576 1576 - local function define_arithmetic_special(name, zero_arity, unary_prefix, _3flua_name) 1577 1577 - local _522_ 1578 1578 - do 1579 1579 - local _519_ = (_3flua_name or name) 1580 1580 - local _520_ = zero_arity 1581 1581 - local _521_ = unary_prefix 1582 1582 - local function _523_(...) 1583 1583 - return arithmetic_special(_519_, _520_, _521_, ...) 1584 1584 - end 1585 1585 - _522_ = _523_ 1586 1586 - end 1587 1587 - SPECIALS[name] = _522_ 1588 1588 - return doc_special(name, {"a", "b", "..."}, "Arithmetic operator; works the same as Lua but accepts more arguments.") 1589 1589 - end 1590 1590 - define_arithmetic_special("+", "0") 1591 1591 - define_arithmetic_special("..", "''") 1592 1592 - define_arithmetic_special("^") 1593 1593 - define_arithmetic_special("-", nil, "") 1594 1594 - define_arithmetic_special("*", "1") 1595 1595 - define_arithmetic_special("%") 1596 1596 - define_arithmetic_special("/", nil, "1") 1597 1597 - define_arithmetic_special("//", nil, "1") 1598 1598 - SPECIALS["or"] = function(ast, scope, parent) 1599 1599 - return arithmetic_special("or", "false", nil, ast, scope, parent) 1600 1600 - end 1601 1601 - SPECIALS["and"] = function(ast, scope, parent) 1602 1602 - return arithmetic_special("and", "true", nil, ast, scope, parent) 1603 1603 - end 1604 1604 - doc_special("and", {"a", "b", "..."}, "Boolean operator; works the same as Lua but accepts more arguments.") 1605 1605 - doc_special("or", {"a", "b", "..."}, "Boolean operator; works the same as Lua but accepts more arguments.") 1606 1606 - local function bitop_special(native_name, lib_name, zero_arity, unary_prefix, ast, scope, parent) 1607 1607 - if (#ast == 1) then 1608 1608 - return compiler.assert(zero_arity, "Expected more than 0 arguments.", ast) 1609 1609 - else 1610 1610 - local len = #ast 1611 1611 - local operands = {} 1612 1612 - local padded_native_name = (" " .. native_name .. " ") 1613 1613 - local prefixed_lib_name = ("bit." .. lib_name) 1614 1614 - for i = 2, len do 1615 1615 - local subexprs 1616 1616 - local _524_ 1617 1617 - if (i ~= len) then 1618 1618 - _524_ = 1 1619 1619 - else 1620 1620 - _524_ = nil 1621 1621 - end 1622 1622 - subexprs = compiler.compile1(ast[i], scope, parent, {nval = _524_}) 1623 1623 - utils.map(subexprs, tostring, operands) 1624 1624 - end 1625 1625 - if (#operands == 1) then 1626 1626 - if utils.root.options.useBitLib then 1627 1627 - return (prefixed_lib_name .. "(" .. unary_prefix .. ", " .. operands[1] .. ")") 1628 1628 - else 1629 1629 - return ("(" .. unary_prefix .. padded_native_name .. operands[1] .. ")") 1630 1630 - end 1631 1631 - else 1632 1632 - if utils.root.options.useBitLib then 1633 1633 - return (prefixed_lib_name .. "(" .. table.concat(operands, ", ") .. ")") 1634 1634 - else 1635 1635 - return ("(" .. table.concat(operands, padded_native_name) .. ")") 1636 1636 - end 1637 1637 - end 1638 1638 - end 1639 1639 - end 1640 1640 - local function define_bitop_special(name, zero_arity, unary_prefix, native) 1641 1641 - local _534_ 1642 1642 - do 1643 1643 - local _530_ = native 1644 1644 - local _531_ = name 1645 1645 - local _532_ = zero_arity 1646 1646 - local _533_ = unary_prefix 1647 1647 - local function _535_(...) 1648 1648 - return bitop_special(_530_, _531_, _532_, _533_, ...) 1649 1649 - end 1650 1650 - _534_ = _535_ 1651 1651 - end 1652 1652 - SPECIALS[name] = _534_ 1653 1653 - return nil 1654 1654 - end 1655 1655 - define_bitop_special("lshift", nil, "1", "<<") 1656 1656 - define_bitop_special("rshift", nil, "1", ">>") 1657 1657 - define_bitop_special("band", "0", "0", "&") 1658 1658 - define_bitop_special("bor", "0", "0", "|") 1659 1659 - define_bitop_special("bxor", "0", "0", "~") 1660 1660 - doc_special("lshift", {"x", "n"}, "Bitwise logical left shift of x by n bits.\nOnly works in Lua 5.3+ or LuaJIT with the --use-bit-lib flag.") 1661 1661 - doc_special("rshift", {"x", "n"}, "Bitwise logical right shift of x by n bits.\nOnly works in Lua 5.3+ or LuaJIT with the --use-bit-lib flag.") 1662 1662 - doc_special("band", {"x1", "x2", "..."}, "Bitwise AND of any number of arguments.\nOnly works in Lua 5.3+ or LuaJIT with the --use-bit-lib flag.") 1663 1663 - doc_special("bor", {"x1", "x2", "..."}, "Bitwise OR of any number of arguments.\nOnly works in Lua 5.3+ or LuaJIT with the --use-bit-lib flag.") 1664 1664 - doc_special("bxor", {"x1", "x2", "..."}, "Bitwise XOR of any number of arguments.\nOnly works in Lua 5.3+ or LuaJIT with the --use-bit-lib flag.") 1665 1665 - doc_special("..", {"a", "b", "..."}, "String concatenation operator; works the same as Lua but accepts more arguments.") 1666 1666 - local function native_comparator(op, _536_, scope, parent) 1667 1667 - local _arg_537_ = _536_ 1668 1668 - local _ = _arg_537_[1] 1669 1669 - local lhs_ast = _arg_537_[2] 1670 1670 - local rhs_ast = _arg_537_[3] 1671 1671 - local _let_538_ = compiler.compile1(lhs_ast, scope, parent, {nval = 1}) 1672 1672 - local lhs = _let_538_[1] 1673 1673 - local _let_539_ = compiler.compile1(rhs_ast, scope, parent, {nval = 1}) 1674 1674 - local rhs = _let_539_[1] 1675 1675 - return string.format("(%s %s %s)", tostring(lhs), op, tostring(rhs)) 1676 1676 - end 1677 1677 - local function double_eval_protected_comparator(op, chain_op, ast, scope, parent) 1678 1678 - local arglist = {} 1679 1679 - local comparisons = {} 1680 1680 - local vals = {} 1681 1681 - local chain = string.format(" %s ", (chain_op or "and")) 1682 1682 - for i = 2, #ast do 1683 1683 - table.insert(arglist, tostring(compiler.gensym(scope))) 1684 1684 - table.insert(vals, tostring((compiler.compile1(ast[i], scope, parent, {nval = 1}))[1])) 1685 1685 - end 1686 1686 - for i = 1, (#arglist - 1) do 1687 1687 - table.insert(comparisons, string.format("(%s %s %s)", arglist[i], op, arglist[(i + 1)])) 1688 1688 - end 1689 1689 - return string.format("(function(%s) return %s end)(%s)", table.concat(arglist, ","), table.concat(comparisons, chain), table.concat(vals, ",")) 1690 1690 - end 1691 1691 - local function define_comparator_special(name, _3flua_op, _3fchain_op) 1692 1692 - do 1693 1693 - local op = (_3flua_op or name) 1694 1694 - local function opfn(ast, scope, parent) 1695 1695 - compiler.assert((2 < #ast), "expected at least two arguments", ast) 1696 1696 - if (3 == #ast) then 1697 1697 - return native_comparator(op, ast, scope, parent) 1698 1698 - else 1699 1699 - return double_eval_protected_comparator(op, _3fchain_op, ast, scope, parent) 1700 1700 - end 1701 1701 - end 1702 1702 - SPECIALS[name] = opfn 1703 1703 - end 1704 1704 - return doc_special(name, {"a", "b", "..."}, "Comparison operator; works the same as Lua but accepts more arguments.") 1705 1705 - end 1706 1706 - define_comparator_special(">") 1707 1707 - define_comparator_special("<") 1708 1708 - define_comparator_special(">=") 1709 1709 - define_comparator_special("<=") 1710 1710 - define_comparator_special("=", "==") 1711 1711 - define_comparator_special("not=", "~=", "or") 1712 1712 - local function define_unary_special(op, _3frealop) 1713 1713 - local function opfn(ast, scope, parent) 1714 1714 - compiler.assert((#ast == 2), "expected one argument", ast) 1715 1715 - local tail = compiler.compile1(ast[2], scope, parent, {nval = 1}) 1716 1716 - return ((_3frealop or op) .. tostring(tail[1])) 1717 1717 - end 1718 1718 - SPECIALS[op] = opfn 1719 1719 - return nil 1720 1720 - end 1721 1721 - define_unary_special("not", "not ") 1722 1722 - doc_special("not", {"x"}, "Logical operator; works the same as Lua.") 1723 1723 - define_unary_special("bnot", "~") 1724 1724 - doc_special("bnot", {"x"}, "Bitwise negation; only works in Lua 5.3+ or LuaJIT with the --use-bit-lib flag.") 1725 1725 - define_unary_special("length", "#") 1726 1726 - doc_special("length", {"x"}, "Returns the length of a table or string.") 1727 1727 - do end (SPECIALS)["~="] = SPECIALS["not="] 1728 1728 - SPECIALS["#"] = SPECIALS.length 1729 1729 - SPECIALS.quote = function(ast, scope, parent) 1730 1730 - compiler.assert((#ast == 2), "expected one argument", ast) 1731 1731 - local runtime, this_scope = true, scope 1732 1732 - while this_scope do 1733 1733 - this_scope = this_scope.parent 1734 1734 - if (this_scope == compiler.scopes.compiler) then 1735 1735 - runtime = false 1736 1736 - else 1737 1737 - end 1738 1738 - end 1739 1739 - return compiler["do-quote"](ast[2], scope, parent, runtime) 1740 1740 - end 1741 1741 - doc_special("quote", {"x"}, "Quasiquote the following form. Only works in macro/compiler scope.") 1742 1742 - local macro_loaded = {} 1743 1743 - local function safe_getmetatable(tbl) 1744 1744 - local mt = getmetatable(tbl) 1745 1745 - assert((mt ~= getmetatable("")), "Illegal metatable access!") 1746 1746 - return mt 1747 1747 - end 1748 1748 - local safe_require = nil 1749 1749 - local function safe_compiler_env() 1750 1750 - local _543_ 1751 1751 - do 1752 1752 - local _542_ = rawget(_G, "utf8") 1753 1753 - if (nil ~= _542_) then 1754 1754 - _543_ = utils.copy(_542_) 1755 1755 - else 1756 1756 - _543_ = _542_ 1757 1757 - end 1758 1758 - end 1759 1759 - return {table = utils.copy(table), math = utils.copy(math), string = utils.copy(string), pairs = utils.stablepairs, ipairs = ipairs, select = select, tostring = tostring, tonumber = tonumber, bit = rawget(_G, "bit"), pcall = pcall, xpcall = xpcall, next = next, print = print, type = type, assert = assert, error = error, setmetatable = setmetatable, getmetatable = safe_getmetatable, require = safe_require, rawlen = rawget(_G, "rawlen"), rawget = rawget, rawset = rawset, rawequal = rawequal, _VERSION = _VERSION, utf8 = _543_} 1760 1760 - end 1761 1761 - local function combined_mt_pairs(env) 1762 1762 - local combined = {} 1763 1763 - local _let_545_ = getmetatable(env) 1764 1764 - local __index = _let_545_["__index"] 1765 1765 - if ("table" == type(__index)) then 1766 1766 - for k, v in pairs(__index) do 1767 1767 - combined[k] = v 1768 1768 - end 1769 1769 - else 1770 1770 - end 1771 1771 - for k, v in next, env, nil do 1772 1772 - combined[k] = v 1773 1773 - end 1774 1774 - return next, combined, nil 1775 1775 - end 1776 1776 - local function make_compiler_env(ast, scope, parent, _3fopts) 1777 1777 - local provided 1778 1778 - do 1779 1779 - local _547_ = (_3fopts or utils.root.options) 1780 1780 - if ((_G.type(_547_) == "table") and ((_547_)["compiler-env"] == "strict")) then 1781 1781 - provided = safe_compiler_env() 1782 1782 - elseif ((_G.type(_547_) == "table") and (nil ~= (_547_).compilerEnv)) then 1783 1783 - local compilerEnv = (_547_).compilerEnv 1784 1784 - provided = compilerEnv 1785 1785 - elseif ((_G.type(_547_) == "table") and (nil ~= (_547_)["compiler-env"])) then 1786 1786 - local compiler_env = (_547_)["compiler-env"] 1787 1787 - provided = compiler_env 1788 1788 - elseif true then 1789 1789 - local _ = _547_ 1790 1790 - provided = safe_compiler_env(false) 1791 1791 - else 1792 1792 - provided = nil 1793 1793 - end 1794 1794 - end 1795 1795 - local env 1796 1796 - local function _549_(base) 1797 1797 - return utils.sym(compiler.gensym((compiler.scopes.macro or scope), base)) 1798 1798 - end 1799 1799 - local function _550_() 1800 1800 - return compiler.scopes.macro 1801 1801 - end 1802 1802 - local function _551_(symbol) 1803 1803 - compiler.assert(compiler.scopes.macro, "must call from macro", ast) 1804 1804 - return compiler.scopes.macro.manglings[tostring(symbol)] 1805 1805 - end 1806 1806 - local function _552_(form) 1807 1807 - compiler.assert(compiler.scopes.macro, "must call from macro", ast) 1808 1808 - return compiler.macroexpand(form, compiler.scopes.macro) 1809 1809 - end 1810 1810 - env = {_AST = ast, _CHUNK = parent, _IS_COMPILER = true, _SCOPE = scope, _SPECIALS = compiler.scopes.global.specials, _VARARG = utils.varg(), ["macro-loaded"] = macro_loaded, unpack = unpack, ["assert-compile"] = compiler.assert, view = view, version = utils.version, metadata = compiler.metadata, ["ast-source"] = utils["ast-source"], list = utils.list, ["list?"] = utils["list?"], ["table?"] = utils["table?"], sequence = utils.sequence, ["sequence?"] = utils["sequence?"], sym = utils.sym, ["sym?"] = utils["sym?"], ["multi-sym?"] = utils["multi-sym?"], comment = utils.comment, ["comment?"] = utils["comment?"], ["varg?"] = utils["varg?"], gensym = _549_, ["get-scope"] = _550_, ["in-scope?"] = _551_, macroexpand = _552_} 1811 1811 - env._G = env 1812 1812 - return setmetatable(env, {__index = provided, __newindex = provided, __pairs = combined_mt_pairs}) 1813 1813 - end 1814 1814 - local function _554_(...) 1815 1815 - local tbl_14_auto = {} 1816 1816 - local i_15_auto = #tbl_14_auto 1817 1817 - for c in string.gmatch((package.config or ""), "([^\n]+)") do 1818 1818 - local val_16_auto = c 1819 1819 - if (nil ~= val_16_auto) then 1820 1820 - i_15_auto = (i_15_auto + 1) 1821 1821 - do end (tbl_14_auto)[i_15_auto] = val_16_auto 1822 1822 - else 1823 1823 - end 1824 1824 - end 1825 1825 - return tbl_14_auto 1826 1826 - end 1827 1827 - local _local_553_ = _554_(...) 1828 1828 - local dirsep = _local_553_[1] 1829 1829 - local pathsep = _local_553_[2] 1830 1830 - local pathmark = _local_553_[3] 1831 1831 - local pkg_config = {dirsep = (dirsep or "/"), pathmark = (pathmark or ";"), pathsep = (pathsep or "?")} 1832 1832 - local function escapepat(str) 1833 1833 - return string.gsub(str, "[^%w]", "%%%1") 1834 1834 - end 1835 1835 - local function search_module(modulename, _3fpathstring) 1836 1836 - local pathsepesc = escapepat(pkg_config.pathsep) 1837 1837 - local pattern = ("([^%s]*)%s"):format(pathsepesc, pathsepesc) 1838 1838 - local no_dot_module = modulename:gsub("%.", pkg_config.dirsep) 1839 1839 - local fullpath = ((_3fpathstring or utils["fennel-module"].path) .. pkg_config.pathsep) 1840 1840 - local function try_path(path) 1841 1841 - local filename = path:gsub(escapepat(pkg_config.pathmark), no_dot_module) 1842 1842 - local filename2 = path:gsub(escapepat(pkg_config.pathmark), modulename) 1843 1843 - local _556_ = (io.open(filename) or io.open(filename2)) 1844 1844 - if (nil ~= _556_) then 1845 1845 - local file = _556_ 1846 1846 - file:close() 1847 1847 - return filename 1848 1848 - elseif true then 1849 1849 - local _ = _556_ 1850 1850 - return nil, ("no file '" .. filename .. "'") 1851 1851 - else 1852 1852 - return nil 1853 1853 - end 1854 1854 - end 1855 1855 - local function find_in_path(start, _3ftried_paths) 1856 1856 - local _558_ = fullpath:match(pattern, start) 1857 1857 - if (nil ~= _558_) then 1858 1858 - local path = _558_ 1859 1859 - local _559_, _560_ = try_path(path) 1860 1860 - if (nil ~= _559_) then 1861 1861 - local filename = _559_ 1862 1862 - return filename 1863 1863 - elseif ((_559_ == nil) and (nil ~= _560_)) then 1864 1864 - local error = _560_ 1865 1865 - local function _562_() 1866 1866 - local _561_ = (_3ftried_paths or {}) 1867 1867 - table.insert(_561_, error) 1868 1868 - return _561_ 1869 1869 - end 1870 1870 - return find_in_path((start + #path + 1), _562_()) 1871 1871 - else 1872 1872 - return nil 1873 1873 - end 1874 1874 - elseif true then 1875 1875 - local _ = _558_ 1876 1876 - local function _564_() 1877 1877 - local tried_paths = table.concat((_3ftried_paths or {}), "\n\9") 1878 1878 - if (_VERSION < "Lua 5.4") then 1879 1879 - return ("\n\9" .. tried_paths) 1880 1880 - else 1881 1881 - return tried_paths 1882 1882 - end 1883 1883 - end 1884 1884 - return nil, _564_() 1885 1885 - else 1886 1886 - return nil 1887 1887 - end 1888 1888 - end 1889 1889 - return find_in_path(1) 1890 1890 - end 1891 1891 - local function make_searcher(_3foptions) 1892 1892 - local function _567_(module_name) 1893 1893 - local opts = utils.copy(utils.root.options) 1894 1894 - for k, v in pairs((_3foptions or {})) do 1895 1895 - opts[k] = v 1896 1896 - end 1897 1897 - opts["module-name"] = module_name 1898 1898 - local _568_, _569_ = search_module(module_name) 1899 1899 - if (nil ~= _568_) then 1900 1900 - local filename = _568_ 1901 1901 - local _572_ 1902 1902 - do 1903 1903 - local _570_ = filename 1904 1904 - local _571_ = opts 1905 1905 - local function _573_(...) 1906 1906 - return utils["fennel-module"].dofile(_570_, _571_, ...) 1907 1907 - end 1908 1908 - _572_ = _573_ 1909 1909 - end 1910 1910 - return _572_, filename 1911 1911 - elseif ((_568_ == nil) and (nil ~= _569_)) then 1912 1912 - local error = _569_ 1913 1913 - return error 1914 1914 - else 1915 1915 - return nil 1916 1916 - end 1917 1917 - end 1918 1918 - return _567_ 1919 1919 - end 1920 1920 - local function dofile_with_searcher(fennel_macro_searcher, filename, opts, ...) 1921 1921 - local searchers = (package.loaders or package.searchers or {}) 1922 1922 - local _ = table.insert(searchers, 1, fennel_macro_searcher) 1923 1923 - local m = utils["fennel-module"].dofile(filename, opts, ...) 1924 1924 - table.remove(searchers, 1) 1925 1925 - return m 1926 1926 - end 1927 1927 - local function fennel_macro_searcher(module_name) 1928 1928 - local opts 1929 1929 - do 1930 1930 - local _575_ = utils.copy(utils.root.options) 1931 1931 - do end (_575_)["module-name"] = module_name 1932 1932 - _575_["env"] = "_COMPILER" 1933 1933 - _575_["requireAsInclude"] = false 1934 1934 - _575_["allowedGlobals"] = nil 1935 1935 - opts = _575_ 1936 1936 - end 1937 1937 - local _576_ = search_module(module_name, utils["fennel-module"]["macro-path"]) 1938 1938 - if (nil ~= _576_) then 1939 1939 - local filename = _576_ 1940 1940 - local _577_ 1941 1941 - if (opts["compiler-env"] == _G) then 1942 1942 - local _578_ = fennel_macro_searcher 1943 1943 - local _579_ = filename 1944 1944 - local _580_ = opts 1945 1945 - local function _582_(...) 1946 1946 - return dofile_with_searcher(_578_, _579_, _580_, ...) 1947 1947 - end 1948 1948 - _577_ = _582_ 1949 1949 - else 1950 1950 - local _583_ = filename 1951 1951 - local _584_ = opts 1952 1952 - local function _586_(...) 1953 1953 - return utils["fennel-module"].dofile(_583_, _584_, ...) 1954 1954 - end 1955 1955 - _577_ = _586_ 1956 1956 - end 1957 1957 - return _577_, filename 1958 1958 - else 1959 1959 - return nil 1960 1960 - end 1961 1961 - end 1962 1962 - local function lua_macro_searcher(module_name) 1963 1963 - local _589_ = search_module(module_name, package.path) 1964 1964 - if (nil ~= _589_) then 1965 1965 - local filename = _589_ 1966 1966 - local code 1967 1967 - do 1968 1968 - local f = io.open(filename) 1969 1969 - local function close_handlers_8_auto(ok_9_auto, ...) 1970 1970 - f:close() 1971 1971 - if ok_9_auto then 1972 1972 - return ... 1973 1973 - else 1974 1974 - return error(..., 0) 1975 1975 - end 1976 1976 - end 1977 1977 - local function _591_() 1978 1978 - return assert(f:read("*a")) 1979 1979 - end 1980 1980 - code = close_handlers_8_auto(_G.xpcall(_591_, (package.loaded.fennel or debug).traceback)) 1981 1981 - end 1982 1982 - local chunk = load_code(code, make_compiler_env(), filename) 1983 1983 - return chunk, filename 1984 1984 - else 1985 1985 - return nil 1986 1986 - end 1987 1987 - end 1988 1988 - local macro_searchers = {fennel_macro_searcher, lua_macro_searcher} 1989 1989 - local function search_macro_module(modname, n) 1990 1990 - local _593_ = macro_searchers[n] 1991 1991 - if (nil ~= _593_) then 1992 1992 - local f = _593_ 1993 1993 - local _594_, _595_ = f(modname) 1994 1994 - if ((nil ~= _594_) and true) then 1995 1995 - local loader = _594_ 1996 1996 - local _3ffilename = _595_ 1997 1997 - return loader, _3ffilename 1998 1998 - elseif true then 1999 1999 - local _ = _594_ 2000 2000 - return search_macro_module(modname, (n + 1)) 2001 2001 - else 2002 2002 - return nil 2003 2003 - end 2004 2004 - else 2005 2005 - return nil 2006 2006 - end 2007 2007 - end 2008 2008 - local function sandbox_fennel_module(modname) 2009 2009 - if ((modname == "fennel.macros") or (package and package.loaded and ("table" == type(package.loaded[modname])) and (package.loaded[modname].metadata == compiler.metadata))) then 2010 2010 - return {metadata = compiler.metadata, view = view} 2011 2011 - else 2012 2012 - return nil 2013 2013 - end 2014 2014 - end 2015 2015 - local function _599_(modname) 2016 2016 - local function _600_() 2017 2017 - local loader, filename = search_macro_module(modname, 1) 2018 2018 - compiler.assert(loader, (modname .. " module not found.")) 2019 2019 - do end (macro_loaded)[modname] = loader(modname, filename) 2020 2020 - return macro_loaded[modname] 2021 2021 - end 2022 2022 - return (macro_loaded[modname] or sandbox_fennel_module(modname) or _600_()) 2023 2023 - end 2024 2024 - safe_require = _599_ 2025 2025 - local function add_macros(macros_2a, ast, scope) 2026 2026 - compiler.assert(utils["table?"](macros_2a), "expected macros to be table", ast) 2027 2027 - for k, v in pairs(macros_2a) do 2028 2028 - compiler.assert((type(v) == "function"), "expected each macro to be function", ast) 2029 2029 - compiler["check-binding-valid"](utils.sym(k), scope, ast, {["macro?"] = true}) 2030 2030 - do end (scope.macros)[k] = v 2031 2031 - end 2032 2032 - return nil 2033 2033 - end 2034 2034 - local function resolve_module_name(_601_, _scope, _parent, opts) 2035 2035 - local _arg_602_ = _601_ 2036 2036 - local filename = _arg_602_["filename"] 2037 2037 - local second = _arg_602_[2] 2038 2038 - local filename0 = (filename or (utils["table?"](second) and second.filename)) 2039 2039 - local module_name = utils.root.options["module-name"] 2040 2040 - local modexpr = compiler.compile(second, opts) 2041 2041 - local modname_chunk = load_code(modexpr) 2042 2042 - return modname_chunk(module_name, filename0) 2043 2043 - end 2044 2044 - SPECIALS["require-macros"] = function(ast, scope, parent, _3freal_ast) 2045 2045 - compiler.assert((#ast == 2), "Expected one module name argument", (_3freal_ast or ast)) 2046 2046 - local modname = resolve_module_name(ast, scope, parent, {}) 2047 2047 - compiler.assert(utils["string?"](modname), "module name must compile to string", (_3freal_ast or ast)) 2048 2048 - if not macro_loaded[modname] then 2049 2049 - local loader, filename = search_macro_module(modname, 1) 2050 2050 - compiler.assert(loader, (modname .. " module not found."), ast) 2051 2051 - do end (macro_loaded)[modname] = compiler.assert(utils["table?"](loader(modname, filename)), "expected macros to be table", (_3freal_ast or ast)) 2052 2052 - else 2053 2053 - end 2054 2054 - if ("import-macros" == tostring(ast[1])) then 2055 2055 - return macro_loaded[modname] 2056 2056 - else 2057 2057 - return add_macros(macro_loaded[modname], ast, scope, parent) 2058 2058 - end 2059 2059 - end 2060 2060 - doc_special("require-macros", {"macro-module-name"}, "Load given module and use its contents as macro definitions in current scope.\nMacro module should return a table of macro functions with string keys.\nConsider using import-macros instead as it is more flexible.") 2061 2061 - local function emit_included_fennel(src, path, opts, sub_chunk) 2062 2062 - local subscope = compiler["make-scope"](utils.root.scope.parent) 2063 2063 - local forms = {} 2064 2064 - if utils.root.options.requireAsInclude then 2065 2065 - subscope.specials.require = compiler["require-include"] 2066 2066 - else 2067 2067 - end 2068 2068 - for _, val in parser.parser(parser["string-stream"](src), path) do 2069 2069 - table.insert(forms, val) 2070 2070 - end 2071 2071 - for i = 1, #forms do 2072 2072 - local subopts 2073 2073 - if (i == #forms) then 2074 2074 - subopts = {tail = true} 2075 2075 - else 2076 2076 - subopts = {nval = 0} 2077 2077 - end 2078 2078 - utils["propagate-options"](opts, subopts) 2079 2079 - compiler.compile1(forms[i], subscope, sub_chunk, subopts) 2080 2080 - end 2081 2081 - return nil 2082 2082 - end 2083 2083 - local function include_path(ast, opts, path, mod, fennel_3f) 2084 2084 - utils.root.scope.includes[mod] = "fnl/loading" 2085 2085 - local src 2086 2086 - do 2087 2087 - local f = assert(io.open(path)) 2088 2088 - local function close_handlers_8_auto(ok_9_auto, ...) 2089 2089 - f:close() 2090 2090 - if ok_9_auto then 2091 2091 - return ... 2092 2092 - else 2093 2093 - return error(..., 0) 2094 2094 - end 2095 2095 - end 2096 2096 - local function _608_() 2097 2097 - return assert(f:read("*all")):gsub("[\13\n]*$", "") 2098 2098 - end 2099 2099 - src = close_handlers_8_auto(_G.xpcall(_608_, (package.loaded.fennel or debug).traceback)) 2100 2100 - end 2101 2101 - local ret = utils.expr(("require(\"" .. mod .. "\")"), "statement") 2102 2102 - local target = ("package.preload[%q]"):format(mod) 2103 2103 - local preload_str = (target .. " = " .. target .. " or function(...)") 2104 2104 - local temp_chunk, sub_chunk = {}, {} 2105 2105 - compiler.emit(temp_chunk, preload_str, ast) 2106 2106 - compiler.emit(temp_chunk, sub_chunk) 2107 2107 - compiler.emit(temp_chunk, "end", ast) 2108 2108 - for _, v in ipairs(temp_chunk) do 2109 2109 - table.insert(utils.root.chunk, v) 2110 2110 - end 2111 2111 - if fennel_3f then 2112 2112 - emit_included_fennel(src, path, opts, sub_chunk) 2113 2113 - else 2114 2114 - compiler.emit(sub_chunk, src, ast) 2115 2115 - end 2116 2116 - utils.root.scope.includes[mod] = ret 2117 2117 - return ret 2118 2118 - end 2119 2119 - local function include_circular_fallback(mod, modexpr, fallback, ast) 2120 2120 - if (utils.root.scope.includes[mod] == "fnl/loading") then 2121 2121 - compiler.assert(fallback, "circular include detected", ast) 2122 2122 - return fallback(modexpr) 2123 2123 - else 2124 2124 - return nil 2125 2125 - end 2126 2126 - end 2127 2127 - SPECIALS.include = function(ast, scope, parent, opts) 2128 2128 - compiler.assert((#ast == 2), "expected one argument", ast) 2129 2129 - local modexpr 2130 2130 - do 2131 2131 - local _611_, _612_ = pcall(resolve_module_name, ast, scope, parent, opts) 2132 2132 - if ((_611_ == true) and (nil ~= _612_)) then 2133 2133 - local modname = _612_ 2134 2134 - modexpr = utils.expr(string.format("%q", modname), "literal") 2135 2135 - elseif true then 2136 2136 - local _ = _611_ 2137 2137 - modexpr = (compiler.compile1(ast[2], scope, parent, {nval = 1}))[1] 2138 2138 - else 2139 2139 - modexpr = nil 2140 2140 - end 2141 2141 - end 2142 2142 - if ((modexpr.type ~= "literal") or ((modexpr[1]):byte() ~= 34)) then 2143 2143 - if opts.fallback then 2144 2144 - return opts.fallback(modexpr) 2145 2145 - else 2146 2146 - return compiler.assert(false, "module name must be string literal", ast) 2147 2147 - end 2148 2148 - else 2149 2149 - local mod = load_code(("return " .. modexpr[1]))() 2150 2150 - local oldmod = utils.root.options["module-name"] 2151 2151 - local _ 2152 2152 - utils.root.options["module-name"] = mod 2153 2153 - _ = nil 2154 2154 - local res 2155 2155 - local function _616_() 2156 2156 - local _615_ = search_module(mod) 2157 2157 - if (nil ~= _615_) then 2158 2158 - local fennel_path = _615_ 2159 2159 - return include_path(ast, opts, fennel_path, mod, true) 2160 2160 - elseif true then 2161 2161 - local _0 = _615_ 2162 2162 - local lua_path = search_module(mod, package.path) 2163 2163 - if lua_path then 2164 2164 - return include_path(ast, opts, lua_path, mod, false) 2165 2165 - elseif opts.fallback then 2166 2166 - return opts.fallback(modexpr) 2167 2167 - else 2168 2168 - return compiler.assert(false, ("module not found " .. mod), ast) 2169 2169 - end 2170 2170 - else 2171 2171 - return nil 2172 2172 - end 2173 2173 - end 2174 2174 - res = ((utils["member?"](mod, (utils.root.options.skipInclude or {})) and opts.fallback(modexpr, true)) or include_circular_fallback(mod, modexpr, opts.fallback, ast) or utils.root.scope.includes[mod] or _616_()) 2175 2175 - utils.root.options["module-name"] = oldmod 2176 2176 - return res 2177 2177 - end 2178 2178 - end 2179 2179 - doc_special("include", {"module-name-literal"}, "Like require but load the target module during compilation and embed it in the\nLua output. The module must be a string literal and resolvable at compile time.") 2180 2180 - local function eval_compiler_2a(ast, scope, parent) 2181 2181 - local env = make_compiler_env(ast, scope, parent) 2182 2182 - local opts = utils.copy(utils.root.options) 2183 2183 - opts.scope = compiler["make-scope"](compiler.scopes.compiler) 2184 2184 - opts.allowedGlobals = current_global_names(env) 2185 2185 - return load_code(compiler.compile(ast, opts), wrap_env(env))(opts["module-name"], ast.filename) 2186 2186 - end 2187 2187 - SPECIALS.macros = function(ast, scope, parent) 2188 2188 - compiler.assert((#ast == 2), "Expected one table argument", ast) 2189 2189 - return add_macros(eval_compiler_2a(ast[2], scope, parent), ast, scope, parent) 2190 2190 - end 2191 2191 - doc_special("macros", {"{:macro-name-1 (fn [...] ...) ... :macro-name-N macro-body-N}"}, "Define all functions in the given table as macros local to the current scope.") 2192 2192 - SPECIALS["eval-compiler"] = function(ast, scope, parent) 2193 2193 - local old_first = ast[1] 2194 2194 - ast[1] = utils.sym("do") 2195 2195 - local val = eval_compiler_2a(ast, scope, parent) 2196 2196 - do end (ast)[1] = old_first 2197 2197 - return val 2198 2198 - end 2199 2199 - doc_special("eval-compiler", {"..."}, "Evaluate the body at compile-time. Use the macro system instead if possible.", true) 2200 2200 - return {doc = doc_2a, ["current-global-names"] = current_global_names, ["load-code"] = load_code, ["macro-loaded"] = macro_loaded, ["macro-searchers"] = macro_searchers, ["make-compiler-env"] = make_compiler_env, ["search-module"] = search_module, ["make-searcher"] = make_searcher, ["wrap-env"] = wrap_env} 2201 2201 - end 2202 2202 - package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or function(...) 2203 2203 - local utils = require("fennel.utils") 2204 2204 - local parser = require("fennel.parser") 2205 2205 - local friend = require("fennel.friend") 2206 2206 - local unpack = (table.unpack or _G.unpack) 2207 2207 - local scopes = {} 2208 2208 - local function make_scope(_3fparent) 2209 2209 - local parent = (_3fparent or scopes.global) 2210 2210 - local _257_ 2211 2211 - if parent then 2212 2212 - _257_ = ((parent.depth or 0) + 1) 2213 2213 - else 2214 2214 - _257_ = 0 2215 2215 - end 2216 2216 - return {includes = setmetatable({}, {__index = (parent and parent.includes)}), macros = setmetatable({}, {__index = (parent and parent.macros)}), manglings = setmetatable({}, {__index = (parent and parent.manglings)}), specials = setmetatable({}, {__index = (parent and parent.specials)}), symmeta = setmetatable({}, {__index = (parent and parent.symmeta)}), unmanglings = setmetatable({}, {__index = (parent and parent.unmanglings)}), gensyms = setmetatable({}, {__index = (parent and parent.gensyms)}), autogensyms = setmetatable({}, {__index = (parent and parent.autogensyms)}), vararg = (parent and parent.vararg), depth = _257_, hashfn = (parent and parent.hashfn), refedglobals = {}, parent = parent} 2217 2217 - end 2218 2218 - local function assert_msg(ast, msg) 2219 2219 - local ast_tbl 2220 2220 - if ("table" == type(ast)) then 2221 2221 - ast_tbl = ast 2222 2222 - else 2223 2223 - ast_tbl = {} 2224 2224 - end 2225 2225 - local m = getmetatable(ast) 2226 2226 - local filename = ((m and m.filename) or ast_tbl.filename or "unknown") 2227 2227 - local line = ((m and m.line) or ast_tbl.line or "?") 2228 2228 - local col = ((m and m.col) or ast_tbl.col or "?") 2229 2229 - local target = tostring((utils["sym?"](ast_tbl[1]) or ast_tbl[1] or "()")) 2230 2230 - return string.format("%s:%s:%s Compile error in '%s': %s", filename, line, col, target, msg) 2231 2231 - end 2232 2232 - local function assert_compile(condition, msg, ast) 2233 2233 - if not condition then 2234 2234 - local _let_260_ = (utils.root.options or {}) 2235 2235 - local source = _let_260_["source"] 2236 2236 - local unfriendly = _let_260_["unfriendly"] 2237 2237 - if (nil == utils.hook("assert-compile", condition, msg, ast, utils.root.reset)) then 2238 2238 - utils.root.reset() 2239 2239 - if (unfriendly or not friend or not _G.io or not _G.io.read) then 2240 2240 - error(assert_msg(ast, msg), 0) 2241 2241 - else 2242 2242 - friend["assert-compile"](condition, msg, ast, source) 2243 2243 - end 2244 2244 - else 2245 2245 - end 2246 2246 - else 2247 2247 - end 2248 2248 - return condition 2249 2249 - end 2250 2250 - scopes.global = make_scope() 2251 2251 - scopes.global.vararg = true 2252 2252 - scopes.compiler = make_scope(scopes.global) 2253 2253 - scopes.macro = scopes.global 2254 2254 - local serialize_subst = {["\7"] = "\\a", ["\8"] = "\\b", ["\9"] = "\\t", ["\n"] = "n", ["\11"] = "\\v", ["\12"] = "\\f"} 2255 2255 - local function serialize_string(str) 2256 2256 - local function _264_(_241) 2257 2257 - return ("\\" .. _241:byte()) 2258 2258 - end 2259 2259 - return string.gsub(string.gsub(string.format("%q", str), ".", serialize_subst), "[\128-\255]", _264_) 2260 2260 - end 2261 2261 - local function global_mangling(str) 2262 2262 - if utils["valid-lua-identifier?"](str) then 2263 2263 - return str 2264 2264 - else 2265 2265 - local function _265_(_241) 2266 2266 - return string.format("_%02x", _241:byte()) 2267 2267 - end 2268 2268 - return ("__fnl_global__" .. str:gsub("[^%w]", _265_)) 2269 2269 - end 2270 2270 - end 2271 2271 - local function global_unmangling(identifier) 2272 2272 - local _267_ = string.match(identifier, "^__fnl_global__(.*)$") 2273 2273 - if (nil ~= _267_) then 2274 2274 - local rest = _267_ 2275 2275 - local _268_ 2276 2276 - local function _269_(_241) 2277 2277 - return string.char(tonumber(_241:sub(2), 16)) 2278 2278 - end 2279 2279 - _268_ = string.gsub(rest, "_[%da-f][%da-f]", _269_) 2280 2280 - return _268_ 2281 2281 - elseif true then 2282 2282 - local _ = _267_ 2283 2283 - return identifier 2284 2284 - else 2285 2285 - return nil 2286 2286 - end 2287 2287 - end 2288 2288 - local allowed_globals = nil 2289 2289 - local function global_allowed_3f(name) 2290 2290 - return (not allowed_globals or utils["member?"](name, allowed_globals)) 2291 2291 - end 2292 2292 - local function unique_mangling(original, mangling, scope, append) 2293 2293 - if (scope.unmanglings[mangling] and not scope.gensyms[mangling]) then 2294 2294 - return unique_mangling(original, (original .. append), scope, (append + 1)) 2295 2295 - else 2296 2296 - return mangling 2297 2297 - end 2298 2298 - end 2299 2299 - local function local_mangling(str, scope, ast, _3ftemp_manglings) 2300 2300 - assert_compile(not utils["multi-sym?"](str), ("unexpected multi symbol " .. str), ast) 2301 2301 - local raw 2302 2302 - if ((utils["lua-keywords"])[str] or str:match("^%d")) then 2303 2303 - raw = ("_" .. str) 2304 2304 - else 2305 2305 - raw = str 2306 2306 - end 2307 2307 - local mangling 2308 2308 - local function _273_(_241) 2309 2309 - return string.format("_%02x", _241:byte()) 2310 2310 - end 2311 2311 - mangling = string.gsub(string.gsub(raw, "-", "_"), "[^%w_]", _273_) 2312 2312 - local unique = unique_mangling(mangling, mangling, scope, 0) 2313 2313 - do end (scope.unmanglings)[unique] = str 2314 2314 - do 2315 2315 - local manglings = (_3ftemp_manglings or scope.manglings) 2316 2316 - do end (manglings)[str] = unique 2317 2317 - end 2318 2318 - return unique 2319 2319 - end 2320 2320 - local function apply_manglings(scope, new_manglings, ast) 2321 2321 - for raw, mangled in pairs(new_manglings) do 2322 2322 - assert_compile(not scope.refedglobals[mangled], ("use of global " .. raw .. " is aliased by a local"), ast) 2323 2323 - do end (scope.manglings)[raw] = mangled 2324 2324 - end 2325 2325 - return nil 2326 2326 - end 2327 2327 - local function combine_parts(parts, scope) 2328 2328 - local ret = (scope.manglings[parts[1]] or global_mangling(parts[1])) 2329 2329 - for i = 2, #parts do 2330 2330 - if utils["valid-lua-identifier?"](parts[i]) then 2331 2331 - if (parts["multi-sym-method-call"] and (i == #parts)) then 2332 2332 - ret = (ret .. ":" .. parts[i]) 2333 2333 - else 2334 2334 - ret = (ret .. "." .. parts[i]) 2335 2335 - end 2336 2336 - else 2337 2337 - ret = (ret .. "[" .. serialize_string(parts[i]) .. "]") 2338 2338 - end 2339 2339 - end 2340 2340 - return ret 2341 2341 - end 2342 2342 - local function next_append() 2343 2343 - utils.root.scope["gensym-append"] = ((utils.root.scope["gensym-append"] or 0) + 1) 2344 2344 - return ("_" .. utils.root.scope["gensym-append"] .. "_") 2345 2345 - end 2346 2346 - local function gensym(scope, _3fbase, _3fsuffix) 2347 2347 - local mangling = ((_3fbase or "") .. next_append() .. (_3fsuffix or "")) 2348 2348 - while scope.unmanglings[mangling] do 2349 2349 - mangling = ((_3fbase or "") .. next_append() .. (_3fsuffix or "")) 2350 2350 - end 2351 2351 - scope.unmanglings[mangling] = (_3fbase or true) 2352 2352 - do end (scope.gensyms)[mangling] = true 2353 2353 - return mangling 2354 2354 - end 2355 2355 - local function combine_auto_gensym(parts, first) 2356 2356 - parts[1] = first 2357 2357 - local last = table.remove(parts) 2358 2358 - local last2 = table.remove(parts) 2359 2359 - local last_joiner = ((parts["multi-sym-method-call"] and ":") or ".") 2360 2360 - table.insert(parts, (last2 .. last_joiner .. last)) 2361 2361 - return table.concat(parts, ".") 2362 2362 - end 2363 2363 - local function autogensym(base, scope) 2364 2364 - local _276_ = utils["multi-sym?"](base) 2365 2365 - if (nil ~= _276_) then 2366 2366 - local parts = _276_ 2367 2367 - return combine_auto_gensym(parts, autogensym(parts[1], scope)) 2368 2368 - elseif true then 2369 2369 - local _ = _276_ 2370 2370 - local function _277_() 2371 2371 - local mangling = gensym(scope, base:sub(1, ( - 2)), "auto") 2372 2372 - do end (scope.autogensyms)[base] = mangling 2373 2373 - return mangling 2374 2374 - end 2375 2375 - return (scope.autogensyms[base] or _277_()) 2376 2376 - else 2377 2377 - return nil 2378 2378 - end 2379 2379 - end 2380 2380 - local function check_binding_valid(symbol, scope, ast, _3fopts) 2381 2381 - local name = tostring(symbol) 2382 2382 - local macro_3f 2383 2383 - do 2384 2384 - local t_279_ = _3fopts 2385 2385 - if (nil ~= t_279_) then 2386 2386 - t_279_ = (t_279_)["macro?"] 2387 2387 - else 2388 2388 - end 2389 2389 - macro_3f = t_279_ 2390 2390 - end 2391 2391 - assert_compile(not name:find("&"), "invalid character: &") 2392 2392 - assert_compile(not name:find("^%."), "invalid character: .") 2393 2393 - assert_compile(not (scope.specials[name] or (not macro_3f and scope.macros[name])), ("local %s was overshadowed by a special form or macro"):format(name), ast) 2394 2394 - return assert_compile(not utils["quoted?"](symbol), string.format("macro tried to bind %s without gensym", name), symbol) 2395 2395 - end 2396 2396 - local function declare_local(symbol, meta, scope, ast, _3ftemp_manglings) 2397 2397 - check_binding_valid(symbol, scope, ast) 2398 2398 - local name = tostring(symbol) 2399 2399 - assert_compile(not utils["multi-sym?"](name), ("unexpected multi symbol " .. name), ast) 2400 2400 - do end (scope.symmeta)[name] = meta 2401 2401 - return local_mangling(name, scope, ast, _3ftemp_manglings) 2402 2402 - end 2403 2403 - local function hashfn_arg_name(name, multi_sym_parts, scope) 2404 2404 - if not scope.hashfn then 2405 2405 - return nil 2406 2406 - elseif (name == "$") then 2407 2407 - return "$1" 2408 2408 - elseif multi_sym_parts then 2409 2409 - if (multi_sym_parts and (multi_sym_parts[1] == "$")) then 2410 2410 - multi_sym_parts[1] = "$1" 2411 2411 - else 2412 2412 - end 2413 2413 - return table.concat(multi_sym_parts, ".") 2414 2414 - else 2415 2415 - return nil 2416 2416 - end 2417 2417 - end 2418 2418 - local function symbol_to_expression(symbol, scope, _3freference_3f) 2419 2419 - utils.hook("symbol-to-expression", symbol, scope, _3freference_3f) 2420 2420 - local name = symbol[1] 2421 2421 - local multi_sym_parts = utils["multi-sym?"](name) 2422 2422 - local name0 = (hashfn_arg_name(name, multi_sym_parts, scope) or name) 2423 2423 - local parts = (multi_sym_parts or {name0}) 2424 2424 - local etype = (((1 < #parts) and "expression") or "sym") 2425 2425 - local local_3f = scope.manglings[parts[1]] 2426 2426 - if (local_3f and scope.symmeta[parts[1]]) then 2427 2427 - scope.symmeta[parts[1]]["used"] = true 2428 2428 - else 2429 2429 - end 2430 2430 - assert_compile(not scope.macros[parts[1]], "tried to reference a macro at runtime", symbol) 2431 2431 - assert_compile((not scope.specials[parts[1]] or ("require" == parts[1])), "tried to reference a special form at runtime", symbol) 2432 2432 - assert_compile((not _3freference_3f or local_3f or ("_ENV" == parts[1]) or global_allowed_3f(parts[1])), ("unknown identifier in strict mode: " .. tostring(parts[1])), symbol) 2433 2433 - if (allowed_globals and not local_3f and scope.parent) then 2434 2434 - scope.parent.refedglobals[parts[1]] = true 2435 2435 - else 2436 2436 - end 2437 2437 - return utils.expr(combine_parts(parts, scope), etype) 2438 2438 - end 2439 2439 - local function emit(chunk, out, _3fast) 2440 2440 - if (type(out) == "table") then 2441 2441 - return table.insert(chunk, out) 2442 2442 - else 2443 2443 - return table.insert(chunk, {ast = _3fast, leaf = out}) 2444 2444 - end 2445 2445 - end 2446 2446 - local function peephole(chunk) 2447 2447 - if chunk.leaf then 2448 2448 - return chunk 2449 2449 - elseif ((3 <= #chunk) and (chunk[(#chunk - 2)].leaf == "do") and not chunk[(#chunk - 1)].leaf and (chunk[#chunk].leaf == "end")) then 2450 2450 - local kid = peephole(chunk[(#chunk - 1)]) 2451 2451 - local new_chunk = {ast = chunk.ast} 2452 2452 - for i = 1, (#chunk - 3) do 2453 2453 - table.insert(new_chunk, peephole(chunk[i])) 2454 2454 - end 2455 2455 - for i = 1, #kid do 2456 2456 - table.insert(new_chunk, kid[i]) 2457 2457 - end 2458 2458 - return new_chunk 2459 2459 - else 2460 2460 - return utils.map(chunk, peephole) 2461 2461 - end 2462 2462 - end 2463 2463 - local function flatten_chunk_correlated(main_chunk, options) 2464 2464 - local function flatten(chunk, out, last_line, file) 2465 2465 - local last_line0 = last_line 2466 2466 - if chunk.leaf then 2467 2467 - out[last_line0] = ((out[last_line0] or "") .. " " .. chunk.leaf) 2468 2468 - else 2469 2469 - for _, subchunk in ipairs(chunk) do 2470 2470 - if (subchunk.leaf or (0 < #subchunk)) then 2471 2471 - local source = utils["ast-source"](subchunk.ast) 2472 2472 - if (file == source.filename) then 2473 2473 - last_line0 = math.max(last_line0, (source.line or 0)) 2474 2474 - else 2475 2475 - end 2476 2476 - last_line0 = flatten(subchunk, out, last_line0, file) 2477 2477 - else 2478 2478 - end 2479 2479 - end 2480 2480 - end 2481 2481 - return last_line0 2482 2482 - end 2483 2483 - local out = {} 2484 2484 - local last = flatten(main_chunk, out, 1, options.filename) 2485 2485 - for i = 1, last do 2486 2486 - if (out[i] == nil) then 2487 2487 - out[i] = "" 2488 2488 - else 2489 2489 - end 2490 2490 - end 2491 2491 - return table.concat(out, "\n") 2492 2492 - end 2493 2493 - local function flatten_chunk(file_sourcemap, chunk, tab, depth) 2494 2494 - if chunk.leaf then 2495 2495 - local _let_291_ = utils["ast-source"](chunk.ast) 2496 2496 - local filename = _let_291_["filename"] 2497 2497 - local line = _let_291_["line"] 2498 2498 - table.insert(file_sourcemap, {filename, line}) 2499 2499 - return chunk.leaf 2500 2500 - else 2501 2501 - local tab0 2502 2502 - do 2503 2503 - local _292_ = tab 2504 2504 - if (_292_ == true) then 2505 2505 - tab0 = " " 2506 2506 - elseif (_292_ == false) then 2507 2507 - tab0 = "" 2508 2508 - elseif (_292_ == tab) then 2509 2509 - tab0 = tab 2510 2510 - elseif (_292_ == nil) then 2511 2511 - tab0 = "" 2512 2512 - else 2513 2513 - tab0 = nil 2514 2514 - end 2515 2515 - end 2516 2516 - local function parter(c) 2517 2517 - if (c.leaf or (0 < #c)) then 2518 2518 - local sub = flatten_chunk(file_sourcemap, c, tab0, (depth + 1)) 2519 2519 - if (0 < depth) then 2520 2520 - return (tab0 .. sub:gsub("\n", ("\n" .. tab0))) 2521 2521 - else 2522 2522 - return sub 2523 2523 - end 2524 2524 - else 2525 2525 - return nil 2526 2526 - end 2527 2527 - end 2528 2528 - return table.concat(utils.map(chunk, parter), "\n") 2529 2529 - end 2530 2530 - end 2531 2531 - local sourcemap = {} 2532 2532 - local function make_short_src(source) 2533 2533 - local source0 = source:gsub("\n", " ") 2534 2534 - if (#source0 <= 49) then 2535 2535 - return ("[fennel \"" .. source0 .. "\"]") 2536 2536 - else 2537 2537 - return ("[fennel \"" .. source0:sub(1, 46) .. "...\"]") 2538 2538 - end 2539 2539 - end 2540 2540 - local function flatten(chunk, options) 2541 2541 - local chunk0 = peephole(chunk) 2542 2542 - if options.correlate then 2543 2543 - return flatten_chunk_correlated(chunk0, options), {} 2544 2544 - else 2545 2545 - local file_sourcemap = {} 2546 2546 - local src = flatten_chunk(file_sourcemap, chunk0, options.indent, 0) 2547 2547 - file_sourcemap.short_src = (options.filename or make_short_src((options.source or src))) 2548 2548 - if options.filename then 2549 2549 - file_sourcemap.key = ("@" .. options.filename) 2550 2550 - else 2551 2551 - file_sourcemap.key = src 2552 2552 - end 2553 2553 - sourcemap[file_sourcemap.key] = file_sourcemap 2554 2554 - return src, file_sourcemap 2555 2555 - end 2556 2556 - end 2557 2557 - local function make_metadata() 2558 2558 - local function _300_(self, tgt, key) 2559 2559 - if self[tgt] then 2560 2560 - return self[tgt][key] 2561 2561 - else 2562 2562 - return nil 2563 2563 - end 2564 2564 - end 2565 2565 - local function _302_(self, tgt, key, value) 2566 2566 - self[tgt] = (self[tgt] or {}) 2567 2567 - do end (self[tgt])[key] = value 2568 2568 - return tgt 2569 2569 - end 2570 2570 - local function _303_(self, tgt, ...) 2571 2571 - local kv_len = select("#", ...) 2572 2572 - local kvs = {...} 2573 2573 - if ((kv_len % 2) ~= 0) then 2574 2574 - error("metadata:setall() expected even number of k/v pairs") 2575 2575 - else 2576 2576 - end 2577 2577 - self[tgt] = (self[tgt] or {}) 2578 2578 - for i = 1, kv_len, 2 do 2579 2579 - self[tgt][kvs[i]] = kvs[(i + 1)] 2580 2580 - end 2581 2581 - return tgt 2582 2582 - end 2583 2583 - return setmetatable({}, {__index = {get = _300_, set = _302_, setall = _303_}, __mode = "k"}) 2584 2584 - end 2585 2585 - local function exprs1(exprs) 2586 2586 - return table.concat(utils.map(exprs, tostring), ", ") 2587 2587 - end 2588 2588 - local function keep_side_effects(exprs, chunk, start, ast) 2589 2589 - local start0 = (start or 1) 2590 2590 - for j = start0, #exprs do 2591 2591 - local se = exprs[j] 2592 2592 - if ((se.type == "expression") and (se[1] ~= "nil")) then 2593 2593 - emit(chunk, string.format("do local _ = %s end", tostring(se)), ast) 2594 2594 - elseif (se.type == "statement") then 2595 2595 - local code = tostring(se) 2596 2596 - local disambiguated 2597 2597 - if (code:byte() == 40) then 2598 2598 - disambiguated = ("do end " .. code) 2599 2599 - else 2600 2600 - disambiguated = code 2601 2601 - end 2602 2602 - emit(chunk, disambiguated, ast) 2603 2603 - else 2604 2604 - end 2605 2605 - end 2606 2606 - return nil 2607 2607 - end 2608 2608 - local function handle_compile_opts(exprs, parent, opts, ast) 2609 2609 - if opts.nval then 2610 2610 - local n = opts.nval 2611 2611 - local len = #exprs 2612 2612 - if (n ~= len) then 2613 2613 - if (n < len) then 2614 2614 - keep_side_effects(exprs, parent, (n + 1), ast) 2615 2615 - for i = (n + 1), len do 2616 2616 - exprs[i] = nil 2617 2617 - end 2618 2618 - else 2619 2619 - for i = (#exprs + 1), n do 2620 2620 - exprs[i] = utils.expr("nil", "literal") 2621 2621 - end 2622 2622 - end 2623 2623 - else 2624 2624 - end 2625 2625 - else 2626 2626 - end 2627 2627 - if opts.tail then 2628 2628 - emit(parent, string.format("return %s", exprs1(exprs)), ast) 2629 2629 - else 2630 2630 - end 2631 2631 - if opts.target then 2632 2632 - local result = exprs1(exprs) 2633 2633 - local function _311_() 2634 2634 - if (result == "") then 2635 2635 - return "nil" 2636 2636 - else 2637 2637 - return result 2638 2638 - end 2639 2639 - end 2640 2640 - emit(parent, string.format("%s = %s", opts.target, _311_()), ast) 2641 2641 - else 2642 2642 - end 2643 2643 - if (opts.tail or opts.target) then 2644 2644 - return {returned = true} 2645 2645 - else 2646 2646 - local _313_ = exprs 2647 2647 - _313_["returned"] = true 2648 2648 - return _313_ 2649 2649 - end 2650 2650 - end 2651 2651 - local function find_macro(ast, scope) 2652 2652 - local macro_2a 2653 2653 - do 2654 2654 - local _315_ = utils["sym?"](ast[1]) 2655 2655 - if (_315_ ~= nil) then 2656 2656 - local _316_ = tostring(_315_) 2657 2657 - if (_316_ ~= nil) then 2658 2658 - macro_2a = scope.macros[_316_] 2659 2659 - else 2660 2660 - macro_2a = _316_ 2661 2661 - end 2662 2662 - else 2663 2663 - macro_2a = _315_ 2664 2664 - end 2665 2665 - end 2666 2666 - local multi_sym_parts = utils["multi-sym?"](ast[1]) 2667 2667 - if (not macro_2a and multi_sym_parts) then 2668 2668 - local nested_macro = utils["get-in"](scope.macros, multi_sym_parts) 2669 2669 - assert_compile((not scope.macros[multi_sym_parts[1]] or (type(nested_macro) == "function")), "macro not found in imported macro module", ast) 2670 2670 - return nested_macro 2671 2671 - else 2672 2672 - return macro_2a 2673 2673 - end 2674 2674 - end 2675 2675 - local function propagate_trace_info(_320_, _index, node) 2676 2676 - local _arg_321_ = _320_ 2677 2677 - local filename = _arg_321_["filename"] 2678 2678 - local line = _arg_321_["line"] 2679 2679 - local bytestart = _arg_321_["bytestart"] 2680 2680 - local byteend = _arg_321_["byteend"] 2681 2681 - do 2682 2682 - local src = utils["ast-source"](node) 2683 2683 - if (("table" == type(node)) and (filename ~= src.filename)) then 2684 2684 - src.filename, src.line, src["from-macro?"] = filename, line, true 2685 2685 - src.bytestart, src.byteend = bytestart, byteend 2686 2686 - else 2687 2687 - end 2688 2688 - end 2689 2689 - return ("table" == type(node)) 2690 2690 - end 2691 2691 - local function max_n(t) 2692 2692 - local n = 0 2693 2693 - for k in pairs(t) do 2694 2694 - if ("number" == type(k)) then 2695 2695 - n = math.max(k, n) 2696 2696 - else 2697 2697 - end 2698 2698 - end 2699 2699 - return n 2700 2700 - end 2701 2701 - local function quote_literal_nils(index, node, parent) 2702 2702 - if (parent and utils["list?"](parent)) then 2703 2703 - for i = 1, max_n(parent) do 2704 2704 - local _324_ = parent[i] 2705 2705 - if (_324_ == nil) then 2706 2706 - parent[i] = utils.sym("nil") 2707 2707 - else 2708 2708 - end 2709 2709 - end 2710 2710 - else 2711 2711 - end 2712 2712 - return index, node, parent 2713 2713 - end 2714 2714 - local function comp(f, g) 2715 2715 - local function _327_(...) 2716 2716 - return f(g(...)) 2717 2717 - end 2718 2718 - return _327_ 2719 2719 - end 2720 2720 - local function built_in_3f(m) 2721 2721 - local found_3f = false 2722 2722 - for _, f in pairs(scopes.global.macros) do 2723 2723 - if found_3f then break end 2724 2724 - found_3f = (f == m) 2725 2725 - end 2726 2726 - return found_3f 2727 2727 - end 2728 2728 - local function macroexpand_2a(ast, scope, _3fonce) 2729 2729 - local _328_ 2730 2730 - if utils["list?"](ast) then 2731 2731 - _328_ = find_macro(ast, scope) 2732 2732 - else 2733 2733 - _328_ = nil 2734 2734 - end 2735 2735 - if (_328_ == false) then 2736 2736 - return ast 2737 2737 - elseif (nil ~= _328_) then 2738 2738 - local macro_2a = _328_ 2739 2739 - local old_scope = scopes.macro 2740 2740 - local _ 2741 2741 - scopes.macro = scope 2742 2742 - _ = nil 2743 2743 - local ok, transformed = nil, nil 2744 2744 - local function _330_() 2745 2745 - return macro_2a(unpack(ast, 2)) 2746 2746 - end 2747 2747 - local function _331_() 2748 2748 - if built_in_3f(macro_2a) then 2749 2749 - return tostring 2750 2750 - else 2751 2751 - return debug.traceback 2752 2752 - end 2753 2753 - end 2754 2754 - ok, transformed = xpcall(_330_, _331_()) 2755 2755 - local _333_ 2756 2756 - do 2757 2757 - local _332_ = ast 2758 2758 - local function _334_(...) 2759 2759 - return propagate_trace_info(_332_, ...) 2760 2760 - end 2761 2761 - _333_ = _334_ 2762 2762 - end 2763 2763 - utils["walk-tree"](transformed, comp(_333_, quote_literal_nils)) 2764 2764 - scopes.macro = old_scope 2765 2765 - assert_compile(ok, transformed, ast) 2766 2766 - if (_3fonce or not transformed) then 2767 2767 - return transformed 2768 2768 - else 2769 2769 - return macroexpand_2a(transformed, scope) 2770 2770 - end 2771 2771 - elseif true then 2772 2772 - local _ = _328_ 2773 2773 - return ast 2774 2774 - else 2775 2775 - return nil 2776 2776 - end 2777 2777 - end 2778 2778 - local function compile_special(ast, scope, parent, opts, special) 2779 2779 - local exprs = (special(ast, scope, parent, opts) or utils.expr("nil", "literal")) 2780 2780 - local exprs0 2781 2781 - if ("table" ~= type(exprs)) then 2782 2782 - exprs0 = utils.expr(exprs, "expression") 2783 2783 - else 2784 2784 - exprs0 = exprs 2785 2785 - end 2786 2786 - local exprs2 2787 2787 - if utils["expr?"](exprs0) then 2788 2788 - exprs2 = {exprs0} 2789 2789 - else 2790 2790 - exprs2 = exprs0 2791 2791 - end 2792 2792 - if not exprs2.returned then 2793 2793 - return handle_compile_opts(exprs2, parent, opts, ast) 2794 2794 - elseif (opts.tail or opts.target) then 2795 2795 - return {returned = true} 2796 2796 - else 2797 2797 - return exprs2 2798 2798 - end 2799 2799 - end 2800 2800 - local function compile_function_call(ast, scope, parent, opts, compile1, len) 2801 2801 - local fargs = {} 2802 2802 - local fcallee = (compile1(ast[1], scope, parent, {nval = 1}))[1] 2803 2803 - assert_compile((utils["sym?"](ast[1]) or utils["list?"](ast[1]) or ("string" == type(ast[1]))), ("cannot call literal value " .. tostring(ast[1])), ast) 2804 2804 - for i = 2, len do 2805 2805 - local subexprs 2806 2806 - local _340_ 2807 2807 - if (i ~= len) then 2808 2808 - _340_ = 1 2809 2809 - else 2810 2810 - _340_ = nil 2811 2811 - end 2812 2812 - subexprs = compile1(ast[i], scope, parent, {nval = _340_}) 2813 2813 - table.insert(fargs, subexprs[1]) 2814 2814 - if (i == len) then 2815 2815 - for j = 2, #subexprs do 2816 2816 - table.insert(fargs, subexprs[j]) 2817 2817 - end 2818 2818 - else 2819 2819 - keep_side_effects(subexprs, parent, 2, ast[i]) 2820 2820 - end 2821 2821 - end 2822 2822 - local pat 2823 2823 - if ("string" == type(ast[1])) then 2824 2824 - pat = "(%s)(%s)" 2825 2825 - else 2826 2826 - pat = "%s(%s)" 2827 2827 - end 2828 2828 - local call = string.format(pat, tostring(fcallee), exprs1(fargs)) 2829 2829 - return handle_compile_opts({utils.expr(call, "statement")}, parent, opts, ast) 2830 2830 - end 2831 2831 - local function compile_call(ast, scope, parent, opts, compile1) 2832 2832 - utils.hook("call", ast, scope) 2833 2833 - local len = #ast 2834 2834 - local first = ast[1] 2835 2835 - local multi_sym_parts = utils["multi-sym?"](first) 2836 2836 - local special = (utils["sym?"](first) and scope.specials[tostring(first)]) 2837 2837 - assert_compile((0 < len), "expected a function, macro, or special to call", ast) 2838 2838 - if special then 2839 2839 - return compile_special(ast, scope, parent, opts, special) 2840 2840 - elseif (multi_sym_parts and multi_sym_parts["multi-sym-method-call"]) then 2841 2841 - local table_with_method = table.concat({unpack(multi_sym_parts, 1, (#multi_sym_parts - 1))}, ".") 2842 2842 - local method_to_call = multi_sym_parts[#multi_sym_parts] 2843 2843 - local new_ast = utils.list(utils.sym(":", ast), utils.sym(table_with_method, ast), method_to_call, select(2, unpack(ast))) 2844 2844 - return compile1(new_ast, scope, parent, opts) 2845 2845 - else 2846 2846 - return compile_function_call(ast, scope, parent, opts, compile1, len) 2847 2847 - end 2848 2848 - end 2849 2849 - local function compile_varg(ast, scope, parent, opts) 2850 2850 - local _345_ 2851 2851 - if scope.hashfn then 2852 2852 - _345_ = "use $... in hashfn" 2853 2853 - else 2854 2854 - _345_ = "unexpected vararg" 2855 2855 - end 2856 2856 - assert_compile(scope.vararg, _345_, ast) 2857 2857 - return handle_compile_opts({utils.expr("...", "varg")}, parent, opts, ast) 2858 2858 - end 2859 2859 - local function compile_sym(ast, scope, parent, opts) 2860 2860 - local multi_sym_parts = utils["multi-sym?"](ast) 2861 2861 - assert_compile(not (multi_sym_parts and multi_sym_parts["multi-sym-method-call"]), "multisym method calls may only be in call position", ast) 2862 2862 - local e 2863 2863 - if (ast[1] == "nil") then 2864 2864 - e = utils.expr("nil", "literal") 2865 2865 - else 2866 2866 - e = symbol_to_expression(ast, scope, true) 2867 2867 - end 2868 2868 - return handle_compile_opts({e}, parent, opts, ast) 2869 2869 - end 2870 2870 - local function serialize_number(n) 2871 2871 - local _348_ = string.gsub(tostring(n), ",", ".") 2872 2872 - return _348_ 2873 2873 - end 2874 2874 - local function compile_scalar(ast, _scope, parent, opts) 2875 2875 - local serialize 2876 2876 - do 2877 2877 - local _349_ = type(ast) 2878 2878 - if (_349_ == "nil") then 2879 2879 - serialize = tostring 2880 2880 - elseif (_349_ == "boolean") then 2881 2881 - serialize = tostring 2882 2882 - elseif (_349_ == "string") then 2883 2883 - serialize = serialize_string 2884 2884 - elseif (_349_ == "number") then 2885 2885 - serialize = serialize_number 2886 2886 - else 2887 2887 - serialize = nil 2888 2888 - end 2889 2889 - end 2890 2890 - return handle_compile_opts({utils.expr(serialize(ast), "literal")}, parent, opts) 2891 2891 - end 2892 2892 - local function compile_table(ast, scope, parent, opts, compile1) 2893 2893 - local buffer = {} 2894 2894 - local function write_other_values(k) 2895 2895 - if ((type(k) ~= "number") or (math.floor(k) ~= k) or (k < 1) or (#ast < k)) then 2896 2896 - if ((type(k) == "string") and utils["valid-lua-identifier?"](k)) then 2897 2897 - return {k, k} 2898 2898 - else 2899 2899 - local _let_351_ = compile1(k, scope, parent, {nval = 1}) 2900 2900 - local compiled = _let_351_[1] 2901 2901 - local kstr = ("[" .. tostring(compiled) .. "]") 2902 2902 - return {kstr, k} 2903 2903 - end 2904 2904 - else 2905 2905 - return nil 2906 2906 - end 2907 2907 - end 2908 2908 - do 2909 2909 - local keys 2910 2910 - do 2911 2911 - local tbl_14_auto = {} 2912 2912 - local i_15_auto = #tbl_14_auto 2913 2913 - for k, v in utils.stablepairs(ast) do 2914 2914 - local val_16_auto = write_other_values(k, v) 2915 2915 - if (nil ~= val_16_auto) then 2916 2916 - i_15_auto = (i_15_auto + 1) 2917 2917 - do end (tbl_14_auto)[i_15_auto] = val_16_auto 2918 2918 - else 2919 2919 - end 2920 2920 - end 2921 2921 - keys = tbl_14_auto 2922 2922 - end 2923 2923 - local function _357_(_355_) 2924 2924 - local _arg_356_ = _355_ 2925 2925 - local k1 = _arg_356_[1] 2926 2926 - local k2 = _arg_356_[2] 2927 2927 - local _let_358_ = compile1(ast[k2], scope, parent, {nval = 1}) 2928 2928 - local v = _let_358_[1] 2929 2929 - return string.format("%s = %s", k1, tostring(v)) 2930 2930 - end 2931 2931 - utils.map(keys, _357_, buffer) 2932 2932 - end 2933 2933 - for i = 1, #ast do 2934 2934 - local nval = ((i ~= #ast) and 1) 2935 2935 - table.insert(buffer, exprs1(compile1(ast[i], scope, parent, {nval = nval}))) 2936 2936 - end 2937 2937 - return handle_compile_opts({utils.expr(("{" .. table.concat(buffer, ", ") .. "}"), "expression")}, parent, opts, ast) 2938 2938 - end 2939 2939 - local function compile1(ast, scope, parent, _3fopts) 2940 2940 - local opts = (_3fopts or {}) 2941 2941 - local ast0 = macroexpand_2a(ast, scope) 2942 2942 - if utils["list?"](ast0) then 2943 2943 - return compile_call(ast0, scope, parent, opts, compile1) 2944 2944 - elseif utils["varg?"](ast0) then 2945 2945 - return compile_varg(ast0, scope, parent, opts) 2946 2946 - elseif utils["sym?"](ast0) then 2947 2947 - return compile_sym(ast0, scope, parent, opts) 2948 2948 - elseif (type(ast0) == "table") then 2949 2949 - return compile_table(ast0, scope, parent, opts, compile1) 2950 2950 - elseif ((type(ast0) == "nil") or (type(ast0) == "boolean") or (type(ast0) == "number") or (type(ast0) == "string")) then 2951 2951 - return compile_scalar(ast0, scope, parent, opts) 2952 2952 - else 2953 2953 - return assert_compile(false, ("could not compile value of type " .. type(ast0)), ast0) 2954 2954 - end 2955 2955 - end 2956 2956 - local function destructure(to, from, ast, scope, parent, opts) 2957 2957 - local opts0 = (opts or {}) 2958 2958 - local _let_360_ = opts0 2959 2959 - local isvar = _let_360_["isvar"] 2960 2960 - local declaration = _let_360_["declaration"] 2961 2961 - local forceglobal = _let_360_["forceglobal"] 2962 2962 - local forceset = _let_360_["forceset"] 2963 2963 - local symtype = _let_360_["symtype"] 2964 2964 - local symtype0 = ("_" .. (symtype or "dst")) 2965 2965 - local setter 2966 2966 - if declaration then 2967 2967 - setter = "local %s = %s" 2968 2968 - else 2969 2969 - setter = "%s = %s" 2970 2970 - end 2971 2971 - local new_manglings = {} 2972 2972 - local function getname(symbol, up1) 2973 2973 - local raw = symbol[1] 2974 2974 - assert_compile(not (opts0.nomulti and utils["multi-sym?"](raw)), ("unexpected multi symbol " .. raw), up1) 2975 2975 - if declaration then 2976 2976 - return declare_local(symbol, nil, scope, symbol, new_manglings) 2977 2977 - else 2978 2978 - local parts = (utils["multi-sym?"](raw) or {raw}) 2979 2979 - local meta = scope.symmeta[parts[1]] 2980 2980 - assert_compile(not raw:find(":"), "cannot set method sym", symbol) 2981 2981 - if ((#parts == 1) and not forceset) then 2982 2982 - assert_compile(not (forceglobal and meta), string.format("global %s conflicts with local", tostring(symbol)), symbol) 2983 2983 - assert_compile(not (meta and not meta.var), ("expected var " .. raw), symbol) 2984 2984 - assert_compile((meta or not opts0.noundef), ("expected local " .. parts[1]), symbol) 2985 2985 - else 2986 2986 - end 2987 2987 - if forceglobal then 2988 2988 - assert_compile(not scope.symmeta[scope.unmanglings[raw]], ("global " .. raw .. " conflicts with local"), symbol) 2989 2989 - do end (scope.manglings)[raw] = global_mangling(raw) 2990 2990 - do end (scope.unmanglings)[global_mangling(raw)] = raw 2991 2991 - if allowed_globals then 2992 2992 - table.insert(allowed_globals, raw) 2993 2993 - else 2994 2994 - end 2995 2995 - else 2996 2996 - end 2997 2997 - return symbol_to_expression(symbol, scope)[1] 2998 2998 - end 2999 2999 - end 3000 3000 - local function compile_top_target(lvalues) 3001 3001 - local inits 3002 3002 - local function _366_(_241) 3003 3003 - if scope.manglings[_241] then 3004 3004 - return _241 3005 3005 - else 3006 3006 - return "nil" 3007 3007 - end 3008 3008 - end 3009 3009 - inits = utils.map(lvalues, _366_) 3010 3010 - local init = table.concat(inits, ", ") 3011 3011 - local lvalue = table.concat(lvalues, ", ") 3012 3012 - local plast = parent[#parent] 3013 3013 - local plen = #parent 3014 3014 - local ret = compile1(from, scope, parent, {target = lvalue}) 3015 3015 - if declaration then 3016 3016 - for pi = plen, #parent do 3017 3017 - if (parent[pi] == plast) then 3018 3018 - plen = pi 3019 3019 - else 3020 3020 - end 3021 3021 - end 3022 3022 - if ((#parent == (plen + 1)) and parent[#parent].leaf) then 3023 3023 - parent[#parent]["leaf"] = ("local " .. parent[#parent].leaf) 3024 3024 - elseif (init == "nil") then 3025 3025 - table.insert(parent, (plen + 1), {ast = ast, leaf = ("local " .. lvalue)}) 3026 3026 - else 3027 3027 - table.insert(parent, (plen + 1), {ast = ast, leaf = ("local " .. lvalue .. " = " .. init)}) 3028 3028 - end 3029 3029 - else 3030 3030 - end 3031 3031 - return ret 3032 3032 - end 3033 3033 - local function destructure_sym(left, rightexprs, up1, top_3f) 3034 3034 - local lname = getname(left, up1) 3035 3035 - check_binding_valid(left, scope, left) 3036 3036 - if top_3f then 3037 3037 - compile_top_target({lname}) 3038 3038 - else 3039 3039 - emit(parent, setter:format(lname, exprs1(rightexprs)), left) 3040 3040 - end 3041 3041 - if declaration then 3042 3042 - scope.symmeta[tostring(left)] = {var = isvar} 3043 3043 - return nil 3044 3044 - else 3045 3045 - return nil 3046 3046 - end 3047 3047 - end 3048 3048 - local unpack_fn = "function (t, k, e)\n local mt = getmetatable(t)\n if 'table' == type(mt) and mt.__fennelrest then\n return mt.__fennelrest(t, k)\n elseif e then\n local rest = {}\n for k, v in pairs(t) do\n if not e[k] then rest[k] = v end\n end\n return rest\n else\n return {(table.unpack or unpack)(t, k)}\n end\n end" 3049 3049 - local function destructure_kv_rest(s, v, left, excluded_keys, destructure1) 3050 3050 - local exclude_str 3051 3051 - local _373_ 3052 3052 - do 3053 3053 - local tbl_14_auto = {} 3054 3054 - local i_15_auto = #tbl_14_auto 3055 3055 - for _, k in ipairs(excluded_keys) do 3056 3056 - local val_16_auto = string.format("[%s] = true", serialize_string(k)) 3057 3057 - if (nil ~= val_16_auto) then 3058 3058 - i_15_auto = (i_15_auto + 1) 3059 3059 - do end (tbl_14_auto)[i_15_auto] = val_16_auto 3060 3060 - else 3061 3061 - end 3062 3062 - end 3063 3063 - _373_ = tbl_14_auto 3064 3064 - end 3065 3065 - exclude_str = table.concat(_373_, ", ") 3066 3066 - local subexpr = utils.expr(string.format(string.gsub(("(" .. unpack_fn .. ")(%s, %s, {%s})"), "\n%s*", " "), s, tostring(v), exclude_str), "expression") 3067 3067 - return destructure1(v, {subexpr}, left) 3068 3068 - end 3069 3069 - local function destructure_rest(s, k, left, destructure1) 3070 3070 - local unpack_str = ("(" .. unpack_fn .. ")(%s, %s)") 3071 3071 - local formatted = string.format(string.gsub(unpack_str, "\n%s*", " "), s, k) 3072 3072 - local subexpr = utils.expr(formatted, "expression") 3073 3073 - assert_compile((utils["sequence?"](left) and (nil == left[(k + 2)])), "expected rest argument before last parameter", left) 3074 3074 - return destructure1(left[(k + 1)], {subexpr}, left) 3075 3075 - end 3076 3076 - local function destructure_table(left, rightexprs, top_3f, destructure1) 3077 3077 - local s = gensym(scope, symtype0) 3078 3078 - local right 3079 3079 - do 3080 3080 - local _375_ 3081 3081 - if top_3f then 3082 3082 - _375_ = exprs1(compile1(from, scope, parent)) 3083 3083 - else 3084 3084 - _375_ = exprs1(rightexprs) 3085 3085 - end 3086 3086 - if (_375_ == "") then 3087 3087 - right = "nil" 3088 3088 - elseif (nil ~= _375_) then 3089 3089 - local right0 = _375_ 3090 3090 - right = right0 3091 3091 - else 3092 3092 - right = nil 3093 3093 - end 3094 3094 - end 3095 3095 - local excluded_keys = {} 3096 3096 - emit(parent, string.format("local %s = %s", s, right), left) 3097 3097 - for k, v in utils.stablepairs(left) do 3098 3098 - if not (("number" == type(k)) and tostring(left[(k - 1)]):find("^&")) then 3099 3099 - if (utils["sym?"](k) and (tostring(k) == "&")) then 3100 3100 - destructure_kv_rest(s, v, left, excluded_keys, destructure1) 3101 3101 - elseif (utils["sym?"](v) and (tostring(v) == "&")) then 3102 3102 - destructure_rest(s, k, left, destructure1) 3103 3103 - elseif (utils["sym?"](k) and (tostring(k) == "&as")) then 3104 3104 - destructure_sym(v, {utils.expr(tostring(s))}, left) 3105 3105 - elseif (utils["sequence?"](left) and (tostring(v) == "&as")) then 3106 3106 - local _, next_sym, trailing = select(k, unpack(left)) 3107 3107 - assert_compile((nil == trailing), "expected &as argument before last parameter", left) 3108 3108 - destructure_sym(next_sym, {utils.expr(tostring(s))}, left) 3109 3109 - else 3110 3110 - local key 3111 3111 - if (type(k) == "string") then 3112 3112 - key = serialize_string(k) 3113 3113 - else 3114 3114 - key = k 3115 3115 - end 3116 3116 - local subexpr = utils.expr(string.format("%s[%s]", s, key), "expression") 3117 3117 - if (type(k) == "string") then 3118 3118 - table.insert(excluded_keys, k) 3119 3119 - else 3120 3120 - end 3121 3121 - destructure1(v, {subexpr}, left) 3122 3122 - end 3123 3123 - else 3124 3124 - end 3125 3125 - end 3126 3126 - return nil 3127 3127 - end 3128 3128 - local function destructure_values(left, up1, top_3f, destructure1) 3129 3129 - local left_names, tables = {}, {} 3130 3130 - for i, name in ipairs(left) do 3131 3131 - if utils["sym?"](name) then 3132 3132 - table.insert(left_names, getname(name, up1)) 3133 3133 - else 3134 3134 - local symname = gensym(scope, symtype0) 3135 3135 - table.insert(left_names, symname) 3136 3136 - do end (tables)[i] = {name, utils.expr(symname, "sym")} 3137 3137 - end 3138 3138 - end 3139 3139 - assert_compile(left[1], "must provide at least one value", left) 3140 3140 - assert_compile(top_3f, "can't nest multi-value destructuring", left) 3141 3141 - compile_top_target(left_names) 3142 3142 - if declaration then 3143 3143 - for _, sym in ipairs(left) do 3144 3144 - if utils["sym?"](sym) then 3145 3145 - scope.symmeta[tostring(sym)] = {var = isvar} 3146 3146 - else 3147 3147 - end 3148 3148 - end 3149 3149 - else 3150 3150 - end 3151 3151 - for _, pair in utils.stablepairs(tables) do 3152 3152 - destructure1(pair[1], {pair[2]}, left) 3153 3153 - end 3154 3154 - return nil 3155 3155 - end 3156 3156 - local function destructure1(left, rightexprs, up1, top_3f) 3157 3157 - if (utils["sym?"](left) and (left[1] ~= "nil")) then 3158 3158 - destructure_sym(left, rightexprs, up1, top_3f) 3159 3159 - elseif utils["table?"](left) then 3160 3160 - destructure_table(left, rightexprs, top_3f, destructure1) 3161 3161 - elseif utils["list?"](left) then 3162 3162 - destructure_values(left, up1, top_3f, destructure1) 3163 3163 - else 3164 3164 - assert_compile(false, string.format("unable to bind %s %s", type(left), tostring(left)), (((type((up1)[2]) == "table") and (up1)[2]) or up1)) 3165 3165 - end 3166 3166 - if top_3f then 3167 3167 - return {returned = true} 3168 3168 - else 3169 3169 - return nil 3170 3170 - end 3171 3171 - end 3172 3172 - local ret = destructure1(to, nil, ast, true) 3173 3173 - utils.hook("destructure", from, to, scope, opts0) 3174 3174 - apply_manglings(scope, new_manglings, ast) 3175 3175 - return ret 3176 3176 - end 3177 3177 - local function require_include(ast, scope, parent, opts) 3178 3178 - opts.fallback = function(e, no_warn) 3179 3179 - if (not no_warn and ("literal" == e.type)) then 3180 3180 - utils.warn(("include module not found, falling back to require: %s"):format(tostring(e))) 3181 3181 - else 3182 3182 - end 3183 3183 - return utils.expr(string.format("require(%s)", tostring(e)), "statement") 3184 3184 - end 3185 3185 - return scopes.global.specials.include(ast, scope, parent, opts) 3186 3186 - end 3187 3187 - local function compile_stream(strm, options) 3188 3188 - local opts = utils.copy(options) 3189 3189 - local old_globals = allowed_globals 3190 3190 - local scope = (opts.scope or make_scope(scopes.global)) 3191 3191 - local vals = {} 3192 3192 - local chunk = {} 3193 3193 - do end (function(tgt, m, ...) return tgt[m](tgt, ...) end)(utils.root, "set-reset") 3194 3194 - allowed_globals = opts.allowedGlobals 3195 3195 - if (opts.indent == nil) then 3196 3196 - opts.indent = " " 3197 3197 - else 3198 3198 - end 3199 3199 - if opts.requireAsInclude then 3200 3200 - scope.specials.require = require_include 3201 3201 - else 3202 3202 - end 3203 3203 - utils.root.chunk, utils.root.scope, utils.root.options = chunk, scope, opts 3204 3204 - for _, val in parser.parser(strm, opts.filename, opts) do 3205 3205 - table.insert(vals, val) 3206 3206 - end 3207 3207 - for i = 1, #vals do 3208 3208 - local exprs = compile1(vals[i], scope, chunk, {nval = (((i < #vals) and 0) or nil), tail = (i == #vals)}) 3209 3209 - keep_side_effects(exprs, chunk, nil, vals[i]) 3210 3210 - if (i == #vals) then 3211 3211 - utils.hook("chunk", vals[i], scope) 3212 3212 - else 3213 3213 - end 3214 3214 - end 3215 3215 - allowed_globals = old_globals 3216 3216 - utils.root.reset() 3217 3217 - return flatten(chunk, opts) 3218 3218 - end 3219 3219 - local function compile_string(str, opts) 3220 3220 - return compile_stream(parser["string-stream"](str), (opts or {})) 3221 3221 - end 3222 3222 - local function compile(ast, opts) 3223 3223 - local opts0 = utils.copy(opts) 3224 3224 - local old_globals = allowed_globals 3225 3225 - local chunk = {} 3226 3226 - local scope = (opts0.scope or make_scope(scopes.global)) 3227 3227 - do end (function(tgt, m, ...) return tgt[m](tgt, ...) end)(utils.root, "set-reset") 3228 3228 - allowed_globals = opts0.allowedGlobals 3229 3229 - if (opts0.indent == nil) then 3230 3230 - opts0.indent = " " 3231 3231 - else 3232 3232 - end 3233 3233 - if opts0.requireAsInclude then 3234 3234 - scope.specials.require = require_include 3235 3235 - else 3236 3236 - end 3237 3237 - utils.root.chunk, utils.root.scope, utils.root.options = chunk, scope, opts0 3238 3238 - local exprs = compile1(ast, scope, chunk, {tail = true}) 3239 3239 - keep_side_effects(exprs, chunk, nil, ast) 3240 3240 - utils.hook("chunk", ast, scope) 3241 3241 - allowed_globals = old_globals 3242 3242 - utils.root.reset() 3243 3243 - return flatten(chunk, opts0) 3244 3244 - end 3245 3245 - local function traceback_frame(info) 3246 3246 - if ((info.what == "C") and info.name) then 3247 3247 - return string.format(" [C]: in function '%s'", info.name) 3248 3248 - elseif (info.what == "C") then 3249 3249 - return " [C]: in ?" 3250 3250 - else 3251 3251 - local remap = sourcemap[info.source] 3252 3252 - if (remap and remap[info.currentline]) then 3253 3253 - if ((remap[info.currentline][1] or "unknown") ~= "unknown") then 3254 3254 - info.short_src = sourcemap[("@" .. remap[info.currentline][1])].short_src 3255 3255 - else 3256 3256 - info.short_src = remap.short_src 3257 3257 - end 3258 3258 - info.currentline = (remap[info.currentline][2] or -1) 3259 3259 - else 3260 3260 - end 3261 3261 - if (info.what == "Lua") then 3262 3262 - local function _395_() 3263 3263 - if info.name then 3264 3264 - return ("'" .. info.name .. "'") 3265 3265 - else 3266 3266 - return "?" 3267 3267 - end 3268 3268 - end 3269 3269 - return string.format(" %s:%d: in function %s", info.short_src, info.currentline, _395_()) 3270 3270 - elseif (info.short_src == "(tail call)") then 3271 3271 - return " (tail call)" 3272 3272 - else 3273 3273 - return string.format(" %s:%d: in main chunk", info.short_src, info.currentline) 3274 3274 - end 3275 3275 - end 3276 3276 - end 3277 3277 - local function traceback(_3fmsg, _3fstart) 3278 3278 - local msg = tostring((_3fmsg or "")) 3279 3279 - if ((msg:find("^Compile error") or msg:find("^Parse error")) and not utils["debug-on?"]("trace")) then 3280 3280 - return msg 3281 3281 - else 3282 3282 - local lines = {} 3283 3283 - if (msg:find(":%d+: Compile error") or msg:find(":%d+: Parse error")) then 3284 3284 - table.insert(lines, msg) 3285 3285 - else 3286 3286 - local newmsg = msg:gsub("^[^:]*:%d+:%s+", "runtime error: ") 3287 3287 - table.insert(lines, newmsg) 3288 3288 - end 3289 3289 - table.insert(lines, "stack traceback:") 3290 3290 - local done_3f, level = false, (_3fstart or 2) 3291 3291 - while not done_3f do 3292 3292 - do 3293 3293 - local _399_ = debug.getinfo(level, "Sln") 3294 3294 - if (_399_ == nil) then 3295 3295 - done_3f = true 3296 3296 - elseif (nil ~= _399_) then 3297 3297 - local info = _399_ 3298 3298 - table.insert(lines, traceback_frame(info)) 3299 3299 - else 3300 3300 - end 3301 3301 - end 3302 3302 - level = (level + 1) 3303 3303 - end 3304 3304 - return table.concat(lines, "\n") 3305 3305 - end 3306 3306 - end 3307 3307 - local function entry_transform(fk, fv) 3308 3308 - local function _402_(k, v) 3309 3309 - if (type(k) == "number") then 3310 3310 - return k, fv(v) 3311 3311 - else 3312 3312 - return fk(k), fv(v) 3313 3313 - end 3314 3314 - end 3315 3315 - return _402_ 3316 3316 - end 3317 3317 - local function mixed_concat(t, joiner) 3318 3318 - local seen = {} 3319 3319 - local ret, s = "", "" 3320 3320 - for k, v in ipairs(t) do 3321 3321 - table.insert(seen, k) 3322 3322 - ret = (ret .. s .. v) 3323 3323 - s = joiner 3324 3324 - end 3325 3325 - for k, v in utils.stablepairs(t) do 3326 3326 - if not seen[k] then 3327 3327 - ret = (ret .. s .. "[" .. k .. "]" .. "=" .. v) 3328 3328 - s = joiner 3329 3329 - else 3330 3330 - end 3331 3331 - end 3332 3332 - return ret 3333 3333 - end 3334 3334 - local function do_quote(form, scope, parent, runtime_3f) 3335 3335 - local function q(x) 3336 3336 - return do_quote(x, scope, parent, runtime_3f) 3337 3337 - end 3338 3338 - if utils["varg?"](form) then 3339 3339 - assert_compile(not runtime_3f, "quoted ... may only be used at compile time", form) 3340 3340 - return "_VARARG" 3341 3341 - elseif utils["sym?"](form) then 3342 3342 - local filename 3343 3343 - if form.filename then 3344 3344 - filename = string.format("%q", form.filename) 3345 3345 - else 3346 3346 - filename = "nil" 3347 3347 - end 3348 3348 - local symstr = tostring(form) 3349 3349 - assert_compile(not runtime_3f, "symbols may only be used at compile time", form) 3350 3350 - if (symstr:find("#$") or symstr:find("#[:.]")) then 3351 3351 - return string.format("sym('%s', {filename=%s, line=%s})", autogensym(symstr, scope), filename, (form.line or "nil")) 3352 3352 - else 3353 3353 - return string.format("sym('%s', {quoted=true, filename=%s, line=%s})", symstr, filename, (form.line or "nil")) 3354 3354 - end 3355 3355 - elseif (utils["list?"](form) and utils["sym?"](form[1]) and (tostring(form[1]) == "unquote")) then 3356 3356 - local payload = form[2] 3357 3357 - local res = unpack(compile1(payload, scope, parent)) 3358 3358 - return res[1] 3359 3359 - elseif utils["list?"](form) then 3360 3360 - local mapped 3361 3361 - local function _407_() 3362 3362 - return nil 3363 3363 - end 3364 3364 - mapped = utils.kvmap(form, entry_transform(_407_, q)) 3365 3365 - local filename 3366 3366 - if form.filename then 3367 3367 - filename = string.format("%q", form.filename) 3368 3368 - else 3369 3369 - filename = "nil" 3370 3370 - end 3371 3371 - assert_compile(not runtime_3f, "lists may only be used at compile time", form) 3372 3372 - return string.format(("setmetatable({filename=%s, line=%s, bytestart=%s, %s}" .. ", getmetatable(list()))"), filename, (form.line or "nil"), (form.bytestart or "nil"), mixed_concat(mapped, ", ")) 3373 3373 - elseif utils["sequence?"](form) then 3374 3374 - local mapped = utils.kvmap(form, entry_transform(q, q)) 3375 3375 - local source = getmetatable(form) 3376 3376 - local filename 3377 3377 - if source.filename then 3378 3378 - filename = string.format("%q", source.filename) 3379 3379 - else 3380 3380 - filename = "nil" 3381 3381 - end 3382 3382 - local _410_ 3383 3383 - if source then 3384 3384 - _410_ = source.line 3385 3385 - else 3386 3386 - _410_ = "nil" 3387 3387 - end 3388 3388 - return string.format("setmetatable({%s}, {filename=%s, line=%s, sequence=%s})", mixed_concat(mapped, ", "), filename, _410_, "(getmetatable(sequence()))['sequence']") 3389 3389 - elseif (type(form) == "table") then 3390 3390 - local mapped = utils.kvmap(form, entry_transform(q, q)) 3391 3391 - local source = getmetatable(form) 3392 3392 - local filename 3393 3393 - if source.filename then 3394 3394 - filename = string.format("%q", source.filename) 3395 3395 - else 3396 3396 - filename = "nil" 3397 3397 - end 3398 3398 - local function _413_() 3399 3399 - if source then 3400 3400 - return source.line 3401 3401 - else 3402 3402 - return "nil" 3403 3403 - end 3404 3404 - end 3405 3405 - return string.format("setmetatable({%s}, {filename=%s, line=%s})", mixed_concat(mapped, ", "), filename, _413_()) 3406 3406 - elseif (type(form) == "string") then 3407 3407 - return serialize_string(form) 3408 3408 - else 3409 3409 - return tostring(form) 3410 3410 - end 3411 3411 - end 3412 3412 - return {compile = compile, compile1 = compile1, ["compile-stream"] = compile_stream, ["compile-string"] = compile_string, ["check-binding-valid"] = check_binding_valid, emit = emit, destructure = destructure, ["require-include"] = require_include, autogensym = autogensym, gensym = gensym, ["do-quote"] = do_quote, ["global-mangling"] = global_mangling, ["global-unmangling"] = global_unmangling, ["apply-manglings"] = apply_manglings, macroexpand = macroexpand_2a, ["declare-local"] = declare_local, ["make-scope"] = make_scope, ["keep-side-effects"] = keep_side_effects, ["symbol-to-expression"] = symbol_to_expression, assert = assert_compile, scopes = scopes, traceback = traceback, metadata = make_metadata(), sourcemap = sourcemap} 3413 3413 - end 3414 3414 - package.preload["fennel.friend"] = package.preload["fennel.friend"] or function(...) 3415 3415 - local utils = require("fennel.utils") 3416 3416 - local utf8_ok_3f, utf8 = pcall(require, "utf8") 3417 3417 - local suggestions = {["unexpected multi symbol (.*)"] = {"removing periods or colons from %s"}, ["use of global (.*) is aliased by a local"] = {"renaming local %s", "refer to the global using _G.%s instead of directly"}, ["local (.*) was overshadowed by a special form or macro"] = {"renaming local %s"}, ["global (.*) conflicts with local"] = {"renaming local %s"}, ["expected var (.*)"] = {"declaring %s using var instead of let/local", "introducing a new local instead of changing the value of %s"}, ["expected macros to be table"] = {"ensuring your macro definitions return a table"}, ["expected each macro to be function"] = {"ensuring that the value for each key in your macros table contains a function", "avoid defining nested macro tables"}, ["macro not found in macro module"] = {"checking the keys of the imported macro module's returned table"}, ["macro tried to bind (.*) without gensym"] = {"changing to %s# when introducing identifiers inside macros"}, ["unknown identifier in strict mode: (.*)"] = {"looking to see if there's a typo", "using the _G table instead, eg. _G.%s if you really want a global", "moving this code to somewhere that %s is in scope", "binding %s as a local in the scope of this code"}, ["expected a function.* to call"] = {"removing the empty parentheses", "using square brackets if you want an empty table"}, ["cannot call literal value"] = {"checking for typos", "checking for a missing function name"}, ["unexpected vararg"] = {"putting \"...\" at the end of the fn parameters if the vararg was intended"}, ["multisym method calls may only be in call position"] = {"using a period instead of a colon to reference a table's fields", "putting parens around this"}, ["unused local (.*)"] = {"renaming the local to _%s if it is meant to be unused", "fixing a typo so %s is used", "disabling the linter which checks for unused locals"}, ["expected parameters"] = {"adding function parameters as a list of identifiers in brackets"}, ["unable to bind (.*)"] = {"replacing the %s with an identifier"}, ["expected rest argument before last parameter"] = {"moving & to right before the final identifier when destructuring"}, ["expected vararg as last parameter"] = {"moving the \"...\" to the end of the parameter list"}, ["expected symbol for function parameter: (.*)"] = {"changing %s to an identifier instead of a literal value"}, ["could not compile value of type "] = {"debugging the macro you're calling to return a list or table"}, ["expected local"] = {"looking for a typo", "looking for a local which is used out of its scope"}, ["expected body expression"] = {"putting some code in the body of this form after the bindings"}, ["expected binding and iterator"] = {"making sure you haven't omitted a local name or iterator"}, ["expected binding sequence"] = {"placing a table here in square brackets containing identifiers to bind"}, ["expected even number of name/value bindings"] = {"finding where the identifier or value is missing"}, ["may only be used at compile time"] = {"moving this to inside a macro if you need to manipulate symbols/lists", "using square brackets instead of parens to construct a table"}, ["unexpected closing delimiter (.)"] = {"deleting %s", "adding matching opening delimiter earlier"}, ["mismatched closing delimiter (.), expected (.)"] = {"replacing %s with %s", "deleting %s", "adding matching opening delimiter earlier"}, ["expected even number of values in table literal"] = {"removing a key", "adding a value"}, ["expected whitespace before opening delimiter"] = {"adding whitespace"}, ["invalid character: (.)"] = {"deleting or replacing %s", "avoiding reserved characters like \", \\, ', ~, ;, @, `, and comma"}, ["could not read number (.*)"] = {"removing the non-digit character", "beginning the identifier with a non-digit if it is not meant to be a number"}, ["can't start multisym segment with a digit"] = {"removing the digit", "adding a non-digit before the digit"}, ["malformed multisym"] = {"ensuring each period or colon is not followed by another period or colon"}, ["method must be last component"] = {"using a period instead of a colon for field access", "removing segments after the colon", "making the method call, then looking up the field on the result"}, ["$ and $... in hashfn are mutually exclusive"] = {"modifying the hashfn so it only contains $... or $, $1, $2, $3, etc"}, ["tried to reference a macro at runtime"] = {"renaming the macro so as not to conflict with locals"}, ["tried to reference a special form at runtime"] = {"wrapping the special in a function if you need it to be first class"}, ["missing subject"] = {"adding an item to operate on"}, ["expected even number of pattern/body pairs"] = {"checking that every pattern has a body to go with it", "adding _ before the final body"}, ["expected at least one pattern/body pair"] = {"adding a pattern and a body to execute when the pattern matches"}, ["unexpected arguments"] = {"removing an argument", "checking for typos"}, ["unexpected iterator clause"] = {"removing an argument", "checking for typos"}} 3418 3418 - local unpack = (table.unpack or _G.unpack) 3419 3419 - local function suggest(msg) 3420 3420 - local suggestion = nil 3421 3421 - for pat, sug in pairs(suggestions) do 3422 3422 - local matches = {msg:match(pat)} 3423 3423 - if (0 < #matches) then 3424 3424 - if ("table" == type(sug)) then 3425 3425 - local out = {} 3426 3426 - for _, s in ipairs(sug) do 3427 3427 - table.insert(out, s:format(unpack(matches))) 3428 3428 - end 3429 3429 - suggestion = out 3430 3430 - else 3431 3431 - suggestion = sug(matches) 3432 3432 - end 3433 3433 - else 3434 3434 - end 3435 3435 - end 3436 3436 - return suggestion 3437 3437 - end 3438 3438 - local function read_line(filename, line, _3fsource) 3439 3439 - if _3fsource then 3440 3440 - local matcher = string.gmatch((_3fsource .. "\n"), "(.-)(\13?\n)") 3441 3441 - for _ = 2, line do 3442 3442 - matcher() 3443 3443 - end 3444 3444 - return matcher() 3445 3445 - else 3446 3446 - local f = assert(io.open(filename)) 3447 3447 - local function close_handlers_8_auto(ok_9_auto, ...) 3448 3448 - f:close() 3449 3449 - if ok_9_auto then 3450 3450 - return ... 3451 3451 - else 3452 3452 - return error(..., 0) 3453 3453 - end 3454 3454 - end 3455 3455 - local function _178_() 3456 3456 - for _ = 2, line do 3457 3457 - f:read() 3458 3458 - end 3459 3459 - return f:read() 3460 3460 - end 3461 3461 - return close_handlers_8_auto(_G.xpcall(_178_, (package.loaded.fennel or debug).traceback)) 3462 3462 - end 3463 3463 - end 3464 3464 - local function sub(str, start, _end) 3465 3465 - if (_end < start) then 3466 3466 - return "" 3467 3467 - elseif utf8_ok_3f then 3468 3468 - return string.sub(str, utf8.offset(str, start), ((utf8.offset(str, (_end + 1)) or (utf8.len(str) + 1)) - 1)) 3469 3469 - else 3470 3470 - return string.sub(str, start, math.min(_end, str:len())) 3471 3471 - end 3472 3472 - end 3473 3473 - local function highlight_line(codeline, col, _3fendcol) 3474 3474 - local endcol = (_3fendcol or col) 3475 3475 - local eol 3476 3476 - if utf8_ok_3f then 3477 3477 - eol = utf8.len(codeline) 3478 3478 - else 3479 3479 - eol = string.len(codeline) 3480 3480 - end 3481 3481 - return (sub(codeline, 1, col) .. "\27[7m" .. sub(codeline, (col + 1), (endcol + 1)) .. "\27[0m" .. sub(codeline, (endcol + 2), eol)) 3482 3482 - end 3483 3483 - local function friendly_msg(msg, _182_, source) 3484 3484 - local _arg_183_ = _182_ 3485 3485 - local filename = _arg_183_["filename"] 3486 3486 - local line = _arg_183_["line"] 3487 3487 - local col = _arg_183_["col"] 3488 3488 - local endcol = _arg_183_["endcol"] 3489 3489 - local ok, codeline = pcall(read_line, filename, line, source) 3490 3490 - local out = {msg, ""} 3491 3491 - if (ok and codeline) then 3492 3492 - if col then 3493 3493 - table.insert(out, highlight_line(codeline, col, endcol)) 3494 3494 - else 3495 3495 - table.insert(out, codeline) 3496 3496 - end 3497 3497 - else 3498 3498 - end 3499 3499 - for _, suggestion in ipairs((suggest(msg) or {})) do 3500 3500 - table.insert(out, ("* Try %s."):format(suggestion)) 3501 3501 - end 3502 3502 - return table.concat(out, "\n") 3503 3503 - end 3504 3504 - local function assert_compile(condition, msg, ast, source) 3505 3505 - if not condition then 3506 3506 - local _let_186_ = utils["ast-source"](ast) 3507 3507 - local filename = _let_186_["filename"] 3508 3508 - local line = _let_186_["line"] 3509 3509 - local col = _let_186_["col"] 3510 3510 - error(friendly_msg(("Compile error in %s:%s:%s\n %s"):format((filename or "unknown"), (line or "?"), (col or "?"), msg), utils["ast-source"](ast), source), 0) 3511 3511 - else 3512 3512 - end 3513 3513 - return condition 3514 3514 - end 3515 3515 - local function parse_error(msg, filename, line, col, source) 3516 3516 - return error(friendly_msg(("Parse error in %s:%s:%s\n %s"):format(filename, line, col, msg), {filename = filename, line = line, col = col}, source), 0) 3517 3517 - end 3518 3518 - return {["assert-compile"] = assert_compile, ["parse-error"] = parse_error} 3519 3519 - end 3520 3520 - package.preload["fennel.parser"] = package.preload["fennel.parser"] or function(...) 3521 3521 - local utils = require("fennel.utils") 3522 3522 - local friend = require("fennel.friend") 3523 3523 - local unpack = (table.unpack or _G.unpack) 3524 3524 - local function granulate(getchunk) 3525 3525 - local c, index, done_3f = "", 1, false 3526 3526 - local function _188_(parser_state) 3527 3527 - if not done_3f then 3528 3528 - if (index <= #c) then 3529 3529 - local b = c:byte(index) 3530 3530 - index = (index + 1) 3531 3531 - return b 3532 3532 - else 3533 3533 - local _189_ = getchunk(parser_state) 3534 3534 - local function _190_() 3535 3535 - local char = _189_ 3536 3536 - return (char ~= "") 3537 3537 - end 3538 3538 - if ((nil ~= _189_) and _190_()) then 3539 3539 - local char = _189_ 3540 3540 - c = char 3541 3541 - index = 2 3542 3542 - return c:byte() 3543 3543 - elseif true then 3544 3544 - local _ = _189_ 3545 3545 - done_3f = true 3546 3546 - return nil 3547 3547 - else 3548 3548 - return nil 3549 3549 - end 3550 3550 - end 3551 3551 - else 3552 3552 - return nil 3553 3553 - end 3554 3554 - end 3555 3555 - local function _194_() 3556 3556 - c = "" 3557 3557 - return nil 3558 3558 - end 3559 3559 - return _188_, _194_ 3560 3560 - end 3561 3561 - local function string_stream(str) 3562 3562 - local str0 = str:gsub("^#!", ";;") 3563 3563 - local index = 1 3564 3564 - local function _195_() 3565 3565 - local r = str0:byte(index) 3566 3566 - index = (index + 1) 3567 3567 - return r 3568 3568 - end 3569 3569 - return _195_ 3570 3570 - end 3571 3571 - local delims = {[40] = 41, [41] = true, [91] = 93, [93] = true, [123] = 125, [125] = true} 3572 3572 - local function sym_char_3f(b) 3573 3573 - local b0 3574 3574 - if ("number" == type(b)) then 3575 3575 - b0 = b 3576 3576 - else 3577 3577 - b0 = string.byte(b) 3578 3578 - end 3579 3579 - return ((32 < b0) and not delims[b0] and (b0 ~= 127) and (b0 ~= 34) and (b0 ~= 39) and (b0 ~= 126) and (b0 ~= 59) and (b0 ~= 44) and (b0 ~= 64) and (b0 ~= 96)) 3580 3580 - end 3581 3581 - local prefixes = {[35] = "hashfn", [39] = "quote", [44] = "unquote", [96] = "quote"} 3582 3582 - local function char_starter_3f(b) 3583 3583 - return ((function(_197_,_198_,_199_) return (_197_ < _198_) and (_198_ < _199_) end)(1,b,127) or (function(_200_,_201_,_202_) return (_200_ < _201_) and (_201_ < _202_) end)(192,b,247)) 3584 3584 - end 3585 3585 - local function parser_fn(getbyte, filename, _203_) 3586 3586 - local _arg_204_ = _203_ 3587 3587 - local source = _arg_204_["source"] 3588 3588 - local unfriendly = _arg_204_["unfriendly"] 3589 3589 - local comments = _arg_204_["comments"] 3590 3590 - local options = _arg_204_ 3591 3591 - local stack = {} 3592 3592 - local line, byteindex, col, prev_col, lastb = 1, 0, 0, 0, nil 3593 3593 - local function ungetb(ub) 3594 3594 - if char_starter_3f(ub) then 3595 3595 - col = (col - 1) 3596 3596 - else 3597 3597 - end 3598 3598 - if (ub == 10) then 3599 3599 - line, col = (line - 1), prev_col 3600 3600 - else 3601 3601 - end 3602 3602 - byteindex = (byteindex - 1) 3603 3603 - lastb = ub 3604 3604 - return nil 3605 3605 - end 3606 3606 - local function getb() 3607 3607 - local r = nil 3608 3608 - if lastb then 3609 3609 - r, lastb = lastb, nil 3610 3610 - else 3611 3611 - r = getbyte({["stack-size"] = #stack}) 3612 3612 - end 3613 3613 - byteindex = (byteindex + 1) 3614 3614 - if (r and char_starter_3f(r)) then 3615 3615 - col = (col + 1) 3616 3616 - else 3617 3617 - end 3618 3618 - if (r == 10) then 3619 3619 - line, col, prev_col = (line + 1), 0, col 3620 3620 - else 3621 3621 - end 3622 3622 - return r 3623 3623 - end 3624 3624 - local function whitespace_3f(b) 3625 3625 - local function _214_() 3626 3626 - local t_213_ = options.whitespace 3627 3627 - if (nil ~= t_213_) then 3628 3628 - t_213_ = (t_213_)[b] 3629 3629 - else 3630 3630 - end 3631 3631 - return t_213_ 3632 3632 - end 3633 3633 - return ((b == 32) or (function(_210_,_211_,_212_) return (_210_ <= _211_) and (_211_ <= _212_) end)(9,b,13) or _214_()) 3634 3634 - end 3635 3635 - local function parse_error(msg, _3fcol_adjust) 3636 3636 - local col0 = (col + (_3fcol_adjust or -1)) 3637 3637 - if (nil == utils["hook-opts"]("parse-error", options, msg, filename, (line or "?"), col0, source, utils.root.reset)) then 3638 3638 - utils.root.reset() 3639 3639 - if (unfriendly or not _G.io or not _G.io.read) then 3640 3640 - return error(string.format("%s:%s:%s Parse error: %s", filename, (line or "?"), col0, msg), 0) 3641 3641 - else 3642 3642 - return friend["parse-error"](msg, filename, (line or "?"), col0, source) 3643 3643 - end 3644 3644 - else 3645 3645 - return nil 3646 3646 - end 3647 3647 - end 3648 3648 - local function parse_stream() 3649 3649 - local whitespace_since_dispatch, done_3f, retval = true 3650 3650 - local function set_source_fields(source0) 3651 3651 - source0.byteend, source0.endcol = byteindex, (col - 1) 3652 3652 - return nil 3653 3653 - end 3654 3654 - local function dispatch(v) 3655 3655 - local _218_ = stack[#stack] 3656 3656 - if (_218_ == nil) then 3657 3657 - retval, done_3f, whitespace_since_dispatch = v, true, false 3658 3658 - return nil 3659 3659 - elseif ((_G.type(_218_) == "table") and (nil ~= (_218_).prefix)) then 3660 3660 - local prefix = (_218_).prefix 3661 3661 - local source0 3662 3662 - do 3663 3663 - local _219_ = table.remove(stack) 3664 3664 - set_source_fields(_219_) 3665 3665 - source0 = _219_ 3666 3666 - end 3667 3667 - local list = utils.list(utils.sym(prefix, source0), v) 3668 3668 - for k, v0 in pairs(source0) do 3669 3669 - list[k] = v0 3670 3670 - end 3671 3671 - return dispatch(list) 3672 3672 - elseif (nil ~= _218_) then 3673 3673 - local top = _218_ 3674 3674 - whitespace_since_dispatch = false 3675 3675 - return table.insert(top, v) 3676 3676 - else 3677 3677 - return nil 3678 3678 - end 3679 3679 - end 3680 3680 - local function badend() 3681 3681 - local accum = utils.map(stack, "closer") 3682 3682 - local _221_ 3683 3683 - if (#stack == 1) then 3684 3684 - _221_ = "" 3685 3685 - else 3686 3686 - _221_ = "s" 3687 3687 - end 3688 3688 - return parse_error(string.format("expected closing delimiter%s %s", _221_, string.char(unpack(accum)))) 3689 3689 - end 3690 3690 - local function skip_whitespace(b) 3691 3691 - if (b and whitespace_3f(b)) then 3692 3692 - whitespace_since_dispatch = true 3693 3693 - return skip_whitespace(getb()) 3694 3694 - elseif (not b and (0 < #stack)) then 3695 3695 - return badend() 3696 3696 - else 3697 3697 - return b 3698 3698 - end 3699 3699 - end 3700 3700 - local function parse_comment(b, contents) 3701 3701 - if (b and (10 ~= b)) then 3702 3702 - local function _225_() 3703 3703 - local _224_ = contents 3704 3704 - table.insert(_224_, string.char(b)) 3705 3705 - return _224_ 3706 3706 - end 3707 3707 - return parse_comment(getb(), _225_()) 3708 3708 - elseif comments then 3709 3709 - ungetb(10) 3710 3710 - return dispatch(utils.comment(table.concat(contents), {line = (line - 1), filename = filename})) 3711 3711 - else 3712 3712 - return nil 3713 3713 - end 3714 3714 - end 3715 3715 - local function open_table(b) 3716 3716 - if not whitespace_since_dispatch then 3717 3717 - parse_error(("expected whitespace before opening delimiter " .. string.char(b))) 3718 3718 - else 3719 3719 - end 3720 3720 - return table.insert(stack, {bytestart = byteindex, closer = delims[b], filename = filename, line = line, col = (col - 1)}) 3721 3721 - end 3722 3722 - local function close_list(list) 3723 3723 - return dispatch(setmetatable(list, getmetatable(utils.list()))) 3724 3724 - end 3725 3725 - local function close_sequence(tbl) 3726 3726 - local val = utils.sequence(unpack(tbl)) 3727 3727 - for k, v in pairs(tbl) do 3728 3728 - getmetatable(val)[k] = v 3729 3729 - end 3730 3730 - return dispatch(val) 3731 3731 - end 3732 3732 - local function add_comment_at(comments0, index, node) 3733 3733 - local _228_ = (comments0)[index] 3734 3734 - if (nil ~= _228_) then 3735 3735 - local existing = _228_ 3736 3736 - return table.insert(existing, node) 3737 3737 - elseif true then 3738 3738 - local _ = _228_ 3739 3739 - comments0[index] = {node} 3740 3740 - return nil 3741 3741 - else 3742 3742 - return nil 3743 3743 - end 3744 3744 - end 3745 3745 - local function next_noncomment(tbl, i) 3746 3746 - if utils["comment?"](tbl[i]) then 3747 3747 - return next_noncomment(tbl, (i + 1)) 3748 3748 - else 3749 3749 - return tbl[i] 3750 3750 - end 3751 3751 - end 3752 3752 - local function extract_comments(tbl) 3753 3753 - local comments0 = {keys = {}, values = {}, last = {}} 3754 3754 - while utils["comment?"](tbl[#tbl]) do 3755 3755 - table.insert(comments0.last, 1, table.remove(tbl)) 3756 3756 - end 3757 3757 - local last_key_3f = false 3758 3758 - for i, node in ipairs(tbl) do 3759 3759 - if not utils["comment?"](node) then 3760 3760 - last_key_3f = not last_key_3f 3761 3761 - elseif last_key_3f then 3762 3762 - add_comment_at(comments0.values, next_noncomment(tbl, i), node) 3763 3763 - else 3764 3764 - add_comment_at(comments0.keys, next_noncomment(tbl, i), node) 3765 3765 - end 3766 3766 - end 3767 3767 - for i = #tbl, 1, -1 do 3768 3768 - if utils["comment?"](tbl[i]) then 3769 3769 - table.remove(tbl, i) 3770 3770 - else 3771 3771 - end 3772 3772 - end 3773 3773 - return comments0 3774 3774 - end 3775 3775 - local function close_curly_table(tbl) 3776 3776 - local comments0 = extract_comments(tbl) 3777 3777 - local keys = {} 3778 3778 - local val = {} 3779 3779 - if ((#tbl % 2) ~= 0) then 3780 3780 - byteindex = (byteindex - 1) 3781 3781 - parse_error("expected even number of values in table literal") 3782 3782 - else 3783 3783 - end 3784 3784 - setmetatable(val, tbl) 3785 3785 - for i = 1, #tbl, 2 do 3786 3786 - if ((tostring(tbl[i]) == ":") and utils["sym?"](tbl[(i + 1)]) and utils["sym?"](tbl[i])) then 3787 3787 - tbl[i] = tostring(tbl[(i + 1)]) 3788 3788 - else 3789 3789 - end 3790 3790 - val[tbl[i]] = tbl[(i + 1)] 3791 3791 - table.insert(keys, tbl[i]) 3792 3792 - end 3793 3793 - tbl.comments = comments0 3794 3794 - tbl.keys = keys 3795 3795 - return dispatch(val) 3796 3796 - end 3797 3797 - local function close_table(b) 3798 3798 - local top = table.remove(stack) 3799 3799 - if (top == nil) then 3800 3800 - parse_error(("unexpected closing delimiter " .. string.char(b))) 3801 3801 - else 3802 3802 - end 3803 3803 - if (top.closer and (top.closer ~= b)) then 3804 3804 - parse_error(("mismatched closing delimiter " .. string.char(b) .. ", expected " .. string.char(top.closer))) 3805 3805 - else 3806 3806 - end 3807 3807 - set_source_fields(top) 3808 3808 - if (b == 41) then 3809 3809 - return close_list(top) 3810 3810 - elseif (b == 93) then 3811 3811 - return close_sequence(top) 3812 3812 - else 3813 3813 - return close_curly_table(top) 3814 3814 - end 3815 3815 - end 3816 3816 - local function parse_string_loop(chars, b, state) 3817 3817 - table.insert(chars, b) 3818 3818 - local state0 3819 3819 - do 3820 3820 - local _238_ = {state, b} 3821 3821 - if ((_G.type(_238_) == "table") and ((_238_)[1] == "base") and ((_238_)[2] == 92)) then 3822 3822 - state0 = "backslash" 3823 3823 - elseif ((_G.type(_238_) == "table") and ((_238_)[1] == "base") and ((_238_)[2] == 34)) then 3824 3824 - state0 = "done" 3825 3825 - elseif ((_G.type(_238_) == "table") and ((_238_)[1] == "backslash") and ((_238_)[2] == 10)) then 3826 3826 - table.remove(chars, (#chars - 1)) 3827 3827 - state0 = "base" 3828 3828 - elseif true then 3829 3829 - local _ = _238_ 3830 3830 - state0 = "base" 3831 3831 - else 3832 3832 - state0 = nil 3833 3833 - end 3834 3834 - end 3835 3835 - if (b and (state0 ~= "done")) then 3836 3836 - return parse_string_loop(chars, getb(), state0) 3837 3837 - else 3838 3838 - return b 3839 3839 - end 3840 3840 - end 3841 3841 - local function escape_char(c) 3842 3842 - return ({[7] = "\\a", [8] = "\\b", [9] = "\\t", [10] = "\\n", [11] = "\\v", [12] = "\\f", [13] = "\\r"})[c:byte()] 3843 3843 - end 3844 3844 - local function parse_string() 3845 3845 - table.insert(stack, {closer = 34}) 3846 3846 - local chars = {34} 3847 3847 - if not parse_string_loop(chars, getb(), "base") then 3848 3848 - badend() 3849 3849 - else 3850 3850 - end 3851 3851 - table.remove(stack) 3852 3852 - local raw = string.char(unpack(chars)) 3853 3853 - local formatted = raw:gsub("[\7-\13]", escape_char) 3854 3854 - local _242_ = (rawget(_G, "loadstring") or load)(("return " .. formatted)) 3855 3855 - if (nil ~= _242_) then 3856 3856 - local load_fn = _242_ 3857 3857 - return dispatch(load_fn()) 3858 3858 - elseif (_242_ == nil) then 3859 3859 - return parse_error(("Invalid string: " .. raw)) 3860 3860 - else 3861 3861 - return nil 3862 3862 - end 3863 3863 - end 3864 3864 - local function parse_prefix(b) 3865 3865 - table.insert(stack, {prefix = prefixes[b], filename = filename, line = line, bytestart = byteindex, col = (col - 1)}) 3866 3866 - local nextb = getb() 3867 3867 - if (whitespace_3f(nextb) or (true == delims[nextb])) then 3868 3868 - if (b ~= 35) then 3869 3869 - parse_error("invalid whitespace after quoting prefix") 3870 3870 - else 3871 3871 - end 3872 3872 - table.remove(stack) 3873 3873 - dispatch(utils.sym("#")) 3874 3874 - else 3875 3875 - end 3876 3876 - return ungetb(nextb) 3877 3877 - end 3878 3878 - local function parse_sym_loop(chars, b) 3879 3879 - if (b and sym_char_3f(b)) then 3880 3880 - table.insert(chars, b) 3881 3881 - return parse_sym_loop(chars, getb()) 3882 3882 - else 3883 3883 - if b then 3884 3884 - ungetb(b) 3885 3885 - else 3886 3886 - end 3887 3887 - return chars 3888 3888 - end 3889 3889 - end 3890 3890 - local function parse_number(rawstr) 3891 3891 - local number_with_stripped_underscores = (not rawstr:find("^_") and rawstr:gsub("_", "")) 3892 3892 - if rawstr:match("^%d") then 3893 3893 - dispatch((tonumber(number_with_stripped_underscores) or parse_error(("could not read number \"" .. rawstr .. "\"")))) 3894 3894 - return true 3895 3895 - else 3896 3896 - local _248_ = tonumber(number_with_stripped_underscores) 3897 3897 - if (nil ~= _248_) then 3898 3898 - local x = _248_ 3899 3899 - dispatch(x) 3900 3900 - return true 3901 3901 - elseif true then 3902 3902 - local _ = _248_ 3903 3903 - return false 3904 3904 - else 3905 3905 - return nil 3906 3906 - end 3907 3907 - end 3908 3908 - end 3909 3909 - local function check_malformed_sym(rawstr) 3910 3910 - local function col_adjust(pat) 3911 3911 - return (rawstr:find(pat) - utils.len(rawstr) - 1) 3912 3912 - end 3913 3913 - if (rawstr:match("^~") and (rawstr ~= "~=")) then 3914 3914 - return parse_error("invalid character: ~") 3915 3915 - elseif rawstr:match("%.[0-9]") then 3916 3916 - return parse_error(("can't start multisym segment with a digit: " .. rawstr), col_adjust("%.[0-9]")) 3917 3917 - elseif (rawstr:match("[%.:][%.:]") and (rawstr ~= "..") and (rawstr ~= "$...")) then 3918 3918 - return parse_error(("malformed multisym: " .. rawstr), col_adjust("[%.:][%.:]")) 3919 3919 - elseif ((rawstr ~= ":") and rawstr:match(":$")) then 3920 3920 - return parse_error(("malformed multisym: " .. rawstr), col_adjust(":$")) 3921 3921 - elseif rawstr:match(":.+[%.:]") then 3922 3922 - return parse_error(("method must be last component of multisym: " .. rawstr), col_adjust(":.+[%.:]")) 3923 3923 - else 3924 3924 - return rawstr 3925 3925 - end 3926 3926 - end 3927 3927 - local function parse_sym(b) 3928 3928 - local source0 = {bytestart = byteindex, filename = filename, line = line, col = (col - 1)} 3929 3929 - local rawstr = string.char(unpack(parse_sym_loop({b}, getb()))) 3930 3930 - set_source_fields(source0) 3931 3931 - if (rawstr == "true") then 3932 3932 - return dispatch(true) 3933 3933 - elseif (rawstr == "false") then 3934 3934 - return dispatch(false) 3935 3935 - elseif (rawstr == "...") then 3936 3936 - return dispatch(utils.varg(source0)) 3937 3937 - elseif rawstr:match("^:.+$") then 3938 3938 - return dispatch(rawstr:sub(2)) 3939 3939 - elseif not parse_number(rawstr) then 3940 3940 - return dispatch(utils.sym(check_malformed_sym(rawstr), source0)) 3941 3941 - else 3942 3942 - return nil 3943 3943 - end 3944 3944 - end 3945 3945 - local function parse_loop(b) 3946 3946 - if not b then 3947 3947 - elseif (b == 59) then 3948 3948 - parse_comment(getb(), {";"}) 3949 3949 - elseif (type(delims[b]) == "number") then 3950 3950 - open_table(b) 3951 3951 - elseif delims[b] then 3952 3952 - close_table(b) 3953 3953 - elseif (b == 34) then 3954 3954 - parse_string(b) 3955 3955 - elseif prefixes[b] then 3956 3956 - parse_prefix(b) 3957 3957 - elseif (sym_char_3f(b) or (b == string.byte("~"))) then 3958 3958 - parse_sym(b) 3959 3959 - elseif not utils["hook-opts"]("illegal-char", options, b, getb, ungetb, dispatch) then 3960 3960 - parse_error(("invalid character: " .. string.char(b))) 3961 3961 - else 3962 3962 - end 3963 3963 - if not b then 3964 3964 - return nil 3965 3965 - elseif done_3f then 3966 3966 - return true, retval 3967 3967 - else 3968 3968 - return parse_loop(skip_whitespace(getb())) 3969 3969 - end 3970 3970 - end 3971 3971 - return parse_loop(skip_whitespace(getb())) 3972 3972 - end 3973 3973 - local function _255_() 3974 3974 - stack, line, byteindex, col, lastb = {}, 1, 0, 0, nil 3975 3975 - return nil 3976 3976 - end 3977 3977 - return parse_stream, _255_ 3978 3978 - end 3979 3979 - local function parser(stream_or_string, _3ffilename, _3foptions) 3980 3980 - local filename = (_3ffilename or "unknown") 3981 3981 - local options = (_3foptions or utils.root.options or {}) 3982 3982 - assert(("string" == type(filename)), "expected filename as second argument to parser") 3983 3983 - if ("string" == type(stream_or_string)) then 3984 3984 - return parser_fn(string_stream(stream_or_string), filename, options) 3985 3985 - else 3986 3986 - return parser_fn(stream_or_string, filename, options) 3987 3987 - end 3988 3988 - end 3989 3989 - return {granulate = granulate, parser = parser, ["string-stream"] = string_stream, ["sym-char?"] = sym_char_3f} 3990 3990 - end 3991 3991 - local utils 3992 3992 - package.preload["fennel.view"] = package.preload["fennel.view"] or function(...) 3993 3993 - local type_order = {number = 1, boolean = 2, string = 3, table = 4, ["function"] = 5, userdata = 6, thread = 7} 3994 3994 - local lua_pairs = pairs 3995 3995 - local lua_ipairs = ipairs 3996 3996 - local function pairs(t) 3997 3997 - local _1_ = getmetatable(t) 3998 3998 - if ((_G.type(_1_) == "table") and (nil ~= (_1_).__pairs)) then 3999 3999 - local p = (_1_).__pairs 4000 4000 - return p(t) 4001 4001 - elseif true then 4002 4002 - local _ = _1_ 4003 4003 - return lua_pairs(t) 4004 4004 - else 4005 4005 - return nil 4006 4006 - end 4007 4007 - end 4008 4008 - local function ipairs(t) 4009 4009 - local _3_ = getmetatable(t) 4010 4010 - if ((_G.type(_3_) == "table") and (nil ~= (_3_).__ipairs)) then 4011 4011 - local i = (_3_).__ipairs 4012 4012 - return i(t) 4013 4013 - elseif true then 4014 4014 - local _ = _3_ 4015 4015 - return lua_ipairs(t) 4016 4016 - else 4017 4017 - return nil 4018 4018 - end 4019 4019 - end 4020 4020 - local function length_2a(t) 4021 4021 - local _5_ = getmetatable(t) 4022 4022 - if ((_G.type(_5_) == "table") and (nil ~= (_5_).__len)) then 4023 4023 - local l = (_5_).__len 4024 4024 - return l(t) 4025 4025 - elseif true then 4026 4026 - local _ = _5_ 4027 4027 - return #t 4028 4028 - else 4029 4029 - return nil 4030 4030 - end 4031 4031 - end 4032 4032 - local function sort_keys(_7_, _9_) 4033 4033 - local _arg_8_ = _7_ 4034 4034 - local a = _arg_8_[1] 4035 4035 - local _arg_10_ = _9_ 4036 4036 - local b = _arg_10_[1] 4037 4037 - local ta = type(a) 4038 4038 - local tb = type(b) 4039 4039 - if ((ta == tb) and ((ta == "string") or (ta == "number"))) then 4040 4040 - return (a < b) 4041 4041 - else 4042 4042 - local dta = type_order[ta] 4043 4043 - local dtb = type_order[tb] 4044 4044 - if (dta and dtb) then 4045 4045 - return (dta < dtb) 4046 4046 - elseif dta then 4047 4047 - return true 4048 4048 - elseif dtb then 4049 4049 - return false 4050 4050 - else 4051 4051 - return (ta < tb) 4052 4052 - end 4053 4053 - end 4054 4054 - end 4055 4055 - local function max_index_gap(kv) 4056 4056 - local gap = 0 4057 4057 - if (0 < length_2a(kv)) then 4058 4058 - local i = 0 4059 4059 - for _, _13_ in ipairs(kv) do 4060 4060 - local _each_14_ = _13_ 4061 4061 - local k = _each_14_[1] 4062 4062 - if (gap < (k - i)) then 4063 4063 - gap = (k - i) 4064 4064 - else 4065 4065 - end 4066 4066 - i = k 4067 4067 - end 4068 4068 - else 4069 4069 - end 4070 4070 - return gap 4071 4071 - end 4072 4072 - local function fill_gaps(kv) 4073 4073 - local missing_indexes = {} 4074 4074 - local i = 0 4075 4075 - for _, _17_ in ipairs(kv) do 4076 4076 - local _each_18_ = _17_ 4077 4077 - local j = _each_18_[1] 4078 4078 - i = (i + 1) 4079 4079 - while (i < j) do 4080 4080 - table.insert(missing_indexes, i) 4081 4081 - i = (i + 1) 4082 4082 - end 4083 4083 - end 4084 4084 - for _, k in ipairs(missing_indexes) do 4085 4085 - table.insert(kv, k, {k}) 4086 4086 - end 4087 4087 - return nil 4088 4088 - end 4089 4089 - local function table_kv_pairs(t, options) 4090 4090 - local assoc_3f = false 4091 4091 - local kv = {} 4092 4092 - local insert = table.insert 4093 4093 - for k, v in pairs(t) do 4094 4094 - if ((type(k) ~= "number") or (k < 1)) then 4095 4095 - assoc_3f = true 4096 4096 - else 4097 4097 - end 4098 4098 - insert(kv, {k, v}) 4099 4099 - end 4100 4100 - table.sort(kv, sort_keys) 4101 4101 - if not assoc_3f then 4102 4102 - if (options["max-sparse-gap"] < max_index_gap(kv)) then 4103 4103 - assoc_3f = true 4104 4104 - else 4105 4105 - fill_gaps(kv) 4106 4106 - end 4107 4107 - else 4108 4108 - end 4109 4109 - if (length_2a(kv) == 0) then 4110 4110 - return kv, "empty" 4111 4111 - else 4112 4112 - local function _22_() 4113 4113 - if assoc_3f then 4114 4114 - return "table" 4115 4115 - else 4116 4116 - return "seq" 4117 4117 - end 4118 4118 - end 4119 4119 - return kv, _22_() 4120 4120 - end 4121 4121 - end 4122 4122 - local function count_table_appearances(t, appearances) 4123 4123 - if (type(t) == "table") then 4124 4124 - if not appearances[t] then 4125 4125 - appearances[t] = 1 4126 4126 - for k, v in pairs(t) do 4127 4127 - count_table_appearances(k, appearances) 4128 4128 - count_table_appearances(v, appearances) 4129 4129 - end 4130 4130 - else 4131 4131 - appearances[t] = ((appearances[t] or 0) + 1) 4132 4132 - end 4133 4133 - else 4134 4134 - end 4135 4135 - return appearances 4136 4136 - end 4137 4137 - local function save_table(t, seen) 4138 4138 - local seen0 = (seen or {len = 0}) 4139 4139 - local id = (seen0.len + 1) 4140 4140 - if not (seen0)[t] then 4141 4141 - seen0[t] = id 4142 4142 - seen0.len = id 4143 4143 - else 4144 4144 - end 4145 4145 - return seen0 4146 4146 - end 4147 4147 - local function detect_cycle(t, seen, _3fk) 4148 4148 - if ("table" == type(t)) then 4149 4149 - seen[t] = true 4150 4150 - local _27_, _28_ = next(t, _3fk) 4151 4151 - if ((nil ~= _27_) and (nil ~= _28_)) then 4152 4152 - local k = _27_ 4153 4153 - local v = _28_ 4154 4154 - return (seen[k] or detect_cycle(k, seen) or seen[v] or detect_cycle(v, seen) or detect_cycle(t, seen, k)) 4155 4155 - else 4156 4156 - return nil 4157 4157 - end 4158 4158 - else 4159 4159 - return nil 4160 4160 - end 4161 4161 - end 4162 4162 - local function visible_cycle_3f(t, options) 4163 4163 - return (options["detect-cycles?"] and detect_cycle(t, {}) and save_table(t, options.seen) and (1 < (options.appearances[t] or 0))) 4164 4164 - end 4165 4165 - local function table_indent(indent, id) 4166 4166 - local opener_length 4167 4167 - if id then 4168 4168 - opener_length = (length_2a(tostring(id)) + 2) 4169 4169 - else 4170 4170 - opener_length = 1 4171 4171 - end 4172 4172 - return (indent + opener_length) 4173 4173 - end 4174 4174 - local pp = nil 4175 4175 - local function concat_table_lines(elements, options, multiline_3f, indent, table_type, prefix, last_comment_3f) 4176 4176 - local indent_str = ("\n" .. string.rep(" ", indent)) 4177 4177 - local open 4178 4178 - local function _32_() 4179 4179 - if ("seq" == table_type) then 4180 4180 - return "[" 4181 4181 - else 4182 4182 - return "{" 4183 4183 - end 4184 4184 - end 4185 4185 - open = ((prefix or "") .. _32_()) 4186 4186 - local close 4187 4187 - if ("seq" == table_type) then 4188 4188 - close = "]" 4189 4189 - else 4190 4190 - close = "}" 4191 4191 - end 4192 4192 - local oneline = (open .. table.concat(elements, " ") .. close) 4193 4193 - if (not options["one-line?"] and (multiline_3f or (options["line-length"] < (indent + length_2a(oneline))) or last_comment_3f)) then 4194 4194 - local function _34_() 4195 4195 - if last_comment_3f then 4196 4196 - return indent_str 4197 4197 - else 4198 4198 - return "" 4199 4199 - end 4200 4200 - end 4201 4201 - return (open .. table.concat(elements, indent_str) .. _34_() .. close) 4202 4202 - else 4203 4203 - return oneline 4204 4204 - end 4205 4205 - end 4206 4206 - local function utf8_len(x) 4207 4207 - local n = 0 4208 4208 - for _ in string.gmatch(x, "[%z\1-\127\192-\247]") do 4209 4209 - n = (n + 1) 4210 4210 - end 4211 4211 - return n 4212 4212 - end 4213 4213 - local function comment_3f(x) 4214 4214 - if ("table" == type(x)) then 4215 4215 - local fst = x[1] 4216 4216 - return (("string" == type(fst)) and (nil ~= fst:find("^;"))) 4217 4217 - else 4218 4218 - return false 4219 4219 - end 4220 4220 - end 4221 4221 - local function pp_associative(t, kv, options, indent) 4222 4222 - local multiline_3f = false 4223 4223 - local id = options.seen[t] 4224 4224 - if (options.depth <= options.level) then 4225 4225 - return "{...}" 4226 4226 - elseif (id and options["detect-cycles?"]) then 4227 4227 - return ("@" .. id .. "{...}") 4228 4228 - else 4229 4229 - local visible_cycle_3f0 = visible_cycle_3f(t, options) 4230 4230 - local id0 = (visible_cycle_3f0 and options.seen[t]) 4231 4231 - local indent0 = table_indent(indent, id0) 4232 4232 - local slength 4233 4233 - if options["utf8?"] then 4234 4234 - slength = utf8_len 4235 4235 - else 4236 4236 - local function _37_(_241) 4237 4237 - return #_241 4238 4238 - end 4239 4239 - slength = _37_ 4240 4240 - end 4241 4241 - local prefix 4242 4242 - if visible_cycle_3f0 then 4243 4243 - prefix = ("@" .. id0) 4244 4244 - else 4245 4245 - prefix = "" 4246 4246 - end 4247 4247 - local items 4248 4248 - do 4249 4249 - local tbl_14_auto = {} 4250 4250 - local i_15_auto = #tbl_14_auto 4251 4251 - for _, _40_ in ipairs(kv) do 4252 4252 - local _each_41_ = _40_ 4253 4253 - local k = _each_41_[1] 4254 4254 - local v = _each_41_[2] 4255 4255 - local val_16_auto 4256 4256 - do 4257 4257 - local k0 = pp(k, options, (indent0 + 1), true) 4258 4258 - local v0 = pp(v, options, (indent0 + slength(k0) + 1)) 4259 4259 - multiline_3f = (multiline_3f or k0:find("\n") or v0:find("\n")) 4260 4260 - val_16_auto = (k0 .. " " .. v0) 4261 4261 - end 4262 4262 - if (nil ~= val_16_auto) then 4263 4263 - i_15_auto = (i_15_auto + 1) 4264 4264 - do end (tbl_14_auto)[i_15_auto] = val_16_auto 4265 4265 - else 4266 4266 - end 4267 4267 - end 4268 4268 - items = tbl_14_auto 4269 4269 - end 4270 4270 - return concat_table_lines(items, options, multiline_3f, indent0, "table", prefix, false) 4271 4271 - end 4272 4272 - end 4273 4273 - local function pp_sequence(t, kv, options, indent) 4274 4274 - local multiline_3f = false 4275 4275 - local id = options.seen[t] 4276 4276 - if (options.depth <= options.level) then 4277 4277 - return "[...]" 4278 4278 - elseif (id and options["detect-cycles?"]) then 4279 4279 - return ("@" .. id .. "[...]") 4280 4280 - else 4281 4281 - local visible_cycle_3f0 = visible_cycle_3f(t, options) 4282 4282 - local id0 = (visible_cycle_3f0 and options.seen[t]) 4283 4283 - local indent0 = table_indent(indent, id0) 4284 4284 - local prefix 4285 4285 - if visible_cycle_3f0 then 4286 4286 - prefix = ("@" .. id0) 4287 4287 - else 4288 4288 - prefix = "" 4289 4289 - end 4290 4290 - local last_comment_3f = comment_3f(t[#t]) 4291 4291 - local items 4292 4292 - do 4293 4293 - local tbl_14_auto = {} 4294 4294 - local i_15_auto = #tbl_14_auto 4295 4295 - for _, _45_ in ipairs(kv) do 4296 4296 - local _each_46_ = _45_ 4297 4297 - local _0 = _each_46_[1] 4298 4298 - local v = _each_46_[2] 4299 4299 - local val_16_auto 4300 4300 - do 4301 4301 - local v0 = pp(v, options, indent0) 4302 4302 - multiline_3f = (multiline_3f or v0:find("\n") or v0:find("^;")) 4303 4303 - val_16_auto = v0 4304 4304 - end 4305 4305 - if (nil ~= val_16_auto) then 4306 4306 - i_15_auto = (i_15_auto + 1) 4307 4307 - do end (tbl_14_auto)[i_15_auto] = val_16_auto 4308 4308 - else 4309 4309 - end 4310 4310 - end 4311 4311 - items = tbl_14_auto 4312 4312 - end 4313 4313 - return concat_table_lines(items, options, multiline_3f, indent0, "seq", prefix, last_comment_3f) 4314 4314 - end 4315 4315 - end 4316 4316 - local function concat_lines(lines, options, indent, force_multi_line_3f) 4317 4317 - if (length_2a(lines) == 0) then 4318 4318 - if options["empty-as-sequence?"] then 4319 4319 - return "[]" 4320 4320 - else 4321 4321 - return "{}" 4322 4322 - end 4323 4323 - else 4324 4324 - local oneline 4325 4325 - local _50_ 4326 4326 - do 4327 4327 - local tbl_14_auto = {} 4328 4328 - local i_15_auto = #tbl_14_auto 4329 4329 - for _, line in ipairs(lines) do 4330 4330 - local val_16_auto = line:gsub("^%s+", "") 4331 4331 - if (nil ~= val_16_auto) then 4332 4332 - i_15_auto = (i_15_auto + 1) 4333 4333 - do end (tbl_14_auto)[i_15_auto] = val_16_auto 4334 4334 - else 4335 4335 - end 4336 4336 - end 4337 4337 - _50_ = tbl_14_auto 4338 4338 - end 4339 4339 - oneline = table.concat(_50_, " ") 4340 4340 - if (not options["one-line?"] and (force_multi_line_3f or oneline:find("\n") or (options["line-length"] < (indent + length_2a(oneline))))) then 4341 4341 - return table.concat(lines, ("\n" .. string.rep(" ", indent))) 4342 4342 - else 4343 4343 - return oneline 4344 4344 - end 4345 4345 - end 4346 4346 - end 4347 4347 - local function pp_metamethod(t, metamethod, options, indent) 4348 4348 - if (options.depth <= options.level) then 4349 4349 - if options["empty-as-sequence?"] then 4350 4350 - return "[...]" 4351 4351 - else 4352 4352 - return "{...}" 4353 4353 - end 4354 4354 - else 4355 4355 - local _ 4356 4356 - local function _55_(_241) 4357 4357 - return visible_cycle_3f(_241, options) 4358 4358 - end 4359 4359 - options["visible-cycle?"] = _55_ 4360 4360 - _ = nil 4361 4361 - local lines, force_multi_line_3f = metamethod(t, pp, options, indent) 4362 4362 - options["visible-cycle?"] = nil 4363 4363 - local _56_ = type(lines) 4364 4364 - if (_56_ == "string") then 4365 4365 - return lines 4366 4366 - elseif (_56_ == "table") then 4367 4367 - return concat_lines(lines, options, indent, force_multi_line_3f) 4368 4368 - elseif true then 4369 4369 - local _0 = _56_ 4370 4370 - return error("__fennelview metamethod must return a table of lines") 4371 4371 - else 4372 4372 - return nil 4373 4373 - end 4374 4374 - end 4375 4375 - end 4376 4376 - local function pp_table(x, options, indent) 4377 4377 - options.level = (options.level + 1) 4378 4378 - local x0 4379 4379 - do 4380 4380 - local _59_ 4381 4381 - if options["metamethod?"] then 4382 4382 - local _60_ = x 4383 4383 - if (nil ~= _60_) then 4384 4384 - local _61_ = getmetatable(_60_) 4385 4385 - if (nil ~= _61_) then 4386 4386 - _59_ = (_61_).__fennelview 4387 4387 - else 4388 4388 - _59_ = _61_ 4389 4389 - end 4390 4390 - else 4391 4391 - _59_ = _60_ 4392 4392 - end 4393 4393 - else 4394 4394 - _59_ = nil 4395 4395 - end 4396 4396 - if (nil ~= _59_) then 4397 4397 - local metamethod = _59_ 4398 4398 - x0 = pp_metamethod(x, metamethod, options, indent) 4399 4399 - elseif true then 4400 4400 - local _ = _59_ 4401 4401 - local _65_, _66_ = table_kv_pairs(x, options) 4402 4402 - if (true and (_66_ == "empty")) then 4403 4403 - local _0 = _65_ 4404 4404 - if options["empty-as-sequence?"] then 4405 4405 - x0 = "[]" 4406 4406 - else 4407 4407 - x0 = "{}" 4408 4408 - end 4409 4409 - elseif ((nil ~= _65_) and (_66_ == "table")) then 4410 4410 - local kv = _65_ 4411 4411 - x0 = pp_associative(x, kv, options, indent) 4412 4412 - elseif ((nil ~= _65_) and (_66_ == "seq")) then 4413 4413 - local kv = _65_ 4414 4414 - x0 = pp_sequence(x, kv, options, indent) 4415 4415 - else 4416 4416 - x0 = nil 4417 4417 - end 4418 4418 - else 4419 4419 - x0 = nil 4420 4420 - end 4421 4421 - end 4422 4422 - options.level = (options.level - 1) 4423 4423 - return x0 4424 4424 - end 4425 4425 - local function number__3estring(n) 4426 4426 - local _70_ = string.gsub(tostring(n), ",", ".") 4427 4427 - return _70_ 4428 4428 - end 4429 4429 - local function colon_string_3f(s) 4430 4430 - return s:find("^[-%w?^_!$%&*+./@|<=>]+$") 4431 4431 - end 4432 4432 - local utf8_inits = {{["min-byte"] = 0, ["max-byte"] = 127, ["min-code"] = 0, ["max-code"] = 127, len = 1}, {["min-byte"] = 192, ["max-byte"] = 223, ["min-code"] = 128, ["max-code"] = 2047, len = 2}, {["min-byte"] = 224, ["max-byte"] = 239, ["min-code"] = 2048, ["max-code"] = 65535, len = 3}, {["min-byte"] = 240, ["max-byte"] = 247, ["min-code"] = 65536, ["max-code"] = 1114111, len = 4}} 4433 4433 - local function utf8_escape(str) 4434 4434 - local function validate_utf8(str0, index) 4435 4435 - local inits = utf8_inits 4436 4436 - local byte = string.byte(str0, index) 4437 4437 - local init 4438 4438 - do 4439 4439 - local ret = nil 4440 4440 - for _, init0 in ipairs(inits) do 4441 4441 - if ret then break end 4442 4442 - ret = (byte and (function(_71_,_72_,_73_) return (_71_ <= _72_) and (_72_ <= _73_) end)(init0["min-byte"],byte,init0["max-byte"]) and init0) 4443 4443 - end 4444 4444 - init = ret 4445 4445 - end 4446 4446 - local code 4447 4447 - local function _74_() 4448 4448 - local code0 4449 4449 - if init then 4450 4450 - code0 = (byte - init["min-byte"]) 4451 4451 - else 4452 4452 - code0 = nil 4453 4453 - end 4454 4454 - for i = (index + 1), (index + init.len + -1) do 4455 4455 - local byte0 = string.byte(str0, i) 4456 4456 - code0 = (byte0 and code0 and (function(_76_,_77_,_78_) return (_76_ <= _77_) and (_77_ <= _78_) end)(128,byte0,191) and ((code0 * 64) + (byte0 - 128))) 4457 4457 - end 4458 4458 - return code0 4459 4459 - end 4460 4460 - code = (init and _74_()) 4461 4461 - if (code and (function(_79_,_80_,_81_) return (_79_ <= _80_) and (_80_ <= _81_) end)(init["min-code"],code,init["max-code"]) and not (function(_82_,_83_,_84_) return (_82_ <= _83_) and (_83_ <= _84_) end)(55296,code,57343)) then 4462 4462 - return init.len 4463 4463 - else 4464 4464 - return nil 4465 4465 - end 4466 4466 - end 4467 4467 - local index = 1 4468 4468 - local output = {} 4469 4469 - while (index <= #str) do 4470 4470 - local nexti = (string.find(str, "[\128-\255]", index) or (#str + 1)) 4471 4471 - local len = validate_utf8(str, nexti) 4472 4472 - table.insert(output, string.sub(str, index, (nexti + (len or 0) + -1))) 4473 4473 - if (not len and (nexti <= #str)) then 4474 4474 - table.insert(output, string.format("\\%03d", string.byte(str, nexti))) 4475 4475 - else 4476 4476 - end 4477 4477 - if len then 4478 4478 - index = (nexti + len) 4479 4479 - else 4480 4480 - index = (nexti + 1) 4481 4481 - end 4482 4482 - end 4483 4483 - return table.concat(output) 4484 4484 - end 4485 4485 - local function pp_string(str, options, indent) 4486 4486 - local escs 4487 4487 - local _88_ 4488 4488 - if (options["escape-newlines?"] and (length_2a(str) < (options["line-length"] - indent))) then 4489 4489 - _88_ = "\\n" 4490 4490 - else 4491 4491 - _88_ = "\n" 4492 4492 - end 4493 4493 - local function _90_(_241, _242) 4494 4494 - return ("\\%03d"):format(_242:byte()) 4495 4495 - end 4496 4496 - escs = setmetatable({["\7"] = "\\a", ["\8"] = "\\b", ["\12"] = "\\f", ["\11"] = "\\v", ["\13"] = "\\r", ["\9"] = "\\t", ["\\"] = "\\\\", ["\""] = "\\\"", ["\n"] = _88_}, {__index = _90_}) 4497 4497 - local str0 = ("\"" .. str:gsub("[%c\\\"]", escs) .. "\"") 4498 4498 - if options["utf8?"] then 4499 4499 - return utf8_escape(str0) 4500 4500 - else 4501 4501 - return str0 4502 4502 - end 4503 4503 - end 4504 4504 - local function make_options(t, options) 4505 4505 - local defaults = {["line-length"] = 80, ["one-line?"] = false, depth = 128, ["detect-cycles?"] = true, ["empty-as-sequence?"] = false, ["metamethod?"] = true, ["prefer-colon?"] = false, ["escape-newlines?"] = false, ["utf8?"] = true, ["max-sparse-gap"] = 10} 4506 4506 - local overrides = {level = 0, appearances = count_table_appearances(t, {}), seen = {len = 0}} 4507 4507 - for k, v in pairs((options or {})) do 4508 4508 - defaults[k] = v 4509 4509 - end 4510 4510 - for k, v in pairs(overrides) do 4511 4511 - defaults[k] = v 4512 4512 - end 4513 4513 - return defaults 4514 4514 - end 4515 4515 - local function _92_(x, options, indent, colon_3f) 4516 4516 - local indent0 = (indent or 0) 4517 4517 - local options0 = (options or make_options(x)) 4518 4518 - local x0 4519 4519 - if options0.preprocess then 4520 4520 - x0 = options0.preprocess(x, options0) 4521 4521 - else 4522 4522 - x0 = x 4523 4523 - end 4524 4524 - local tv = type(x0) 4525 4525 - local function _95_() 4526 4526 - local _94_ = getmetatable(x0) 4527 4527 - if (nil ~= _94_) then 4528 4528 - return (_94_).__fennelview 4529 4529 - else 4530 4530 - return _94_ 4531 4531 - end 4532 4532 - end 4533 4533 - if ((tv == "table") or ((tv == "userdata") and _95_())) then 4534 4534 - return pp_table(x0, options0, indent0) 4535 4535 - elseif (tv == "number") then 4536 4536 - return number__3estring(x0) 4537 4537 - else 4538 4538 - local function _97_() 4539 4539 - if (colon_3f ~= nil) then 4540 4540 - return colon_3f 4541 4541 - elseif ("function" == type(options0["prefer-colon?"])) then 4542 4542 - return options0["prefer-colon?"](x0) 4543 4543 - else 4544 4544 - return options0["prefer-colon?"] 4545 4545 - end 4546 4546 - end 4547 4547 - if ((tv == "string") and colon_string_3f(x0) and _97_()) then 4548 4548 - return (":" .. x0) 4549 4549 - elseif (tv == "string") then 4550 4550 - return pp_string(x0, options0, indent0) 4551 4551 - elseif ((tv == "boolean") or (tv == "nil")) then 4552 4552 - return tostring(x0) 4553 4553 - else 4554 4554 - return ("#<" .. tostring(x0) .. ">") 4555 4555 - end 4556 4556 - end 4557 4557 - end 4558 4558 - pp = _92_ 4559 4559 - local function view(x, _3foptions) 4560 4560 - return pp(x, make_options(x, _3foptions), 0) 4561 4561 - end 4562 4562 - return view 4563 4563 - end 4564 4564 - package.preload["fennel.utils"] = package.preload["fennel.utils"] or function(...) 4565 4565 - local view = require("fennel.view") 4566 4566 - local version = "1.2.1" 4567 4567 - local function luajit_vm_3f() 4568 4568 - return ((nil ~= _G.jit) and (type(_G.jit) == "table") and (nil ~= _G.jit.on) and (nil ~= _G.jit.off) and (type(_G.jit.version_num) == "number")) 4569 4569 - end 4570 4570 - local function luajit_vm_version() 4571 4571 - local jit_os 4572 4572 - if (_G.jit.os == "OSX") then 4573 4573 - jit_os = "macOS" 4574 4574 - else 4575 4575 - jit_os = _G.jit.os 4576 4576 - end 4577 4577 - return (_G.jit.version .. " " .. jit_os .. "/" .. _G.jit.arch) 4578 4578 - end 4579 4579 - local function fengari_vm_3f() 4580 4580 - return ((nil ~= _G.fengari) and (type(_G.fengari) == "table") and (nil ~= _G.fengari.VERSION) and (type(_G.fengari.VERSION_NUM) == "number")) 4581 4581 - end 4582 4582 - local function fengari_vm_version() 4583 4583 - return (_G.fengari.RELEASE .. " (" .. _VERSION .. ")") 4584 4584 - end 4585 4585 - local function lua_vm_version() 4586 4586 - if luajit_vm_3f() then 4587 4587 - return luajit_vm_version() 4588 4588 - elseif fengari_vm_3f() then 4589 4589 - return fengari_vm_version() 4590 4590 - else 4591 4591 - return ("PUC " .. _VERSION) 4592 4592 - end 4593 4593 - end 4594 4594 - local function runtime_version() 4595 4595 - return ("Fennel " .. version .. " on " .. lua_vm_version()) 4596 4596 - end 4597 4597 - local function warn(message) 4598 4598 - if (_G.io and _G.io.stderr) then 4599 4599 - return (_G.io.stderr):write(("--WARNING: %s\n"):format(tostring(message))) 4600 4600 - else 4601 4601 - return nil 4602 4602 - end 4603 4603 - end 4604 4604 - local len 4605 4605 - do 4606 4606 - local _102_, _103_ = pcall(require, "utf8") 4607 4607 - if ((_102_ == true) and (nil ~= _103_)) then 4608 4608 - local utf8 = _103_ 4609 4609 - len = utf8.len 4610 4610 - elseif true then 4611 4611 - local _ = _102_ 4612 4612 - len = string.len 4613 4613 - else 4614 4614 - len = nil 4615 4615 - end 4616 4616 - end 4617 4617 - local function mt_keys_in_order(t, out, used_keys) 4618 4618 - for _, k in ipairs(getmetatable(t).keys) do 4619 4619 - if (t[k] and not used_keys[k]) then 4620 4620 - used_keys[k] = true 4621 4621 - table.insert(out, k) 4622 4622 - else 4623 4623 - end 4624 4624 - end 4625 4625 - for k in pairs(t) do 4626 4626 - if not used_keys[k] then 4627 4627 - table.insert(out, k) 4628 4628 - else 4629 4629 - end 4630 4630 - end 4631 4631 - return out 4632 4632 - end 4633 4633 - local function stablepairs(t) 4634 4634 - local keys 4635 4635 - local _108_ 4636 4636 - do 4637 4637 - local t_107_ = getmetatable(t) 4638 4638 - if (nil ~= t_107_) then 4639 4639 - t_107_ = (t_107_).keys 4640 4640 - else 4641 4641 - end 4642 4642 - _108_ = t_107_ 4643 4643 - end 4644 4644 - if _108_ then 4645 4645 - keys = mt_keys_in_order(t, {}, {}) 4646 4646 - else 4647 4647 - local _110_ 4648 4648 - do 4649 4649 - local tbl_14_auto = {} 4650 4650 - local i_15_auto = #tbl_14_auto 4651 4651 - for k in pairs(t) do 4652 4652 - local val_16_auto = k 4653 4653 - if (nil ~= val_16_auto) then 4654 4654 - i_15_auto = (i_15_auto + 1) 4655 4655 - do end (tbl_14_auto)[i_15_auto] = val_16_auto 4656 4656 - else 4657 4657 - end 4658 4658 - end 4659 4659 - _110_ = tbl_14_auto 4660 4660 - end 4661 4661 - local function _112_(_241, _242) 4662 4662 - return (tostring(_241) < tostring(_242)) 4663 4663 - end 4664 4664 - table.sort(_110_, _112_) 4665 4665 - keys = _110_ 4666 4666 - end 4667 4667 - local succ 4668 4668 - do 4669 4669 - local tbl_11_auto = {} 4670 4670 - for i, k in ipairs(keys) do 4671 4671 - local _114_, _115_ = k, keys[(i + 1)] 4672 4672 - if ((nil ~= _114_) and (nil ~= _115_)) then 4673 4673 - local k_12_auto = _114_ 4674 4674 - local v_13_auto = _115_ 4675 4675 - tbl_11_auto[k_12_auto] = v_13_auto 4676 4676 - else 4677 4677 - end 4678 4678 - end 4679 4679 - succ = tbl_11_auto 4680 4680 - end 4681 4681 - local function stablenext(tbl, key) 4682 4682 - local next_key 4683 4683 - if (key == nil) then 4684 4684 - next_key = keys[1] 4685 4685 - else 4686 4686 - next_key = succ[key] 4687 4687 - end 4688 4688 - return next_key, tbl[next_key] 4689 4689 - end 4690 4690 - return stablenext, t, nil 4691 4691 - end 4692 4692 - local function get_in(tbl, path, _3ffallback) 4693 4693 - assert(("table" == type(tbl)), "get-in expects path to be a table") 4694 4694 - if (0 == #path) then 4695 4695 - return _3ffallback 4696 4696 - else 4697 4697 - local _118_ 4698 4698 - do 4699 4699 - local t = tbl 4700 4700 - for _, k in ipairs(path) do 4701 4701 - if (nil == t) then break end 4702 4702 - local _119_ = type(t) 4703 4703 - if (_119_ == "table") then 4704 4704 - t = t[k] 4705 4705 - else 4706 4706 - t = nil 4707 4707 - end 4708 4708 - end 4709 4709 - _118_ = t 4710 4710 - end 4711 4711 - if (nil ~= _118_) then 4712 4712 - local res = _118_ 4713 4713 - return res 4714 4714 - elseif true then 4715 4715 - local _ = _118_ 4716 4716 - return _3ffallback 4717 4717 - else 4718 4718 - return nil 4719 4719 - end 4720 4720 - end 4721 4721 - end 4722 4722 - local function map(t, f, _3fout) 4723 4723 - local out = (_3fout or {}) 4724 4724 - local f0 4725 4725 - if (type(f) == "function") then 4726 4726 - f0 = f 4727 4727 - else 4728 4728 - local function _123_(_241) 4729 4729 - return (_241)[f] 4730 4730 - end 4731 4731 - f0 = _123_ 4732 4732 - end 4733 4733 - for _, x in ipairs(t) do 4734 4734 - local _125_ = f0(x) 4735 4735 - if (nil ~= _125_) then 4736 4736 - local v = _125_ 4737 4737 - table.insert(out, v) 4738 4738 - else 4739 4739 - end 4740 4740 - end 4741 4741 - return out 4742 4742 - end 4743 4743 - local function kvmap(t, f, _3fout) 4744 4744 - local out = (_3fout or {}) 4745 4745 - local f0 4746 4746 - if (type(f) == "function") then 4747 4747 - f0 = f 4748 4748 - else 4749 4749 - local function _127_(_241) 4750 4750 - return (_241)[f] 4751 4751 - end 4752 4752 - f0 = _127_ 4753 4753 - end 4754 4754 - for k, x in stablepairs(t) do 4755 4755 - local _129_, _130_ = f0(k, x) 4756 4756 - if ((nil ~= _129_) and (nil ~= _130_)) then 4757 4757 - local key = _129_ 4758 4758 - local value = _130_ 4759 4759 - out[key] = value 4760 4760 - elseif (nil ~= _129_) then 4761 4761 - local value = _129_ 4762 4762 - table.insert(out, value) 4763 4763 - else 4764 4764 - end 4765 4765 - end 4766 4766 - return out 4767 4767 - end 4768 4768 - local function copy(from, _3fto) 4769 4769 - local tbl_11_auto = (_3fto or {}) 4770 4770 - for k, v in pairs((from or {})) do 4771 4771 - local _132_, _133_ = k, v 4772 4772 - if ((nil ~= _132_) and (nil ~= _133_)) then 4773 4773 - local k_12_auto = _132_ 4774 4774 - local v_13_auto = _133_ 4775 4775 - tbl_11_auto[k_12_auto] = v_13_auto 4776 4776 - else 4777 4777 - end 4778 4778 - end 4779 4779 - return tbl_11_auto 4780 4780 - end 4781 4781 - local function member_3f(x, tbl, _3fn) 4782 4782 - local _135_ = tbl[(_3fn or 1)] 4783 4783 - if (_135_ == x) then 4784 4784 - return true 4785 4785 - elseif (_135_ == nil) then 4786 4786 - return nil 4787 4787 - elseif true then 4788 4788 - local _ = _135_ 4789 4789 - return member_3f(x, tbl, ((_3fn or 1) + 1)) 4790 4790 - else 4791 4791 - return nil 4792 4792 - end 4793 4793 - end 4794 4794 - local function allpairs(tbl) 4795 4795 - assert((type(tbl) == "table"), "allpairs expects a table") 4796 4796 - local t = tbl 4797 4797 - local seen = {} 4798 4798 - local function allpairs_next(_, state) 4799 4799 - local next_state, value = next(t, state) 4800 4800 - if seen[next_state] then 4801 4801 - return allpairs_next(nil, next_state) 4802 4802 - elseif next_state then 4803 4803 - seen[next_state] = true 4804 4804 - return next_state, value 4805 4805 - else 4806 4806 - local _137_ = getmetatable(t) 4807 4807 - if ((_G.type(_137_) == "table") and true) then 4808 4808 - local __index = (_137_).__index 4809 4809 - if ("table" == type(__index)) then 4810 4810 - t = __index 4811 4811 - return allpairs_next(t) 4812 4812 - else 4813 4813 - return nil 4814 4814 - end 4815 4815 - else 4816 4816 - return nil 4817 4817 - end 4818 4818 - end 4819 4819 - end 4820 4820 - return allpairs_next 4821 4821 - end 4822 4822 - local function deref(self) 4823 4823 - return self[1] 4824 4824 - end 4825 4825 - local nil_sym = nil 4826 4826 - local function list__3estring(self, _3ftostring2) 4827 4827 - local safe = {} 4828 4828 - local max = 0 4829 4829 - for k in pairs(self) do 4830 4830 - if ((type(k) == "number") and (max < k)) then 4831 4831 - max = k 4832 4832 - else 4833 4833 - end 4834 4834 - end 4835 4835 - for i = 1, max do 4836 4836 - safe[i] = (((self[i] == nil) and nil_sym) or self[i]) 4837 4837 - end 4838 4838 - return ("(" .. table.concat(map(safe, (_3ftostring2 or view)), " ", 1, max) .. ")") 4839 4839 - end 4840 4840 - local function comment_view(c) 4841 4841 - return c, true 4842 4842 - end 4843 4843 - local function sym_3d(a, b) 4844 4844 - return ((deref(a) == deref(b)) and (getmetatable(a) == getmetatable(b))) 4845 4845 - end 4846 4846 - local function sym_3c(a, b) 4847 4847 - return (a[1] < tostring(b)) 4848 4848 - end 4849 4849 - local symbol_mt = {__fennelview = deref, __tostring = deref, __eq = sym_3d, __lt = sym_3c, "SYMBOL"} 4850 4850 - local expr_mt 4851 4851 - local function _142_(x) 4852 4852 - return tostring(deref(x)) 4853 4853 - end 4854 4854 - expr_mt = {__tostring = _142_, "EXPR"} 4855 4855 - local list_mt = {__fennelview = list__3estring, __tostring = list__3estring, "LIST"} 4856 4856 - local comment_mt = {__fennelview = comment_view, __tostring = deref, __eq = sym_3d, __lt = sym_3c, "COMMENT"} 4857 4857 - local sequence_marker = {"SEQUENCE"} 4858 4858 - local varg_mt = {__fennelview = deref, __tostring = deref, "VARARG"} 4859 4859 - local getenv 4860 4860 - local function _143_() 4861 4861 - return nil 4862 4862 - end 4863 4863 - getenv = ((os and os.getenv) or _143_) 4864 4864 - local function debug_on_3f(flag) 4865 4865 - local level = (getenv("FENNEL_DEBUG") or "") 4866 4866 - return ((level == "all") or level:find(flag)) 4867 4867 - end 4868 4868 - local function list(...) 4869 4869 - return setmetatable({...}, list_mt) 4870 4870 - end 4871 4871 - local function sym(str, _3fsource) 4872 4872 - local _144_ 4873 4873 - do 4874 4874 - local tbl_11_auto = {str} 4875 4875 - for k, v in pairs((_3fsource or {})) do 4876 4876 - local _145_, _146_ = nil, nil 4877 4877 - if (type(k) == "string") then 4878 4878 - _145_, _146_ = k, v 4879 4879 - else 4880 4880 - _145_, _146_ = nil 4881 4881 - end 4882 4882 - if ((nil ~= _145_) and (nil ~= _146_)) then 4883 4883 - local k_12_auto = _145_ 4884 4884 - local v_13_auto = _146_ 4885 4885 - tbl_11_auto[k_12_auto] = v_13_auto 4886 4886 - else 4887 4887 - end 4888 4888 - end 4889 4889 - _144_ = tbl_11_auto 4890 4890 - end 4891 4891 - return setmetatable(_144_, symbol_mt) 4892 4892 - end 4893 4893 - nil_sym = sym("nil") 4894 4894 - local function sequence(...) 4895 4895 - return setmetatable({...}, {sequence = sequence_marker}) 4896 4896 - end 4897 4897 - local function expr(strcode, etype) 4898 4898 - return setmetatable({type = etype, strcode}, expr_mt) 4899 4899 - end 4900 4900 - local function comment_2a(contents, _3fsource) 4901 4901 - local _let_149_ = (_3fsource or {}) 4902 4902 - local filename = _let_149_["filename"] 4903 4903 - local line = _let_149_["line"] 4904 4904 - return setmetatable({filename = filename, line = line, contents}, comment_mt) 4905 4905 - end 4906 4906 - local function varg(_3fsource) 4907 4907 - local _150_ 4908 4908 - do 4909 4909 - local tbl_11_auto = {"..."} 4910 4910 - for k, v in pairs((_3fsource or {})) do 4911 4911 - local _151_, _152_ = nil, nil 4912 4912 - if (type(k) == "string") then 4913 4913 - _151_, _152_ = k, v 4914 4914 - else 4915 4915 - _151_, _152_ = nil 4916 4916 - end 4917 4917 - if ((nil ~= _151_) and (nil ~= _152_)) then 4918 4918 - local k_12_auto = _151_ 4919 4919 - local v_13_auto = _152_ 4920 4920 - tbl_11_auto[k_12_auto] = v_13_auto 4921 4921 - else 4922 4922 - end 4923 4923 - end 4924 4924 - _150_ = tbl_11_auto 4925 4925 - end 4926 4926 - return setmetatable(_150_, varg_mt) 4927 4927 - end 4928 4928 - local function expr_3f(x) 4929 4929 - return ((type(x) == "table") and (getmetatable(x) == expr_mt) and x) 4930 4930 - end 4931 4931 - local function varg_3f(x) 4932 4932 - return ((type(x) == "table") and (getmetatable(x) == varg_mt) and x) 4933 4933 - end 4934 4934 - local function list_3f(x) 4935 4935 - return ((type(x) == "table") and (getmetatable(x) == list_mt) and x) 4936 4936 - end 4937 4937 - local function sym_3f(x) 4938 4938 - return ((type(x) == "table") and (getmetatable(x) == symbol_mt) and x) 4939 4939 - end 4940 4940 - local function sequence_3f(x) 4941 4941 - local mt = ((type(x) == "table") and getmetatable(x)) 4942 4942 - return (mt and (mt.sequence == sequence_marker) and x) 4943 4943 - end 4944 4944 - local function comment_3f(x) 4945 4945 - return ((type(x) == "table") and (getmetatable(x) == comment_mt) and x) 4946 4946 - end 4947 4947 - local function table_3f(x) 4948 4948 - return ((type(x) == "table") and not varg_3f(x) and (getmetatable(x) ~= list_mt) and (getmetatable(x) ~= symbol_mt) and not comment_3f(x) and x) 4949 4949 - end 4950 4950 - local function string_3f(x) 4951 4951 - return (type(x) == "string") 4952 4952 - end 4953 4953 - local function multi_sym_3f(str) 4954 4954 - if sym_3f(str) then 4955 4955 - return multi_sym_3f(tostring(str)) 4956 4956 - elseif (type(str) ~= "string") then 4957 4957 - return false 4958 4958 - else 4959 4959 - local parts = {} 4960 4960 - for part in str:gmatch("[^%.%:]+[%.%:]?") do 4961 4961 - local last_char = part:sub(( - 1)) 4962 4962 - if (last_char == ":") then 4963 4963 - parts["multi-sym-method-call"] = true 4964 4964 - else 4965 4965 - end 4966 4966 - if ((last_char == ":") or (last_char == ".")) then 4967 4967 - parts[(#parts + 1)] = part:sub(1, ( - 2)) 4968 4968 - else 4969 4969 - parts[(#parts + 1)] = part 4970 4970 - end 4971 4971 - end 4972 4972 - return ((0 < #parts) and (str:match("%.") or str:match(":")) and not str:match("%.%.") and (str:byte() ~= string.byte(".")) and (str:byte(( - 1)) ~= string.byte(".")) and parts) 4973 4973 - end 4974 4974 - end 4975 4975 - local function quoted_3f(symbol) 4976 4976 - return symbol.quoted 4977 4977 - end 4978 4978 - local function ast_source(ast) 4979 4979 - if (table_3f(ast) or sequence_3f(ast)) then 4980 4980 - return (getmetatable(ast) or {}) 4981 4981 - elseif ("table" == type(ast)) then 4982 4982 - return ast 4983 4983 - else 4984 4984 - return {} 4985 4985 - end 4986 4986 - end 4987 4987 - local function walk_tree(root, f, _3fcustom_iterator) 4988 4988 - local function walk(iterfn, parent, idx, node) 4989 4989 - if f(idx, node, parent) then 4990 4990 - for k, v in iterfn(node) do 4991 4991 - walk(iterfn, node, k, v) 4992 4992 - end 4993 4993 - return nil 4994 4994 - else 4995 4995 - return nil 4996 4996 - end 4997 4997 - end 4998 4998 - walk((_3fcustom_iterator or pairs), nil, nil, root) 4999 4999 - return root 5000 5000 - end 5001 5001 - local lua_keywords = {"and", "break", "do", "else", "elseif", "end", "false", "for", "function", "if", "in", "local", "nil", "not", "or", "repeat", "return", "then", "true", "until", "while", "goto"} 5002 5002 - for i, v in ipairs(lua_keywords) do 5003 5003 - lua_keywords[v] = i 5004 5004 - end 5005 5005 - local function valid_lua_identifier_3f(str) 5006 5006 - return (str:match("^[%a_][%w_]*$") and not lua_keywords[str]) 5007 5007 - end 5008 5008 - local propagated_options = {"allowedGlobals", "indent", "correlate", "useMetadata", "env", "compiler-env", "compilerEnv"} 5009 5009 - local function propagate_options(options, subopts) 5010 5010 - for _, name in ipairs(propagated_options) do 5011 5011 - subopts[name] = options[name] 5012 5012 - end 5013 5013 - return subopts 5014 5014 - end 5015 5015 - local root 5016 5016 - local function _160_() 5017 5017 - end 5018 5018 - root = {chunk = nil, scope = nil, options = nil, reset = _160_} 5019 5019 - root["set-reset"] = function(_161_) 5020 5020 - local _arg_162_ = _161_ 5021 5021 - local chunk = _arg_162_["chunk"] 5022 5022 - local scope = _arg_162_["scope"] 5023 5023 - local options = _arg_162_["options"] 5024 5024 - local reset = _arg_162_["reset"] 5025 5025 - root.reset = function() 5026 5026 - root.chunk, root.scope, root.options, root.reset = chunk, scope, options, reset 5027 5027 - return nil 5028 5028 - end 5029 5029 - return root.reset 5030 5030 - end 5031 5031 - local warned = {} 5032 5032 - local function check_plugin_version(_163_) 5033 5033 - local _arg_164_ = _163_ 5034 5034 - local name = _arg_164_["name"] 5035 5035 - local versions = _arg_164_["versions"] 5036 5036 - local plugin = _arg_164_ 5037 5037 - if (not member_3f(version:gsub("-dev", ""), (versions or {})) and not warned[plugin]) then 5038 5038 - warned[plugin] = true 5039 5039 - return warn(string.format("plugin %s does not support Fennel version %s", (name or "unknown"), version)) 5040 5040 - else 5041 5041 - return nil 5042 5042 - end 5043 5043 - end 5044 5044 - local function hook_opts(event, _3foptions, ...) 5045 5045 - local plugins 5046 5046 - local function _167_(...) 5047 5047 - local t_166_ = _3foptions 5048 5048 - if (nil ~= t_166_) then 5049 5049 - t_166_ = (t_166_).plugins 5050 5050 - else 5051 5051 - end 5052 5052 - return t_166_ 5053 5053 - end 5054 5054 - local function _170_(...) 5055 5055 - local t_169_ = root.options 5056 5056 - if (nil ~= t_169_) then 5057 5057 - t_169_ = (t_169_).plugins 5058 5058 - else 5059 5059 - end 5060 5060 - return t_169_ 5061 5061 - end 5062 5062 - plugins = (_167_(...) or _170_(...)) 5063 5063 - if plugins then 5064 5064 - local result = nil 5065 5065 - for _, plugin in ipairs(plugins) do 5066 5066 - if result then break end 5067 5067 - check_plugin_version(plugin) 5068 5068 - local _172_ = plugin[event] 5069 5069 - if (nil ~= _172_) then 5070 5070 - local f = _172_ 5071 5071 - result = f(...) 5072 5072 - else 5073 5073 - result = nil 5074 5074 - end 5075 5075 - end 5076 5076 - return result 5077 5077 - else 5078 5078 - return nil 5079 5079 - end 5080 5080 - end 5081 5081 - local function hook(event, ...) 5082 5082 - return hook_opts(event, root.options, ...) 5083 5083 - end 5084 5084 - return {warn = warn, allpairs = allpairs, stablepairs = stablepairs, copy = copy, ["get-in"] = get_in, kvmap = kvmap, map = map, ["walk-tree"] = walk_tree, ["member?"] = member_3f, list = list, sequence = sequence, sym = sym, varg = varg, expr = expr, comment = comment_2a, ["comment?"] = comment_3f, ["expr?"] = expr_3f, ["list?"] = list_3f, ["multi-sym?"] = multi_sym_3f, ["sequence?"] = sequence_3f, ["sym?"] = sym_3f, ["table?"] = table_3f, ["varg?"] = varg_3f, ["quoted?"] = quoted_3f, ["string?"] = string_3f, ["valid-lua-identifier?"] = valid_lua_identifier_3f, ["lua-keywords"] = lua_keywords, hook = hook, ["hook-opts"] = hook_opts, ["propagate-options"] = propagate_options, root = root, ["debug-on?"] = debug_on_3f, ["ast-source"] = ast_source, version = version, ["runtime-version"] = runtime_version, len = len, path = table.concat({"./?.fnl", "./?/init.fnl", getenv("FENNEL_PATH")}, ";"), ["macro-path"] = table.concat({"./?.fnl", "./?/init-macros.fnl", "./?/init.fnl", getenv("FENNEL_MACRO_PATH")}, ";")} 5085 5085 - end 5086 5086 - utils = require("fennel.utils") 5087 5087 - local parser = require("fennel.parser") 5088 5088 - local compiler = require("fennel.compiler") 5089 5089 - local specials = require("fennel.specials") 5090 5090 - local repl = require("fennel.repl") 5091 5091 - local view = require("fennel.view") 5092 5092 - local function eval_env(env, opts) 5093 5093 - if (env == "_COMPILER") then 5094 5094 - local env0 = specials["make-compiler-env"](nil, compiler.scopes.compiler, {}, opts) 5095 5095 - if (opts.allowedGlobals == nil) then 5096 5096 - opts.allowedGlobals = specials["current-global-names"](env0) 5097 5097 - else 5098 5098 - end 5099 5099 - return specials["wrap-env"](env0) 5100 5100 - else 5101 5101 - return (env and specials["wrap-env"](env)) 5102 5102 - end 5103 5103 - end 5104 5104 - local function eval_opts(options, str) 5105 5105 - local opts = utils.copy(options) 5106 5106 - if (opts.allowedGlobals == nil) then 5107 5107 - opts.allowedGlobals = specials["current-global-names"](opts.env) 5108 5108 - else 5109 5109 - end 5110 5110 - if (not opts.filename and not opts.source) then 5111 5111 - opts.source = str 5112 5112 - else 5113 5113 - end 5114 5114 - if (opts.env == "_COMPILER") then 5115 5115 - opts.scope = compiler["make-scope"](compiler.scopes.compiler) 5116 5116 - else 5117 5117 - end 5118 5118 - return opts 5119 5119 - end 5120 5120 - local function eval(str, options, ...) 5121 5121 - local opts = eval_opts(options, str) 5122 5122 - local env = eval_env(opts.env, opts) 5123 5123 - local lua_source = compiler["compile-string"](str, opts) 5124 5124 - local loader 5125 5125 - local function _735_(...) 5126 5126 - if opts.filename then 5127 5127 - return ("@" .. opts.filename) 5128 5128 - else 5129 5129 - return str 5130 5130 - end 5131 5131 - end 5132 5132 - loader = specials["load-code"](lua_source, env, _735_(...)) 5133 5133 - opts.filename = nil 5134 5134 - return loader(...) 5135 5135 - end 5136 5136 - local function dofile_2a(filename, options, ...) 5137 5137 - local opts = utils.copy(options) 5138 5138 - local f = assert(io.open(filename, "rb")) 5139 5139 - local source = assert(f:read("*all"), ("Could not read " .. filename)) 5140 5140 - f:close() 5141 5141 - opts.filename = filename 5142 5142 - return eval(source, opts, ...) 5143 5143 - end 5144 5144 - local function syntax() 5145 5145 - local body_3f = {"when", "with-open", "collect", "icollect", "fcollect", "lambda", "\206\187", "macro", "match", "match-try", "accumulate", "doto"} 5146 5146 - local binding_3f = {"collect", "icollect", "fcollect", "each", "for", "let", "with-open", "accumulate"} 5147 5147 - local define_3f = {"fn", "lambda", "\206\187", "var", "local", "macro", "macros", "global"} 5148 5148 - local out = {} 5149 5149 - for k, v in pairs(compiler.scopes.global.specials) do 5150 5150 - local metadata = (compiler.metadata[v] or {}) 5151 5151 - do end (out)[k] = {["special?"] = true, ["body-form?"] = metadata["fnl/body-form?"], ["binding-form?"] = utils["member?"](k, binding_3f), ["define?"] = utils["member?"](k, define_3f)} 5152 5152 - end 5153 5153 - for k, v in pairs(compiler.scopes.global.macros) do 5154 5154 - out[k] = {["macro?"] = true, ["body-form?"] = utils["member?"](k, body_3f), ["binding-form?"] = utils["member?"](k, binding_3f), ["define?"] = utils["member?"](k, define_3f)} 5155 5155 - end 5156 5156 - for k, v in pairs(_G) do 5157 5157 - local _736_ = type(v) 5158 5158 - if (_736_ == "function") then 5159 5159 - out[k] = {["global?"] = true, ["function?"] = true} 5160 5160 - elseif (_736_ == "table") then 5161 5161 - for k2, v2 in pairs(v) do 5162 5162 - if (("function" == type(v2)) and (k ~= "_G")) then 5163 5163 - out[(k .. "." .. k2)] = {["function?"] = true, ["global?"] = true} 5164 5164 - else 5165 5165 - end 5166 5166 - end 5167 5167 - out[k] = {["global?"] = true} 5168 5168 - else 5169 5169 - end 5170 5170 - end 5171 5171 - return out 5172 5172 - end 5173 5173 - local mod = {list = utils.list, ["list?"] = utils["list?"], sym = utils.sym, ["sym?"] = utils["sym?"], ["multi-sym?"] = utils["multi-sym?"], sequence = utils.sequence, ["sequence?"] = utils["sequence?"], ["table?"] = utils["table?"], comment = utils.comment, ["comment?"] = utils["comment?"], varg = utils.varg, ["varg?"] = utils["varg?"], ["sym-char?"] = parser["sym-char?"], parser = parser.parser, compile = compiler.compile, ["compile-string"] = compiler["compile-string"], ["compile-stream"] = compiler["compile-stream"], eval = eval, repl = repl, view = view, dofile = dofile_2a, ["load-code"] = specials["load-code"], doc = specials.doc, metadata = compiler.metadata, traceback = compiler.traceback, version = utils.version, ["runtime-version"] = utils["runtime-version"], ["ast-source"] = utils["ast-source"], path = utils.path, ["macro-path"] = utils["macro-path"], ["macro-loaded"] = specials["macro-loaded"], ["macro-searchers"] = specials["macro-searchers"], ["search-module"] = specials["search-module"], ["make-searcher"] = specials["make-searcher"], searcher = specials["make-searcher"](), syntax = syntax, gensym = compiler.gensym, scope = compiler["make-scope"], mangle = compiler["global-mangling"], unmangle = compiler["global-unmangling"], compile1 = compiler.compile1, ["string-stream"] = parser["string-stream"], granulate = parser.granulate, loadCode = specials["load-code"], make_searcher = specials["make-searcher"], makeSearcher = specials["make-searcher"], searchModule = specials["search-module"], macroPath = utils["macro-path"], macroSearchers = specials["macro-searchers"], macroLoaded = specials["macro-loaded"], compileStream = compiler["compile-stream"], compileString = compiler["compile-string"], stringStream = parser["string-stream"], runtimeVersion = utils["runtime-version"]} 5174 5174 - mod.install = function(_3fopts) 5175 5175 - table.insert((package.searchers or package.loaders), specials["make-searcher"](_3fopts)) 5176 5176 - return mod 5177 5177 - end 5178 5178 - utils["fennel-module"] = mod 5179 5179 - do 5180 5180 - local builtin_macros = [===[;; These macros are awkward because their definition cannot rely on the any 5181 5181 - ;; built-in macros, only special forms. (no when, no icollect, etc) 5182 5182 - 5183 5183 - (fn copy [t] 5184 5184 - (let [out []] 5185 5185 - (each [_ v (ipairs t)] (table.insert out v)) 5186 5186 - (setmetatable out (getmetatable t)))) 5187 5187 - 5188 5188 - (fn ->* [val ...] 5189 5189 - "Thread-first macro. 5190 5190 - Take the first value and splice it into the second form as its first argument. 5191 5191 - The value of the second form is spliced into the first arg of the third, etc." 5192 5192 - (var x val) 5193 5193 - (each [_ e (ipairs [...])] 5194 5194 - (let [elt (if (list? e) (copy e) (list e))] 5195 5195 - (table.insert elt 2 x) 5196 5196 - (set x elt))) 5197 5197 - x) 5198 5198 - 5199 5199 - (fn ->>* [val ...] 5200 5200 - "Thread-last macro. 5201 5201 - Same as ->, except splices the value into the last position of each form 5202 5202 - rather than the first." 5203 5203 - (var x val) 5204 5204 - (each [_ e (ipairs [...])] 5205 5205 - (let [elt (if (list? e) (copy e) (list e))] 5206 5206 - (table.insert elt x) 5207 5207 - (set x elt))) 5208 5208 - x) 5209 5209 - 5210 5210 - (fn -?>* [val ?e ...] 5211 5211 - "Nil-safe thread-first macro. 5212 5212 - Same as -> except will short-circuit with nil when it encounters a nil value." 5213 5213 - (if (= nil ?e) 5214 5214 - val 5215 5215 - (let [el (if (list? ?e) (copy ?e) (list ?e)) 5216 5216 - tmp (gensym)] 5217 5217 - (table.insert el 2 tmp) 5218 5218 - `(let [,tmp ,val] 5219 5219 - (if (not= nil ,tmp) 5220 5220 - (-?> ,el ,...) 5221 5221 - ,tmp))))) 5222 5222 - 5223 5223 - (fn -?>>* [val ?e ...] 5224 5224 - "Nil-safe thread-last macro. 5225 5225 - Same as ->> except will short-circuit with nil when it encounters a nil value." 5226 5226 - (if (= nil ?e) 5227 5227 - val 5228 5228 - (let [el (if (list? ?e) (copy ?e) (list ?e)) 5229 5229 - tmp (gensym)] 5230 5230 - (table.insert el tmp) 5231 5231 - `(let [,tmp ,val] 5232 5232 - (if (not= ,tmp nil) 5233 5233 - (-?>> ,el ,...) 5234 5234 - ,tmp))))) 5235 5235 - 5236 5236 - (fn ?dot [tbl ...] 5237 5237 - "Nil-safe table look up. 5238 5238 - Same as . (dot), except will short-circuit with nil when it encounters 5239 5239 - a nil value in any of subsequent keys." 5240 5240 - (let [head (gensym :t) 5241 5241 - lookups `(do 5242 5242 - (var ,head ,tbl) 5243 5243 - ,head)] 5244 5244 - (each [_ k (ipairs [...])] 5245 5245 - ;; Kinda gnarly to reassign in place like this, but it emits the best lua. 5246 5246 - ;; With this impl, it emits a flat, concise, and readable set of ifs 5247 5247 - (table.insert lookups (# lookups) `(if (not= nil ,head) 5248 5248 - (set ,head (. ,head ,k))))) 5249 5249 - lookups)) 5250 5250 - 5251 5251 - (fn doto* [val ...] 5252 5252 - "Evaluate val and splice it into the first argument of subsequent forms." 5253 5253 - (assert (not= val nil) "missing subject") 5254 5254 - (let [rebind? (or (not (sym? val)) 5255 5255 - (multi-sym? val)) 5256 5256 - name (if rebind? (gensym) val) 5257 5257 - form (if rebind? `(let [,name ,val]) `(do))] 5258 5258 - (each [_ elt (ipairs [...])] 5259 5259 - (let [elt (if (list? elt) (copy elt) (list elt))] 5260 5260 - (table.insert elt 2 name) 5261 5261 - (table.insert form elt))) 5262 5262 - (table.insert form name) 5263 5263 - form)) 5264 5264 - 5265 5265 - (fn when* [condition body1 ...] 5266 5266 - "Evaluate body for side-effects only when condition is truthy." 5267 5267 - (assert body1 "expected body") 5268 5268 - `(if ,condition 5269 5269 - (do 5270 5270 - ,body1 5271 5271 - ,...))) 5272 5272 - 5273 5273 - (fn with-open* [closable-bindings ...] 5274 5274 - "Like `let`, but invokes (v:close) on each binding after evaluating the body. 5275 5275 - The body is evaluated inside `xpcall` so that bound values will be closed upon 5276 5276 - encountering an error before propagating it." 5277 5277 - (let [bodyfn `(fn [] 5278 5278 - ,...) 5279 5279 - closer `(fn close-handlers# [ok# ...] 5280 5280 - (if ok# ... (error ... 0))) 5281 5281 - traceback `(. (or package.loaded.fennel debug) :traceback)] 5282 5282 - (for [i 1 (length closable-bindings) 2] 5283 5283 - (assert (sym? (. closable-bindings i)) 5284 5284 - "with-open only allows symbols in bindings") 5285 5285 - (table.insert closer 4 `(: ,(. closable-bindings i) :close))) 5286 5286 - `(let ,closable-bindings 5287 5287 - ,closer 5288 5288 - (close-handlers# (_G.xpcall ,bodyfn ,traceback))))) 5289 5289 - 5290 5290 - (fn extract-into [iter-tbl] 5291 5291 - (var (into iter-out found?) (values [] (copy iter-tbl))) 5292 5292 - (for [i (length iter-tbl) 2 -1] 5293 5293 - (let [item (. iter-tbl i)] 5294 5294 - (if (or (= `&into item) 5295 5295 - (= :into item)) 5296 5296 - (do 5297 5297 - (assert (not found?) "expected only one &into clause") 5298 5298 - (set found? true) 5299 5299 - (set into (. iter-tbl (+ i 1))) 5300 5300 - (table.remove iter-out i) 5301 5301 - (table.remove iter-out i))))) 5302 5302 - (assert (or (not found?) (sym? into) (table? into) (list? into)) 5303 5303 - "expected table, function call, or symbol in &into clause") 5304 5304 - (values into iter-out)) 5305 5305 - 5306 5306 - (fn collect* [iter-tbl key-expr value-expr ...] 5307 5307 - "Return a table made by running an iterator and evaluating an expression that 5308 5308 - returns key-value pairs to be inserted sequentially into the table. This can 5309 5309 - be thought of as a table comprehension. The body should provide two expressions 5310 5310 - (used as key and value) or nil, which causes it to be omitted. 5311 5311 - 5312 5312 - For example, 5313 5313 - (collect [k v (pairs {:apple \"red\" :orange \"orange\"})] 5314 5314 - (values v k)) 5315 5315 - returns 5316 5316 - {:red \"apple\" :orange \"orange\"} 5317 5317 - 5318 5318 - Supports an &into clause after the iterator to put results in an existing table. 5319 5319 - Supports early termination with an &until clause." 5320 5320 - (assert (and (sequence? iter-tbl) (<= 2 (length iter-tbl))) 5321 5321 - "expected iterator binding table") 5322 5322 - (assert (not= nil key-expr) "expected key and value expression") 5323 5323 - (assert (= nil ...) 5324 5324 - "expected 1 or 2 body expressions; wrap multiple expressions with do") 5325 5325 - (let [kv-expr (if (= nil value-expr) key-expr `(values ,key-expr ,value-expr)) 5326 5326 - (into iter) (extract-into iter-tbl)] 5327 5327 - `(let [tbl# ,into] 5328 5328 - (each ,iter 5329 5329 - (match ,kv-expr 5330 5330 - (k# v#) (tset tbl# k# v#))) 5331 5331 - tbl#))) 5332 5332 - 5333 5333 - (fn seq-collect [how iter-tbl value-expr ...] 5334 5334 - "Common part between icollect and fcollect for producing sequential tables. 5335 5335 - 5336 5336 - Iteration code only deffers in using the for or each keyword, the rest 5337 5337 - of the generated code is identical." 5338 5338 - (assert (not= nil value-expr) "expected table value expression") 5339 5339 - (assert (= nil ...) 5340 5340 - "expected exactly one body expression. Wrap multiple expressions in do") 5341 5341 - (let [(into iter) (extract-into iter-tbl)] 5342 5342 - `(let [tbl# ,into] 5343 5343 - ;; believe it or not, using a var here has a pretty good performance 5344 5344 - ;; boost: https://p.hagelb.org/icollect-performance.html 5345 5345 - (var i# (length tbl#)) 5346 5346 - (,how ,iter 5347 5347 - (let [val# ,value-expr] 5348 5348 - (when (not= nil val#) 5349 5349 - (set i# (+ i# 1)) 5350 5350 - (tset tbl# i# val#)))) 5351 5351 - tbl#))) 5352 5352 - 5353 5353 - (fn icollect* [iter-tbl value-expr ...] 5354 5354 - "Return a sequential table made by running an iterator and evaluating an 5355 5355 - expression that returns values to be inserted sequentially into the table. 5356 5356 - This can be thought of as a table comprehension. If the body evaluates to nil 5357 5357 - that element is omitted. 5358 5358 - 5359 5359 - For example, 5360 5360 - (icollect [_ v (ipairs [1 2 3 4 5])] 5361 5361 - (when (not= v 3) 5362 5362 - (* v v))) 5363 5363 - returns 5364 5364 - [1 4 16 25] 5365 5365 - 5366 5366 - Supports an &into clause after the iterator to put results in an existing table. 5367 5367 - Supports early termination with an &until clause." 5368 5368 - (assert (and (sequence? iter-tbl) (<= 2 (length iter-tbl))) 5369 5369 - "expected iterator binding table") 5370 5370 - (seq-collect 'each iter-tbl value-expr ...)) 5371 5371 - 5372 5372 - (fn fcollect* [iter-tbl value-expr ...] 5373 5373 - "Return a sequential table made by advancing a range as specified by 5374 5374 - for, and evaluating an expression that returns values to be inserted 5375 5375 - sequentially into the table. This can be thought of as a range 5376 5376 - comprehension. If the body evaluates to nil that element is omitted. 5377 5377 - 5378 5378 - For example, 5379 5379 - (fcollect [i 1 10 2] 5380 5380 - (when (not= i 3) 5381 5381 - (* i i))) 5382 5382 - returns 5383 5383 - [1 25 49 81] 5384 5384 - 5385 5385 - Supports an &into clause after the range to put results in an existing table. 5386 5386 - Supports early termination with an &until clause." 5387 5387 - (assert (and (sequence? iter-tbl) (< 2 (length iter-tbl))) 5388 5388 - "expected range binding table") 5389 5389 - (seq-collect 'for iter-tbl value-expr ...)) 5390 5390 - 5391 5391 - (fn accumulate* [iter-tbl body ...] 5392 5392 - "Accumulation macro. 5393 5393 - 5394 5394 - It takes a binding table and an expression as its arguments. In the binding 5395 5395 - table, the first form starts out bound to the second value, which is an initial 5396 5396 - accumulator. The rest are an iterator binding table in the format `each` takes. 5397 5397 - 5398 5398 - It runs through the iterator in each step of which the given expression is 5399 5399 - evaluated, and the accumulator is set to the value of the expression. It 5400 5400 - eventually returns the final value of the accumulator. 5401 5401 - 5402 5402 - For example, 5403 5403 - (accumulate [total 0 5404 5404 - _ n (pairs {:apple 2 :orange 3})] 5405 5405 - (+ total n)) 5406 5406 - returns 5" 5407 5407 - (assert (and (sequence? iter-tbl) (<= 4 (length iter-tbl))) 5408 5408 - "expected initial value and iterator binding table") 5409 5409 - (assert (not= nil body) "expected body expression") 5410 5410 - (assert (= nil ...) 5411 5411 - "expected exactly one body expression. Wrap multiple expressions with do") 5412 5412 - (let [accum-var (. iter-tbl 1) 5413 5413 - accum-init (. iter-tbl 2)] 5414 5414 - `(do 5415 5415 - (var ,accum-var ,accum-init) 5416 5416 - (each ,[(unpack iter-tbl 3)] 5417 5417 - (set ,accum-var ,body)) 5418 5418 - ,(if (list? accum-var) 5419 5419 - (list (sym :values) (unpack accum-var)) 5420 5420 - accum-var)))) 5421 5421 - 5422 5422 - (fn double-eval-safe? [x type] 5423 5423 - (or (= :number type) (= :string type) (= :boolean type) 5424 5424 - (and (sym? x) (not (multi-sym? x))))) 5425 5425 - 5426 5426 - (fn partial* [f ...] 5427 5427 - "Return a function with all arguments partially applied to f." 5428 5428 - (assert f "expected a function to partially apply") 5429 5429 - (let [bindings [] 5430 5430 - args []] 5431 5431 - (each [_ arg (ipairs [...])] 5432 5432 - (if (double-eval-safe? arg (type arg)) 5433 5433 - (table.insert args arg) 5434 5434 - (let [name (gensym)] 5435 5435 - (table.insert bindings name) 5436 5436 - (table.insert bindings arg) 5437 5437 - (table.insert args name)))) 5438 5438 - (let [body (list f (unpack args))] 5439 5439 - (table.insert body _VARARG) 5440 5440 - ;; only use the extra let if we need double-eval protection 5441 5441 - (if (= 0 (length bindings)) 5442 5442 - `(fn [,_VARARG] ,body) 5443 5443 - `(let ,bindings 5444 5444 - (fn [,_VARARG] ,body)))))) 5445 5445 - 5446 5446 - (fn pick-args* [n f] 5447 5447 - "Create a function of arity n that applies its arguments to f. 5448 5448 - 5449 5449 - For example, 5450 5450 - (pick-args 2 func) 5451 5451 - expands to 5452 5452 - (fn [_0_ _1_] (func _0_ _1_))" 5453 5453 - (if (and _G.io _G.io.stderr) 5454 5454 - (_G.io.stderr:write 5455 5455 - "-- WARNING: pick-args is deprecated and will be removed in the future.\n")) 5456 5456 - (assert (and (= (type n) :number) (= n (math.floor n)) (<= 0 n)) 5457 5457 - (.. "Expected n to be an integer literal >= 0, got " (tostring n))) 5458 5458 - (let [bindings []] 5459 5459 - (for [i 1 n] 5460 5460 - (tset bindings i (gensym))) 5461 5461 - `(fn ,bindings 5462 5462 - (,f ,(unpack bindings))))) 5463 5463 - 5464 5464 - (fn pick-values* [n ...] 5465 5465 - "Evaluate to exactly n values. 5466 5466 - 5467 5467 - For example, 5468 5468 - (pick-values 2 ...) 5469 5469 - expands to 5470 5470 - (let [(_0_ _1_) ...] 5471 5471 - (values _0_ _1_))" 5472 5472 - (assert (and (= :number (type n)) (<= 0 n) (= n (math.floor n))) 5473 5473 - (.. "Expected n to be an integer >= 0, got " (tostring n))) 5474 5474 - (let [let-syms (list) 5475 5475 - let-values (if (= 1 (select "#" ...)) ... `(values ,...))] 5476 5476 - (for [i 1 n] 5477 5477 - (table.insert let-syms (gensym))) 5478 5478 - (if (= n 0) `(values) 5479 5479 - `(let [,let-syms ,let-values] 5480 5480 - (values ,(unpack let-syms)))))) 5481 5481 - 5482 5482 - (fn lambda* [...] 5483 5483 - "Function literal with nil-checked arguments. 5484 5484 - Like `fn`, but will throw an exception if a declared argument is passed in as 5485 5485 - nil, unless that argument's name begins with a question mark." 5486 5486 - (let [args [...] 5487 5487 - has-internal-name? (sym? (. args 1)) 5488 5488 - arglist (if has-internal-name? (. args 2) (. args 1)) 5489 5489 - docstring-position (if has-internal-name? 3 2) 5490 5490 - has-docstring? (and (< docstring-position (length args)) 5491 5491 - (= :string (type (. args docstring-position)))) 5492 5492 - arity-check-position (- 4 (if has-internal-name? 0 1) 5493 5493 - (if has-docstring? 0 1)) 5494 5494 - empty-body? (< (length args) arity-check-position)] 5495 5495 - (fn check! [a] 5496 5496 - (if (table? a) 5497 5497 - (each [_ a (pairs a)] 5498 5498 - (check! a)) 5499 5499 - (let [as (tostring a)] 5500 5500 - (and (not (as:match "^?")) (not= as "&") (not= as "_") 5501 5501 - (not= as "...") (not= as "&as"))) 5502 5502 - (table.insert args arity-check-position 5503 5503 - `(_G.assert (not= nil ,a) 5504 5504 - ,(: "Missing argument %s on %s:%s" :format 5505 5505 - (tostring a) 5506 5506 - (or a.filename :unknown) 5507 5507 - (or a.line "?")))))) 5508 5508 - 5509 5509 - (assert (= :table (type arglist)) "expected arg list") 5510 5510 - (each [_ a (ipairs arglist)] 5511 5511 - (check! a)) 5512 5512 - (if empty-body? 5513 5513 - (table.insert args (sym :nil))) 5514 5514 - `(fn ,(unpack args)))) 5515 5515 - 5516 5516 - (fn macro* [name ...] 5517 5517 - "Define a single macro." 5518 5518 - (assert (sym? name) "expected symbol for macro name") 5519 5519 - (local args [...]) 5520 5520 - `(macros {,(tostring name) (fn ,(unpack args))})) 5521 5521 - 5522 5522 - (fn macrodebug* [form return?] 5523 5523 - "Print the resulting form after performing macroexpansion. 5524 5524 - With a second argument, returns expanded form as a string instead of printing." 5525 5525 - (let [handle (if return? `do `print)] 5526 5526 - `(,handle ,(view (macroexpand form _SCOPE))))) 5527 5527 - 5528 5528 - (fn import-macros* [binding1 module-name1 ...] 5529 5529 - "Bind a table of macros from each macro module according to a binding form. 5530 5530 - Each binding form can be either a symbol or a k/v destructuring table. 5531 5531 - Example: 5532 5532 - (import-macros mymacros :my-macros ; bind to symbol 5533 5533 - {:macro1 alias : macro2} :proj.macros) ; import by name" 5534 5534 - (assert (and binding1 module-name1 (= 0 (% (select "#" ...) 2))) 5535 5535 - "expected even number of binding/modulename pairs") 5536 5536 - (for [i 1 (select "#" binding1 module-name1 ...) 2] 5537 5537 - ;; delegate the actual loading of the macros to the require-macros 5538 5538 - ;; special which already knows how to set up the compiler env and stuff. 5539 5539 - ;; this is weird because require-macros is deprecated but it works. 5540 5540 - (let [(binding modname) (select i binding1 module-name1 ...) 5541 5541 - scope (get-scope) 5542 5542 - ;; if the module-name is an expression (and not just a string) we 5543 5543 - ;; patch our expression to have the correct source filename so 5544 5544 - ;; require-macros can pass it down when resolving the module-name. 5545 5545 - expr `(import-macros ,modname) 5546 5546 - filename (if (list? modname) (. modname 1 :filename) :unknown) 5547 5547 - _ (tset expr :filename filename) 5548 5548 - macros* (_SPECIALS.require-macros expr scope {} binding)] 5549 5549 - (if (sym? binding) 5550 5550 - ;; bind whole table of macros to table bound to symbol 5551 5551 - (tset scope.macros (. binding 1) macros*) 5552 5552 - ;; 1-level table destructuring for importing individual macros 5553 5553 - (table? binding) 5554 5554 - (each [macro-name [import-key] (pairs binding)] 5555 5555 - (assert (= :function (type (. macros* macro-name))) 5556 5556 - (.. "macro " macro-name " not found in module " 5557 5557 - (tostring modname))) 5558 5558 - (tset scope.macros import-key (. macros* macro-name)))))) 5559 5559 - nil) 5560 5560 - 5561 5561 - ;;; Pattern matching 5562 5562 - 5563 5563 - (fn match-values [vals pattern unifications match-pattern] 5564 5564 - (let [condition `(and) 5565 5565 - bindings []] 5566 5566 - (each [i pat (ipairs pattern)] 5567 5567 - (let [(subcondition subbindings) (match-pattern [(. vals i)] pat 5568 5568 - unifications)] 5569 5569 - (table.insert condition subcondition) 5570 5570 - (each [_ b (ipairs subbindings)] 5571 5571 - (table.insert bindings b)))) 5572 5572 - (values condition bindings))) 5573 5573 - 5574 5574 - (fn match-table [val pattern unifications match-pattern] 5575 5575 - (let [condition `(and (= (_G.type ,val) :table)) 5576 5576 - bindings []] 5577 5577 - (each [k pat (pairs pattern)] 5578 5578 - (if (= pat `&) 5579 5579 - (let [rest-pat (. pattern (+ k 1)) 5580 5580 - rest-val `(select ,k ((or table.unpack _G.unpack) ,val)) 5581 5581 - subcondition (match-table `(pick-values 1 ,rest-val) 5582 5582 - rest-pat unifications match-pattern)] 5583 5583 - (if (not (sym? rest-pat)) 5584 5584 - (table.insert condition subcondition)) 5585 5585 - (assert (= nil (. pattern (+ k 2))) 5586 5586 - "expected & rest argument before last parameter") 5587 5587 - (table.insert bindings rest-pat) 5588 5588 - (table.insert bindings [rest-val])) 5589 5589 - (= k `&as) 5590 5590 - (do 5591 5591 - (table.insert bindings pat) 5592 5592 - (table.insert bindings val)) 5593 5593 - (and (= :number (type k)) (= `&as pat)) 5594 5594 - (do 5595 5595 - (assert (= nil (. pattern (+ k 2))) 5596 5596 - "expected &as argument before last parameter") 5597 5597 - (table.insert bindings (. pattern (+ k 1))) 5598 5598 - (table.insert bindings val)) 5599 5599 - ;; don't process the pattern right after &/&as; already got it 5600 5600 - (or (not= :number (type k)) (and (not= `&as (. pattern (- k 1))) 5601 5601 - (not= `& (. pattern (- k 1))))) 5602 5602 - (let [subval `(. ,val ,k) 5603 5603 - (subcondition subbindings) (match-pattern [subval] pat 5604 5604 - unifications)] 5605 5605 - (table.insert condition subcondition) 5606 5606 - (each [_ b (ipairs subbindings)] 5607 5607 - (table.insert bindings b))))) 5608 5608 - (values condition bindings))) 5609 5609 - 5610 5610 - (fn match-pattern [vals pattern unifications] 5611 5611 - "Take the AST of values and a single pattern and returns a condition 5612 5612 - to determine if it matches as well as a list of bindings to 5613 5613 - introduce for the duration of the body if it does match." 5614 5614 - ;; we have to assume we're matching against multiple values here until we 5615 5615 - ;; know we're either in a multi-valued clause (in which case we know the # 5616 5616 - ;; of vals) or we're not, in which case we only care about the first one. 5617 5617 - (let [[val] vals] 5618 5618 - (if (or (and (sym? pattern) ; unification with outer locals (or nil) 5619 5619 - (not= "_" (tostring pattern)) ; never unify _ 5620 5620 - (or (in-scope? pattern) (= :nil (tostring pattern)))) 5621 5621 - (and (multi-sym? pattern) (in-scope? (. (multi-sym? pattern) 1)))) 5622 5622 - (values `(= ,val ,pattern) []) 5623 5623 - ;; unify a local we've seen already 5624 5624 - (and (sym? pattern) (. unifications (tostring pattern))) 5625 5625 - (values `(= ,(. unifications (tostring pattern)) ,val) []) 5626 5626 - ;; bind a fresh local 5627 5627 - (sym? pattern) 5628 5628 - (let [wildcard? (: (tostring pattern) :find "^_")] 5629 5629 - (if (not wildcard?) (tset unifications (tostring pattern) val)) 5630 5630 - (values (if (or wildcard? (string.find (tostring pattern) "^?")) true 5631 5631 - `(not= ,(sym :nil) ,val)) [pattern val])) 5632 5632 - ;; guard clause 5633 5633 - (and (list? pattern) (= (. pattern 2) `?)) 5634 5634 - (let [(pcondition bindings) (match-pattern vals (. pattern 1) 5635 5635 - unifications) 5636 5636 - condition `(and ,(unpack pattern 3))] 5637 5637 - (values `(and ,pcondition 5638 5638 - (let ,bindings 5639 5639 - ,condition)) bindings)) 5640 5640 - ;; multi-valued patterns (represented as lists) 5641 5641 - (list? pattern) 5642 5642 - (match-values vals pattern unifications match-pattern) 5643 5643 - ;; table patterns 5644 5644 - (= (type pattern) :table) 5645 5645 - (match-table val pattern unifications match-pattern) 5646 5646 - ;; literal value 5647 5647 - (values `(= ,val ,pattern) [])))) 5648 5648 - 5649 5649 - (fn match-condition [vals clauses] 5650 5650 - "Construct the actual `if` AST for the given match values and clauses." 5651 5651 - (if (not= 0 (% (length clauses) 2)) ; treat odd final clause as default 5652 5652 - (table.insert clauses (length clauses) (sym "_"))) 5653 5653 - (let [out `(if)] 5654 5654 - (for [i 1 (length clauses) 2] 5655 5655 - (let [pattern (. clauses i) 5656 5656 - body (. clauses (+ i 1)) 5657 5657 - (condition bindings) (match-pattern vals pattern {})] 5658 5658 - (table.insert out condition) 5659 5659 - (table.insert out `(let ,bindings 5660 5660 - ,body)))) 5661 5661 - out)) 5662 5662 - 5663 5663 - (fn match-val-syms [clauses] 5664 5664 - "How many multi-valued clauses are there? return a list of that many gensyms." 5665 5665 - (let [syms (list (gensym))] 5666 5666 - (for [i 1 (length clauses) 2] 5667 5667 - (let [clause (if (and (list? (. clauses i)) (= `? (. clauses i 2))) 5668 5668 - (. clauses i 1) 5669 5669 - (. clauses i))] 5670 5670 - (if (list? clause) 5671 5671 - (each [valnum (ipairs clause)] 5672 5672 - (if (not (. syms valnum)) 5673 5673 - (tset syms valnum (gensym))))))) 5674 5674 - syms)) 5675 5675 - 5676 5676 - (fn match* [val ...] 5677 5677 - ;; Old implementation of match macro, which doesn't directly support 5678 5678 - ;; `where' and `or'. New syntax is implemented in `match-where', 5679 5679 - ;; which simply generates old syntax and feeds it to `match*'. 5680 5680 - (let [clauses [...] 5681 5681 - vals (match-val-syms clauses)] 5682 5682 - ;; protect against multiple evaluation of the value, bind against as 5683 5683 - ;; many values as we ever match against in the clauses. 5684 5684 - (list `let [vals val] (match-condition vals clauses)))) 5685 5685 - 5686 5686 - ;; Construction of old match syntax from new syntax 5687 5687 - 5688 5688 - (fn partition-2 [seq] 5689 5689 - ;; Partition `seq` by 2. 5690 5690 - ;; If `seq` has odd amount of elements, the last one is dropped. 5691 5691 - ;; 5692 5692 - ;; Input: [1 2 3 4 5] 5693 5693 - ;; Output: [[1 2] [3 4]] 5694 5694 - (let [firsts [] 5695 5695 - seconds [] 5696 5696 - res []] 5697 5697 - (for [i 1 (length seq) 2] 5698 5698 - (let [first (. seq i) 5699 5699 - second (. seq (+ i 1))] 5700 5700 - (table.insert firsts (if (not= nil first) first `nil)) 5701 5701 - (table.insert seconds (if (not= nil second) second `nil)))) 5702 5702 - (each [i v1 (ipairs firsts)] 5703 5703 - (let [v2 (. seconds i)] 5704 5704 - (if (not= nil v2) 5705 5705 - (table.insert res [v1 v2])))) 5706 5706 - res)) 5707 5707 - 5708 5708 - (fn transform-or [[_ & pats] guards] 5709 5709 - ;; Transforms `(or pat pats*)` lists into match `guard` patterns. 5710 5710 - ;; 5711 5711 - ;; (or pat1 pat2), guard => [(pat1 ? guard) (pat2 ? guard)] 5712 5712 - (let [res []] 5713 5713 - (each [_ pat (ipairs pats)] 5714 5714 - (table.insert res (list pat `? (unpack guards)))) 5715 5715 - res)) 5716 5716 - 5717 5717 - (fn transform-cond [cond] 5718 5718 - ;; Transforms `where` cond into sequence of `match` guards. 5719 5719 - ;; 5720 5720 - ;; pat => [pat] 5721 5721 - ;; (where pat guard) => [(pat ? guard)] 5722 5722 - ;; (where (or pat1 pat2) guard) => [(pat1 ? guard) (pat2 ? guard)] 5723 5723 - (if (and (list? cond) (= (. cond 1) `where)) 5724 5724 - (let [second (. cond 2)] 5725 5725 - (if (and (list? second) (= (. second 1) `or)) 5726 5726 - (transform-or second [(unpack cond 3)]) 5727 5727 - :else 5728 5728 - [(list second `? (unpack cond 3))])) 5729 5729 - :else 5730 5730 - [cond])) 5731 5731 - 5732 5732 - (fn match-where [val ...] 5733 5733 - "Perform pattern matching on val. See reference for details. 5734 5734 - 5735 5735 - Syntax: 5736 5736 - 5737 5737 - (match data-expression 5738 5738 - pattern body 5739 5739 - (where pattern guard guards*) body 5740 5740 - (where (or pattern patterns*) guard guards*) body)" 5741 5741 - (assert (not= val nil) "missing subject") 5742 5742 - (assert (= 0 (math.fmod (select :# ...) 2)) 5743 5743 - "expected even number of pattern/body pairs") 5744 5744 - (assert (not= 0 (select :# ...)) 5745 5745 - "expected at least one pattern/body pair") 5746 5746 - (let [conds-bodies (partition-2 [...]) 5747 5747 - match-body []] 5748 5748 - (each [_ [cond body] (ipairs conds-bodies)] 5749 5749 - (each [_ cond (ipairs (transform-cond cond))] 5750 5750 - (table.insert match-body cond) 5751 5751 - (table.insert match-body body))) 5752 5752 - (match* val (unpack match-body)))) 5753 5753 - 5754 5754 - (fn match-try-step [expr else pattern body ...] 5755 5755 - (if (= nil pattern body) 5756 5756 - expr 5757 5757 - ;; unlike regular match, we can't know how many values the value 5758 5758 - ;; might evaluate to, so we have to capture them all in ... via IIFE 5759 5759 - ;; to avoid double-evaluation. 5760 5760 - `((fn [...] 5761 5761 - (match ... 5762 5762 - ,pattern ,(match-try-step body else ...) 5763 5763 - ,(unpack else))) 5764 5764 - ,expr))) 5765 5765 - 5766 5766 - (fn match-try* [expr pattern body ...] 5767 5767 - "Perform chained pattern matching for a sequence of steps which might fail. 5768 5768 - 5769 5769 - The values from the initial expression are matched against the first pattern. 5770 5770 - If they match, the first body is evaluated and its values are matched against 5771 5771 - the second pattern, etc. 5772 5772 - 5773 5773 - If there is a (catch pat1 body1 pat2 body2 ...) form at the end, any mismatch 5774 5774 - from the steps will be tried against these patterns in sequence as a fallback 5775 5775 - just like a normal match. If there is no catch, the mismatched values will be 5776 5776 - returned as the value of the entire expression." 5777 5777 - (let [clauses [pattern body ...] 5778 5778 - last (. clauses (length clauses)) 5779 5779 - catch (if (= `catch (and (= :table (type last)) (. last 1))) 5780 5780 - (let [[_ & e] (table.remove clauses)] e) ; remove `catch sym 5781 5781 - [`_# `...])] 5782 5782 - (assert (= 0 (math.fmod (length clauses) 2)) 5783 5783 - "expected every pattern to have a body") 5784 5784 - (assert (= 0 (math.fmod (length catch) 2)) 5785 5785 - "expected every catch pattern to have a body") 5786 5786 - (match-try-step expr catch (unpack clauses)))) 5787 5787 - 5788 5788 - {:-> ->* 5789 5789 - :->> ->>* 5790 5790 - :-?> -?>* 5791 5791 - :-?>> -?>>* 5792 5792 - :?. ?dot 5793 5793 - :doto doto* 5794 5794 - :when when* 5795 5795 - :with-open with-open* 5796 5796 - :collect collect* 5797 5797 - :icollect icollect* 5798 5798 - :fcollect fcollect* 5799 5799 - :accumulate accumulate* 5800 5800 - :partial partial* 5801 5801 - :lambda lambda* 5802 5802 - :pick-args pick-args* 5803 5803 - :pick-values pick-values* 5804 5804 - :macro macro* 5805 5805 - :macrodebug macrodebug* 5806 5806 - :import-macros import-macros* 5807 5807 - :match match-where 5808 5808 - :match-try match-try*} 5809 5809 - ]===] 5810 5810 - local module_name = "fennel.macros" 5811 5811 - local _ 5812 5812 - local function _739_() 5813 5813 - return mod 5814 5814 - end 5815 5815 - package.preload[module_name] = _739_ 5816 5816 - _ = nil 5817 5817 - local env 5818 5818 - do 5819 5819 - local _740_ = specials["make-compiler-env"](nil, compiler.scopes.compiler, {}) 5820 5820 - do end (_740_)["utils"] = utils 5821 5821 - _740_["fennel"] = mod 5822 5822 - env = _740_ 5823 5823 - end 5824 5824 - local built_ins = eval(builtin_macros, {env = env, scope = compiler.scopes.compiler, allowedGlobals = false, useMetadata = true, filename = "src/fennel/macros.fnl", moduleName = module_name}) 5825 5825 - for k, v in pairs(built_ins) do 5826 5826 - compiler.scopes.global.macros[k] = v 5827 5827 - end 5828 5828 - compiler.scopes.global.macros["\206\187"] = compiler.scopes.global.macros.lambda 5829 5829 - package.preload[module_name] = nil 5830 5830 - end 5831 5831 - return mod