From 5bf35209be9125007d40672e5eec3ee721ece3f5 Mon Sep 17 00:00:00 2001 From: Jeremy Penner Date: Mon, 2 Aug 2021 14:48:01 -0400 Subject: [PATCH] Upgrade to Fennel 0.9.2 --- lib/fennel.lua | 165 +++++++++++++++++++++++++++---------------------- 1 file changed, 91 insertions(+), 74 deletions(-) diff --git a/lib/fennel.lua b/lib/fennel.lua index 1185044..3c6bfd0 100644 --- a/lib/fennel.lua +++ b/lib/fennel.lua @@ -266,7 +266,7 @@ package.preload["fennel.repl"] = package.preload["fennel.repl"] or function(...) else if parse_ok_3f then do - local _4_0, _5_0 = pcall(compiler.compile, x, {["assert-compile"] = opts["assert-compile"], ["parse-error"] = opts["parse-error"], correlate = opts.correlate, moduleName = opts.moduleName, scope = scope, source = src_string, useMetadata = opts.useMetadata}) + local _4_0, _5_0 = pcall(compiler.compile, x, {["assert-compile"] = opts["assert-compile"], ["parse-error"] = opts["parse-error"], correlate = opts.correlate, moduleName = opts.moduleName, scope = scope, source = src_string, useBitLib = opts.useBitLib, useMetadata = opts.useMetadata}) if ((_4_0 == false) and (nil ~= _5_0)) then local msg = _5_0 clear_stream() @@ -1202,6 +1202,7 @@ package.preload["fennel.specials"] = package.preload["fennel.specials"] or funct SPECIALS.each = function(ast, scope, parent) compiler.assert((#ast >= 3), "expected body expression", ast[1]) local binding = compiler.assert(utils["table?"](ast[2]), "expected binding table", ast) + local _ = compiler.assert((2 <= #binding), "expected binding and iterator", binding) local until_condition = remove_until_condition(binding) local iter = table.remove(binding, #binding) local destructures = {} @@ -1876,7 +1877,7 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct else _0_ = 0 end - return {autogensyms = {}, depth = _0_, hashfn = (parent0 and parent0.hashfn), includes = setmetatable({}, {__index = (parent0 and parent0.includes)}), macros = setmetatable({}, {__index = (parent0 and parent0.macros)}), manglings = setmetatable({}, {__index = (parent0 and parent0.manglings)}), parent = parent0, refedglobals = setmetatable({}, {__index = (parent0 and parent0.refedglobals)}), specials = setmetatable({}, {__index = (parent0 and parent0.specials)}), symmeta = setmetatable({}, {__index = (parent0 and parent0.symmeta)}), unmanglings = setmetatable({}, {__index = (parent0 and parent0.unmanglings)}), vararg = (parent0 and parent0.vararg)} + return {autogensyms = setmetatable({}, {__index = (parent0 and parent0.autogensyms)}), depth = _0_, gensyms = setmetatable({}, {__index = (parent0 and parent0.gensyms)}), hashfn = (parent0 and parent0.hashfn), includes = setmetatable({}, {__index = (parent0 and parent0.includes)}), macros = setmetatable({}, {__index = (parent0 and parent0.macros)}), manglings = setmetatable({}, {__index = (parent0 and parent0.manglings)}), parent = parent0, refedglobals = setmetatable({}, {__index = (parent0 and parent0.refedglobals)}), specials = setmetatable({}, {__index = (parent0 and parent0.specials)}), symmeta = setmetatable({}, {__index = (parent0 and parent0.symmeta)}), unmanglings = setmetatable({}, {__index = (parent0 and parent0.unmanglings)}), vararg = (parent0 and parent0.vararg)} end local function assert_msg(ast, msg) local ast_tbl = nil @@ -1950,11 +1951,11 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct end end local allowed_globals = nil - local function global_allowed(name) + local function global_allowed_3f(name) return (not allowed_globals or utils["member?"](name, allowed_globals)) end local function unique_mangling(original, mangling, scope, append) - if scope.unmanglings[mangling] then + if (scope.unmanglings[mangling] and not scope.gensyms[mangling]) then return unique_mangling(original, (original .. append), scope, (append + 1)) else return mangling @@ -2010,6 +2011,7 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct append = (append + 1) end scope.unmanglings[mangling] = (base or true) + scope.gensyms[mangling] = true return mangling end local function autogensym(base, scope) @@ -2068,7 +2070,7 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct if (local_3f and scope.symmeta[parts[1]]) then scope.symmeta[parts[1]]["used"] = true end - assert_compile((not reference_3f or local_3f or global_allowed(parts[1])), ("unknown global in strict mode: " .. tostring(parts[1])), symbol) + assert_compile((not reference_3f or local_3f or ("_ENV" == parts[1]) or global_allowed_3f(parts[1])), ("unknown global in strict mode: " .. tostring(parts[1])), symbol) if (allowed_globals and not local_3f) then utils.root.scope.refedglobals[parts[1]] = true end @@ -2102,7 +2104,7 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct local m = getmetatable(ast) return ((m and m.line and m) or (("table" == type(ast)) and ast) or {}) end - local function flatten_chunk_correlated(main_chunk) + local function flatten_chunk_correlated(main_chunk, options) local function flatten(chunk, out, last_line, file) local last_line0 = last_line if chunk.leaf then @@ -2111,7 +2113,7 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct for _, subchunk in ipairs(chunk) do if (subchunk.leaf or (#subchunk > 0)) then local source = ast_source(subchunk.ast) - if (file == source.file) then + if (file == source.filename) then last_line0 = math.max(last_line0, (source.line or 0)) end last_line0 = flatten(subchunk, out, last_line0, file) @@ -2121,7 +2123,7 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct return last_line0 end local out = {} - local last = flatten(main_chunk, out, 1, main_chunk.file) + local last = flatten(main_chunk, out, 1, options.filename) for i = 1, last do if (out[i] == nil) then out[i] = "" @@ -2178,7 +2180,7 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct local function flatten(chunk, options) local chunk0 = peephole(chunk) if options.correlate then - return flatten_chunk_correlated(chunk0), {} + return flatten_chunk_correlated(chunk0, options), {} else local sm = {} local ret = flatten_chunk(sm, chunk0, options.indent, 0) @@ -2222,20 +2224,21 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct local function exprs1(exprs) return table.concat(utils.map(exprs, 1), ", ") end - local function disambiguate_parens(code, chunk) - if (code:byte() == 40) then - return ("do end " .. code) - else - return code - end - end local function keep_side_effects(exprs, chunk, start, ast) - for j = (start or 1), #exprs do + local start0 = (start or 1) + for j = start0, #exprs do local se = exprs[j] if ((se.type == "expression") and (se[1] ~= "nil")) then emit(chunk, string.format("do local _ = %s end", tostring(se)), ast) elseif (se.type == "statement") then - emit(chunk, disambiguate_parens(tostring(se), chunk), ast) + local code = tostring(se) + local disambiguated = nil + if (code:byte() == 40) then + disambiguated = ("do end " .. code) + else + disambiguated = code + end + emit(chunk, disambiguated, ast) end end return nil @@ -2353,7 +2356,7 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct local function compile_function_call(ast, scope, parent, opts, compile1, len) local fargs = {} local fcallee = compile1(ast[1], scope, parent, {nval = 1})[1] - assert_compile((fcallee.type ~= "literal"), ("cannot call literal value " .. tostring(ast[1])), ast) + assert_compile((("string" == type(ast[1])) or (fcallee.type ~= "literal")), ("cannot call literal value " .. tostring(ast[1])), ast) for i = 2, len do local subexprs = nil local _0_ @@ -2372,7 +2375,13 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct keep_side_effects(subexprs, parent, 2, ast[i]) end end - local call = string.format("%s(%s)", tostring(fcallee), exprs1(fargs)) + local pat = nil + if ("string" == type(ast[1])) then + pat = "(%s)(%s)" + else + pat = "%s(%s)" + end + local call = string.format(pat, tostring(fcallee), exprs1(fargs)) return handle_compile_opts({utils.expr(call, "statement")}, parent, opts, ast) end local function compile_call(ast, scope, parent, opts, compile1) @@ -2749,7 +2758,7 @@ package.preload["fennel.compiler"] = package.preload["fennel.compiler"] or funct end end local function traceback(msg, start) - local msg0 = (msg or "") + local msg0 = tostring((msg or "")) if ((msg0:find("^Compile error") or msg0:find("^Parse error")) and not utils["debug-on?"]("trace")) then return msg0 else @@ -2888,7 +2897,7 @@ package.preload["fennel.friend"] = package.preload["fennel.friend"] or function( local m = getmetatable(ast) return ((m and m.line and m) or (("table" == type(ast)) and ast) or {}) end - local suggestions = {["$ and $... in hashfn are mutually exclusive"] = {"modifying the hashfn so it only contains $... or $, $1, $2, $3, etc"}, ["can't start multisym segment with a digit"] = {"removing the digit", "adding a non-digit before the digit"}, ["cannot call literal value"] = {"checking for typos", "checking for a missing function name"}, ["could not compile value of type "] = {"debugging the macro you're calling to return a list or table"}, ["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"}, ["expected a function.* to call"] = {"removing the empty parentheses", "using square brackets if you want an empty table"}, ["expected binding table"] = {"placing a table here in square brackets containing identifiers to bind"}, ["expected body expression"] = {"putting some code in the body of this form after the bindings"}, ["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"}, ["expected even number of name/value bindings"] = {"finding where the identifier or value is missing"}, ["expected even number of values in table literal"] = {"removing a key", "adding a value"}, ["expected local"] = {"looking for a typo", "looking for a local which is used out of its scope"}, ["expected macros to be table"] = {"ensuring your macro definitions return a table"}, ["expected parameters"] = {"adding function parameters as a list of identifiers in brackets"}, ["expected rest argument before last parameter"] = {"moving & to right before the final identifier when destructuring"}, ["expected symbol for function parameter: (.*)"] = {"changing %s to an identifier instead of a literal value"}, ["expected var (.*)"] = {"declaring %s using var instead of let/local", "introducing a new local instead of changing the value of %s"}, ["expected vararg as last parameter"] = {"moving the \"...\" to the end of the parameter list"}, ["expected whitespace before opening delimiter"] = {"adding whitespace"}, ["global (.*) conflicts with local"] = {"renaming local %s"}, ["illegal character: (.)"] = {"deleting or replacing %s", "avoiding reserved characters like \", \\, ', ~, ;, @, `, and comma"}, ["local (.*) was overshadowed by a special form or macro"] = {"renaming local %s"}, ["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"}, ["malformed multisym"] = {"ensuring each period or colon is not followed by another period or colon"}, ["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"}, ["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"}, ["mismatched closing delimiter (.), expected (.)"] = {"replacing %s with %s", "deleting %s", "adding matching opening delimiter earlier"}, ["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"}, ["unable to bind (.*)"] = {"replacing the %s with an identifier"}, ["unexpected closing delimiter (.)"] = {"deleting %s", "adding matching opening delimiter earlier"}, ["unexpected multi symbol (.*)"] = {"removing periods or colons from %s"}, ["unexpected vararg"] = {"putting \"...\" at the end of the fn parameters if the vararg was intended"}, ["unknown global 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"}, ["unused local (.*)"] = {"fixing a typo so %s is used", "renaming the local to _%s"}, ["use of global (.*) is aliased by a local"] = {"renaming local %s", "refer to the global using _G.%s instead of directly"}} + local suggestions = {["$ and $... in hashfn are mutually exclusive"] = {"modifying the hashfn so it only contains $... or $, $1, $2, $3, etc"}, ["can't start multisym segment with a digit"] = {"removing the digit", "adding a non-digit before the digit"}, ["cannot call literal value"] = {"checking for typos", "checking for a missing function name"}, ["could not compile value of type "] = {"debugging the macro you're calling to return a list or table"}, ["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"}, ["expected a function.* to call"] = {"removing the empty parentheses", "using square brackets if you want an empty table"}, ["expected binding and iterator"] = {"making sure you haven't omitted a local name or iterator"}, ["expected binding table"] = {"placing a table here in square brackets containing identifiers to bind"}, ["expected body expression"] = {"putting some code in the body of this form after the bindings"}, ["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"}, ["expected even number of name/value bindings"] = {"finding where the identifier or value is missing"}, ["expected even number of values in table literal"] = {"removing a key", "adding a value"}, ["expected local"] = {"looking for a typo", "looking for a local which is used out of its scope"}, ["expected macros to be table"] = {"ensuring your macro definitions return a table"}, ["expected parameters"] = {"adding function parameters as a list of identifiers in brackets"}, ["expected rest argument before last parameter"] = {"moving & to right before the final identifier when destructuring"}, ["expected symbol for function parameter: (.*)"] = {"changing %s to an identifier instead of a literal value"}, ["expected var (.*)"] = {"declaring %s using var instead of let/local", "introducing a new local instead of changing the value of %s"}, ["expected vararg as last parameter"] = {"moving the \"...\" to the end of the parameter list"}, ["expected whitespace before opening delimiter"] = {"adding whitespace"}, ["global (.*) conflicts with local"] = {"renaming local %s"}, ["illegal character: (.)"] = {"deleting or replacing %s", "avoiding reserved characters like \", \\, ', ~, ;, @, `, and comma"}, ["local (.*) was overshadowed by a special form or macro"] = {"renaming local %s"}, ["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"}, ["malformed multisym"] = {"ensuring each period or colon is not followed by another period or colon"}, ["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"}, ["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"}, ["mismatched closing delimiter (.), expected (.)"] = {"replacing %s with %s", "deleting %s", "adding matching opening delimiter earlier"}, ["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"}, ["unable to bind (.*)"] = {"replacing the %s with an identifier"}, ["unexpected closing delimiter (.)"] = {"deleting %s", "adding matching opening delimiter earlier"}, ["unexpected multi symbol (.*)"] = {"removing periods or colons from %s"}, ["unexpected vararg"] = {"putting \"...\" at the end of the fn parameters if the vararg was intended"}, ["unknown global 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"}, ["unused local (.*)"] = {"fixing a typo so %s is used", "renaming the local to _%s"}, ["use of global (.*) is aliased by a local"] = {"renaming local %s", "refer to the global using _G.%s instead of directly"}} local unpack = (table.unpack or _G.unpack) local function suggest(msg) local suggestion = nil @@ -3706,19 +3715,19 @@ local function dofile_2a(filename, options, ...) opts.filename = filename return eval(source, opts, ...) end -local mod = {["comment?"] = utils["comment?"], ["compile-stream"] = compiler["compile-stream"], ["compile-string"] = compiler["compile-string"], ["list?"] = utils["list?"], ["load-code"] = specials["load-code"], ["macro-loaded"] = specials["macro-loaded"], ["macro-searchers"] = specials["macro-searchers"], ["make-searcher"] = specials["make-searcher"], ["search-module"] = specials["search-module"], ["sequence?"] = utils["sequence?"], ["string-stream"] = parser["string-stream"], ["sym-char?"] = parser["sym-char?"], ["sym?"] = utils["sym?"], comment = utils.comment, compile = compiler.compile, compile1 = compiler.compile1, compileStream = compiler["compile-stream"], compileString = compiler["compile-string"], doc = specials.doc, dofile = dofile_2a, eval = eval, gensym = compiler.gensym, granulate = parser.granulate, list = utils.list, loadCode = specials["load-code"], macroLoaded = specials["macro-loaded"], makeSearcher = specials["make-searcher"], make_searcher = specials["make-searcher"], mangle = compiler["global-mangling"], metadata = compiler.metadata, parser = parser.parser, path = utils.path, repl = repl, scope = compiler["make-scope"], searchModule = specials["search-module"], searcher = specials["make-searcher"](), sequence = utils.sequence, stringStream = parser["string-stream"], sym = utils.sym, traceback = compiler.traceback, unmangle = compiler["global-unmangling"], varg = utils.varg, version = "0.9.1-dev", view = view} +local mod = {["comment?"] = utils["comment?"], ["compile-stream"] = compiler["compile-stream"], ["compile-string"] = compiler["compile-string"], ["list?"] = utils["list?"], ["load-code"] = specials["load-code"], ["macro-loaded"] = specials["macro-loaded"], ["macro-searchers"] = specials["macro-searchers"], ["make-searcher"] = specials["make-searcher"], ["search-module"] = specials["search-module"], ["sequence?"] = utils["sequence?"], ["string-stream"] = parser["string-stream"], ["sym-char?"] = parser["sym-char?"], ["sym?"] = utils["sym?"], comment = utils.comment, compile = compiler.compile, compile1 = compiler.compile1, compileStream = compiler["compile-stream"], compileString = compiler["compile-string"], doc = specials.doc, dofile = dofile_2a, eval = eval, gensym = compiler.gensym, granulate = parser.granulate, list = utils.list, loadCode = specials["load-code"], macroLoaded = specials["macro-loaded"], makeSearcher = specials["make-searcher"], make_searcher = specials["make-searcher"], mangle = compiler["global-mangling"], metadata = compiler.metadata, parser = parser.parser, path = utils.path, repl = repl, scope = compiler["make-scope"], searchModule = specials["search-module"], searcher = specials["make-searcher"](), sequence = utils.sequence, stringStream = parser["string-stream"], sym = utils.sym, traceback = compiler.traceback, unmangle = compiler["global-unmangling"], varg = utils.varg, version = "0.9.2", view = view} utils["fennel-module"] = mod do local builtin_macros = [===[;; This module contains all the built-in Fennel macros. Unlike all the other ;; modules that are loaded by the old bootstrap compiler, this runs in the ;; compiler scope of the version of the compiler being defined. - + ;; The code for these macros is somewhat idiosyncratic because it cannot use any ;; macros which have not yet been defined. - + ;; TODO: some of these macros modify their arguments; we should stop doing that, ;; but in a way that preserves file/line metadata. - + (fn ->* [val ...] "Thread-first macro. Take the first value and splice it into the second form as its first argument. @@ -3729,7 +3738,7 @@ do (table.insert elt 2 x) (set x elt))) x) - + (fn ->>* [val ...] "Thread-last macro. Same as ->, except splices the value into the last position of each form @@ -3740,7 +3749,7 @@ do (table.insert elt x) (set x elt))) x) - + (fn -?>* [val ...] "Nil-safe thread-first macro. Same as -> except will short-circuit with nil when it encounters a nil value." @@ -3755,7 +3764,7 @@ do (if ,tmp (-?> ,el ,(unpack els)) ,tmp))))) - + (fn -?>>* [val ...] "Nil-safe thread-last macro. Same as ->> except will short-circuit with nil when it encounters a nil value." @@ -3770,14 +3779,20 @@ do (if ,tmp (-?>> ,el ,(unpack els)) ,tmp))))) - - (fn ?dot [tbl k ...] + + (fn ?dot [tbl ...] "Nil-safe table look up. Same as . (dot), except will short-circuit with nil when it encounters a nil value in any of subsequent keys." - (if (= nil k) tbl `(let [res# (. ,tbl ,k)] - (and res# (?. res# ,...))))) - + (let [head (gensym :t) + lookups `(do (var ,head ,tbl) ,head)] + (each [_ k (ipairs [...])] + ;; Kinda gnarly to reassign in place like this, but it emits the best lua. + ;; With this impl, it emits a flat, concise, and readable set of if blocks. + (table.insert lookups (# lookups) `(if (not= nil ,head) + (set ,head (. ,head ,k))))) + lookups)) + (fn doto* [val ...] "Evaluates val and splices it into the first argument of subsequent forms." (let [name (gensym) @@ -3787,7 +3802,7 @@ do (table.insert form elt)) (table.insert form name) form)) - + (fn when* [condition body1 ...] "Evaluate body for side-effects only when condition is truthy." (assert body1 "expected body") @@ -3795,7 +3810,7 @@ do (do ,body1 ,...))) - + (fn with-open* [closable-bindings ...] "Like `let`, but invokes (v:close) on each binding after evaluating the body. The body is evaluated inside `xpcall` so that bound values will be closed upon @@ -3812,13 +3827,13 @@ do `(let ,closable-bindings ,closer (close-handlers# (xpcall ,bodyfn ,traceback))))) - + (fn collect* [iter-tbl key-value-expr ...] "Returns a table made by running an iterator and evaluating an expression that returns key-value pairs to be inserted sequentially into the table. This can be thought of as a \"table comprehension\". The provided key-value expression must return either 2 values, or nil. - + For example, (collect [k v (pairs {:apple \"red\" :orange \"orange\"})] (values v k)) @@ -3834,12 +3849,12 @@ do (match ,key-value-expr (k# v#) (tset tbl# k# v#))) tbl#)) - + (fn icollect* [iter-tbl value-expr ...] "Returns a sequential table made by running an iterator and evaluating an expression that returns values to be inserted sequentially into the table. This can be thought of as a \"list comprehension\". - + For example, (icollect [_ v (ipairs [1 2 3 4 5])] (when (> v 2) (* v v))) returns @@ -3853,7 +3868,7 @@ do (each ,iter-tbl (tset tbl# (+ (length tbl#) 1) ,value-expr)) tbl#)) - + (fn partial* [f ...] "Returns a function with all arguments partially applied to f." (assert f "expected a function to partially apply") @@ -3861,10 +3876,10 @@ do (table.insert body _VARARG) `(fn [,_VARARG] ,body))) - + (fn pick-args* [n f] "Creates a function of arity n that applies its arguments to f. - + For example, (pick-args 2 func) expands to @@ -3876,10 +3891,10 @@ do (tset bindings i (gensym))) `(fn ,bindings (,f ,(unpack bindings))))) - + (fn pick-values* [n ...] "Like the `values` special, but emits exactly n values. - + For example, (pick-values 2 ...) expands to @@ -3894,7 +3909,7 @@ do (if (= n 0) `(values) `(let [,let-syms ,let-values] (values ,(unpack let-syms)))))) - + (fn lambda* [...] "Function literal with arity checking. Will throw an exception if a declared argument is passed in as nil, unless @@ -3921,26 +3936,26 @@ do ,(tostring a) ,(or a.filename :unknown) ,(or a.line "?")))))) - + (assert (= :table (type arglist)) "expected arg list") (each [_ a (ipairs arglist)] (check! a)) (if empty-body? (table.insert args (sym :nil))) `(fn ,(unpack args)))) - + (fn macro* [name ...] "Define a single macro." (assert (sym? name) "expected symbol for macro name") (local args [...]) `(macros {,(tostring name) (fn ,(unpack args))})) - + (fn macrodebug* [form return?] "Print the resulting form after performing macroexpansion. With a second argument, returns expanded form as a string instead of printing." (let [handle (if return? `do `print)] `(,handle ,(view (macroexpand form _SCOPE))))) - + (fn import-macros* [binding1 module-name1 ...] "Binds a table of macros from each macro module according to a binding form. Each binding form can be either a symbol or a k/v destructuring table. @@ -3971,9 +3986,9 @@ do (tostring modname))) (tset scope.macros import-key (. subscope.macros macro-name)))))) nil) - + ;;; Pattern matching - + (fn match-values [vals pattern unifications match-pattern] (let [condition `(and) bindings []] @@ -3984,7 +3999,7 @@ do (each [_ b (ipairs subbindings)] (table.insert bindings b)))) (values condition bindings))) - + (fn match-table [val pattern unifications match-pattern] (let [condition `(and (= (type ,val) :table)) bindings []] @@ -4016,7 +4031,7 @@ do (each [_ b (ipairs subbindings)] (table.insert bindings b))))) (values condition bindings))) - + (fn match-pattern [vals pattern unifications] "Takes the AST of values and a single pattern and returns a condition to determine if it matches as well as a list of bindings to @@ -4043,11 +4058,10 @@ do (and (list? pattern) (= (. pattern 2) `?)) (let [(pcondition bindings) (match-pattern vals (. pattern 1) unifications) - condition `(and ,pcondition)] - (for [i 3 (length pattern)] ; splice in guard clauses - (table.insert condition (. pattern i))) - (values `(let ,bindings - ,condition) bindings)) + condition `(and ,(unpack pattern 3))] + (values `(and ,pcondition + (let ,bindings + ,condition)) bindings)) ;; multi-valued patterns (represented as lists) (list? pattern) (match-values vals pattern unifications match-pattern) @@ -4056,7 +4070,7 @@ do (match-table val pattern unifications match-pattern) ;; literal value (values `(= ,val ,pattern) [])))) - + (fn match-condition [vals clauses] "Construct the actual `if` AST for the given match values and clauses." (if (not= 0 (% (length clauses) 2)) ; treat odd final clause as default @@ -4070,17 +4084,20 @@ do (table.insert out `(let ,bindings ,body)))) out)) - + (fn match-val-syms [clauses] "How many multi-valued clauses are there? return a list of that many gensyms." (let [syms (list (gensym))] (for [i 1 (length clauses) 2] - (if (list? (. clauses i)) - (each [valnum (ipairs (. clauses i))] - (if (not (. syms valnum)) - (tset syms valnum (gensym)))))) + (let [clause (if (and (list? (. clauses i)) (= `? (. clauses i 2))) + (. clauses i 1) + (. clauses i))] + (if (list? clause) + (each [valnum (ipairs clause)] + (if (not (. syms valnum)) + (tset syms valnum (gensym))))))) syms)) - + (fn match* [val ...] ;; Old implementation of match macro, which doesn't directly support ;; `where' and `or'. New syntax is implemented in `match-where', @@ -4090,9 +4107,9 @@ do ;; protect against multiple evaluation of the value, bind against as ;; many values as we ever match against in the clauses. (list `let [vals val] (match-condition vals clauses)))) - + ;; Construction of old match syntax from new syntax - + (fn partition-2 [seq] ;; Partition `seq` by 2. ;; If `seq` has odd amount of elements, the last one is dropped. @@ -4112,7 +4129,7 @@ do (if (not= nil v2) (table.insert res [v1 v2])))) res)) - + (fn transform-or [[_ & pats] guards] ;; Transforms `(or pat pats*)` lists into match `guard` patterns. ;; @@ -4121,7 +4138,7 @@ do (each [_ pat (ipairs pats)] (table.insert res (list pat `? (unpack guards)))) res)) - + (fn transform-cond [cond] ;; Transforms `where` cond into sequence of `match` guards. ;; @@ -4136,12 +4153,12 @@ do [(list second `? (unpack cond 3))])) :else [cond])) - + (fn match-where [val ...] "Perform pattern matching on val. See reference for details. - + Syntax: - + (match data-expression pattern body (where pattern guard guards*) body @@ -4157,7 +4174,7 @@ do (if else-branch (table.insert match-body else-branch)) (match* val (unpack match-body)))) - + {:-> ->* :->> ->>* :-?> -?>*