Navigation Menu

Skip to content

Instantly share code, notes, and snippets.

/lumen.lua

Created March 18, 2017 08:28
Show Gist options
  • Star 0 You must be signed in to star a gist
  • Fork 2 You must be signed in to fork a gist
  • Save anonymous/af755d7cf0f71a574f39f547d3357a39 to your computer and use it in GitHub Desktop.
Save anonymous/af755d7cf0f71a574f39f547d3357a39 to your computer and use it in GitHub Desktop.
Download ZIP
Self-hosted Lisp using vvander's Lua browser runtime: https://cdn.rawgit.com/vvanders/wasm_lua/d68f46a8/main.html
Raw
lumen.lua
environment = {{}}
target = "lua"
function nil63(x)
return(x == nil)
end
function is63(x)
return(not nil63(x))
end
function no(x)
return(nil63(x) or x == false)
end
function yes(x)
return(not no(x))
end
function _35(x)
return(#x)
end
function none63(x)
return(_35(x) == 0)
end
function some63(x)
return(_35(x) > 0)
end
function one63(x)
return(_35(x) == 1)
end
function two63(x)
return(_35(x) == 2)
end
function hd(l)
return(l[1])
end
function string63(x)
return(type(x) == "string")
end
function number63(x)
return(type(x) == "number")
end
function boolean63(x)
return(type(x) == "boolean")
end
function function63(x)
return(type(x) == "function")
end
function obj63(x)
return(is63(x) and type(x) == "table")
end
function atom63(x)
return(nil63(x) or string63(x) or number63(x) or boolean63(x))
end
nan = 0 / 0
-- inf = 1 / 0 -- There's a bug in WASM preventing this from working.
inf = 0 / 0 -- Hack around it for now.
function nan63(n)
return(not( n == n))
end
function inf63(n)
return(n == inf or n == -inf)
end
function clip(s, from, upto)
return(string.sub(s, from + 1, upto))
end
function cut(x, from, upto)
local l = {}
local j = 0
local _e
if nil63(from) or from < 0 then
_e = 0
else
_e = from
end
local i = _e
local n = _35(x)
local _e1
if nil63(upto) or upto > n then
_e1 = n
else
_e1 = upto
end
local _upto = _e1
while i < _upto do
l[j + 1] = x[i + 1]
i = i + 1
j = j + 1
end
local _o = x
local k = nil
for k in next, _o do
local v = _o[k]
if not number63(k) then
l[k] = v
end
end
return(l)
end
function keys(x)
local t = {}
local _o1 = x
local k = nil
for k in next, _o1 do
local v = _o1[k]
if not number63(k) then
t[k] = v
end
end
return(t)
end
function edge(x)
return(_35(x) - 1)
end
function inner(x)
return(clip(x, 1, edge(x)))
end
function tl(l)
return(cut(l, 1))
end
function char(s, n)
return(clip(s, n, n + 1))
end
function code(s, n)
local _e2
if n then
_e2 = n + 1
end
return(string.byte(s, _e2))
end
function string_literal63(x)
return(string63(x) and char(x, 0) == "\"")
end
function id_literal63(x)
return(string63(x) and char(x, 0) == "|")
end
function add(l, x)
return(table.insert(l, x))
end
function drop(l)
return(table.remove(l))
end
function last(l)
return(l[edge(l) + 1])
end
function almost(l)
return(cut(l, 0, edge(l)))
end
function reverse(l)
local l1 = keys(l)
local i = edge(l)
while i >= 0 do
add(l1, l[i + 1])
i = i - 1
end
return(l1)
end
function reduce(f, x)
if none63(x) then
return(nil)
else
if one63(x) then
return(hd(x))
else
return(f(hd(x), reduce(f, tl(x))))
end
end
end
function join(...)
local ls = unstash({...})
local r = {}
local _x2 = ls
local _i2 = 0
while _i2 < _35(_x2) do
local l = _x2[_i2 + 1]
if l then
local n = _35(r)
local _o2 = l
local k = nil
for k in next, _o2 do
local v = _o2[k]
if number63(k) then
k = k + n
end
r[k] = v
end
end
_i2 = _i2 + 1
end
return(r)
end
function find(f, t)
local _o3 = t
local _i4 = nil
for _i4 in next, _o3 do
local x = _o3[_i4]
local y = f(x)
if y then
return(y)
end
end
end
function first(f, l)
local _x3 = l
local _i5 = 0
while _i5 < _35(_x3) do
local x = _x3[_i5 + 1]
local y = f(x)
if y then
return(y)
end
_i5 = _i5 + 1
end
end
function in63(x, t)
return(find(function (y)
return(x == y)
end, t))
end
function pair(l)
local l1 = {}
local i = 0
while i < _35(l) do
add(l1, {l[i + 1], l[i + 1 + 1]})
i = i + 1
i = i + 1
end
return(l1)
end
function sort(l, f)
table.sort(l, f)
return(l)
end
function map(f, x)
local t = {}
local _x5 = x
local _i6 = 0
while _i6 < _35(_x5) do
local v = _x5[_i6 + 1]
local y = f(v)
if is63(y) then
add(t, y)
end
_i6 = _i6 + 1
end
local _o4 = x
local k = nil
for k in next, _o4 do
local v = _o4[k]
if not number63(k) then
local y = f(v)
if is63(y) then
t[k] = y
end
end
end
return(t)
end
function keep(f, x)
return(map(function (v)
if yes(f(v)) then
return(v)
end
end, x))
end
function keys63(t)
local _o5 = t
local k = nil
for k in next, _o5 do
local v = _o5[k]
if not number63(k) then
return(true)
end
end
return(false)
end
function empty63(t)
local _o6 = t
local _i9 = nil
for _i9 in next, _o6 do
local x = _o6[_i9]
return(false)
end
return(true)
end
function stash(args)
if keys63(args) then
local p = {}
local _o7 = args
local k = nil
for k in next, _o7 do
local v = _o7[k]
if not number63(k) then
p[k] = v
end
end
p._stash = true
add(args, p)
end
return(args)
end
function unstash(args)
if none63(args) then
return({})
else
local l = last(args)
if obj63(l) and l._stash then
local args1 = almost(args)
local _o8 = l
local k = nil
for k in next, _o8 do
local v = _o8[k]
if not( k == "_stash") then
args1[k] = v
end
end
return(args1)
else
return(args)
end
end
end
function destash33(l, args1)
if obj63(l) and l._stash then
local _o9 = l
local k = nil
for k in next, _o9 do
local v = _o9[k]
if not( k == "_stash") then
args1[k] = v
end
end
else
return(l)
end
end
function search(s, pattern, start)
local _e3
if start then
_e3 = start + 1
end
local _start = _e3
local i = string.find(s, pattern, _start, true)
return(i and i - 1)
end
function split(s, sep)
if s == "" or sep == "" then
return({})
else
local l = {}
local n = _35(sep)
while true do
local i = search(s, sep)
if nil63(i) then
break
else
add(l, clip(s, 0, i))
s = clip(s, i + n)
end
end
add(l, s)
return(l)
end
end
function cat(...)
local xs = unstash({...})
return(reduce(function (a, b)
return(a .. b)
end, xs) or "")
end
function _43(...)
local xs = unstash({...})
return(reduce(function (a, b)
return(a + b)
end, xs) or 0)
end
function _(...)
local xs = unstash({...})
return(reduce(function (b, a)
return(a - b)
end, reverse(xs)) or 0)
end
function _42(...)
local xs = unstash({...})
return(reduce(function (a, b)
return(a * b)
end, xs) or 1)
end
function _47(...)
local xs = unstash({...})
return(reduce(function (b, a)
return(a / b)
end, reverse(xs)) or 1)
end
function _37(...)
local xs = unstash({...})
return(reduce(function (b, a)
return(a % b)
end, reverse(xs)) or 0)
end
function _62(a, b)
return(a > b)
end
function _60(a, b)
return(a < b)
end
function _61(a, b)
return(a == b)
end
function _6261(a, b)
return(a >= b)
end
function _6061(a, b)
return(a <= b)
end
function number(s)
return(tonumber(s))
end
function number_code63(n)
return(n > 47 and n < 58)
end
function numeric63(s)
local n = _35(s)
local i = 0
while i < n do
if not number_code63(code(s, i)) then
return(false)
end
i = i + 1
end
return(true)
end
function escape(s)
local s1 = "\""
local i = 0
while i < _35(s) do
local c = char(s, i)
local _e4
if c == "\n" then
_e4 = "\\n"
else
local _e5
if c == "\"" then
_e5 = "\\\""
else
local _e6
if c == "\\" then
_e6 = "\\\\"
else
_e6 = c
end
_e5 = _e6
end
_e4 = _e5
end
local c1 = _e4
s1 = s1 .. c1
i = i + 1
end
return(s1 .. "\"")
end
function str(x, stack)
if nil63(x) then
return("nil")
else
if nan63(x) then
return("nan")
else
if x == inf then
return("inf")
else
if x == -inf then
return("-inf")
else
if boolean63(x) then
if x then
return("true")
else
return("false")
end
else
if string63(x) then
return(escape(x))
else
if atom63(x) then
return(tostring(x))
else
if function63(x) then
return("function")
else
if stack and in63(x, stack) then
return("circular")
else
if not( type(x) == "table") then
return(escape(tostring(x)))
else
local s = "("
local sp = ""
local xs = {}
local ks = {}
local l = stack or {}
add(l, x)
local _o10 = x
local k = nil
for k in next, _o10 do
local v = _o10[k]
if number63(k) then
xs[k] = str(v, l)
else
add(ks, k .. ":")
add(ks, str(v, l))
end
end
drop(l)
local _o11 = join(xs, ks)
local _i14 = nil
for _i14 in next, _o11 do
local v = _o11[_i14]
s = s .. sp .. v
sp = " "
end
return(s .. ")")
end
end
end
end
end
end
end
end
end
end
end
local values = unpack or table.unpack
function apply(f, args)
local _args = stash(args)
return(f(values(_args)))
end
function call(f)
return(f())
end
function toplevel63()
return(one63(environment))
end
function setenv(k, ...)
local _r69 = unstash({...})
local _k = destash33(k, _r69)
local _id = _r69
local _keys = cut(_id, 0)
if string63(_k) then
local _e7
if _keys.toplevel then
_e7 = hd(environment)
else
_e7 = last(environment)
end
local frame = _e7
local entry = frame[_k] or {}
local _o12 = _keys
local _k1 = nil
for _k1 in next, _o12 do
local v = _o12[_k1]
entry[_k1] = v
end
frame[_k] = entry
return(frame[_k])
end
end
local math = math
abs = math.abs
acos = math.acos
asin = math.asin
atan = math.atan
atan2 = math.atan2
ceil = math.ceil
cos = math.cos
floor = math.floor
log = math.log
log10 = math.log10
max = math.max
min = math.min
pow = math.pow
random = math.random
sin = math.sin
sinh = math.sinh
sqrt = math.sqrt
tan = math.tan
tanh = math.tanh
trunc = math.floor
setenv("quote", {_stash = true, macro = function (form)
return(quoted(form))
end})
setenv("quasiquote", {_stash = true, macro = function (form)
return(quasiexpand(form, 1))
end})
setenv("set", {_stash = true, macro = function (...)
local args = unstash({...})
return(join({"do"}, map(function (_x6)
local _id1 = _x6
local lh = _id1[1]
local rh = _id1[2]
return({"%set", lh, rh})
end, pair(args))))
end})
setenv("at", {_stash = true, macro = function (l, i)
if target == "lua" and number63(i) then
i = i + 1
else
if target == "lua" then
i = {"+", i, 1}
end
end
return({"get", l, i})
end})
setenv("wipe", {_stash = true, macro = function (place)
if target == "lua" then
return({"set", place, "nil"})
else
return({"%delete", place})
end
end})
setenv("list", {_stash = true, macro = function (...)
local body = unstash({...})
local x = unique("x")
local l = {}
local forms = {}
local _o1 = body
local k = nil
for k in next, _o1 do
local v = _o1[k]
if number63(k) then
l[k] = v
else
add(forms, {"set", {"get", x, {"quote", k}}, v})
end
end
if some63(forms) then
return(join({"let", x, join({"%array"}, l)}, forms, {x}))
else
return(join({"%array"}, l))
end
end})
setenv("if", {_stash = true, macro = function (...)
local branches = unstash({...})
return(hd(expand_if(branches)))
end})
setenv("case", {_stash = true, macro = function (expr, ...)
local _r13 = unstash({...})
local _expr1 = destash33(expr, _r13)
local _id4 = _r13
local clauses = cut(_id4, 0)
local x = unique("x")
local eq = function (_)
return({"=", {"quote", _}, x})
end
local cl = function (_x48)
local _id5 = _x48
local a = _id5[1]
local b = _id5[2]
if nil63(b) then
return({a})
else
if string63(a) or number63(a) then
return({eq(a), b})
else
if one63(a) then
return({eq(hd(a)), b})
else
if _35(a) > 1 then
return({join({"or"}, map(eq, a)), b})
end
end
end
end
end
return({"let", x, _expr1, join({"if"}, apply(join, map(cl, pair(clauses))))})
end})
setenv("when", {_stash = true, macro = function (cond, ...)
local _r17 = unstash({...})
local _cond1 = destash33(cond, _r17)
local _id7 = _r17
local body = cut(_id7, 0)
return({"if", _cond1, join({"do"}, body)})
end})
setenv("unless", {_stash = true, macro = function (cond, ...)
local _r19 = unstash({...})
local _cond3 = destash33(cond, _r19)
local _id9 = _r19
local body = cut(_id9, 0)
return({"if", {"not", _cond3}, join({"do"}, body)})
end})
setenv("obj", {_stash = true, macro = function (...)
local body = unstash({...})
return(join({"%object"}, mapo(function (x)
return(x)
end, body)))
end})
setenv("let", {_stash = true, macro = function (bs, ...)
local _r23 = unstash({...})
local _bs1 = destash33(bs, _r23)
local _id13 = _r23
local body = cut(_id13, 0)
if atom63(_bs1) then
return(join({"let", {_bs1, hd(body)}}, tl(body)))
else
if none63(_bs1) then
return(join({"do"}, body))
else
local _id14 = _bs1
local lh = _id14[1]
local rh = _id14[2]
local bs2 = cut(_id14, 2)
local _id15 = bind(lh, rh)
local id = _id15[1]
local val = _id15[2]
local bs1 = cut(_id15, 2)
local renames = {}
if bound63(id) or toplevel63() then
local id1 = unique(id)
renames = {id, id1}
id = id1
else
setenv(id, {_stash = true, variable = true})
end
return({"do", {"%local", id, val}, {"let-symbol", renames, join({"let", join(bs1, bs2)}, body)}})
end
end
end})
setenv("with", {_stash = true, macro = function (x, v, ...)
local _r25 = unstash({...})
local _x98 = destash33(x, _r25)
local _v1 = destash33(v, _r25)
local _id17 = _r25
local body = cut(_id17, 0)
return(join({"let", {_x98, _v1}}, body, {_x98}))
end})
setenv("let-when", {_stash = true, macro = function (x, v, ...)
local _r27 = unstash({...})
local _x110 = destash33(x, _r27)
local _v3 = destash33(v, _r27)
local _id19 = _r27
local body = cut(_id19, 0)
local y = unique("y")
return({"let", y, _v3, {"when", {"yes", y}, join({"let", {_x110, y}}, body)}})
end})
setenv("define-macro", {_stash = true, macro = function (name, args, ...)
local _r29 = unstash({...})
local _name1 = destash33(name, _r29)
local _args1 = destash33(args, _r29)
local _id21 = _r29
local body = cut(_id21, 0)
local _x121 = {"setenv", {"quote", _name1}}
_x121.macro = join({"fn", _args1}, body)
local form = _x121
eval(form)
return(form)
end})
setenv("define-special", {_stash = true, macro = function (name, args, ...)
local _r31 = unstash({...})
local _name3 = destash33(name, _r31)
local _args3 = destash33(args, _r31)
local _id23 = _r31
local body = cut(_id23, 0)
local _x129 = {"setenv", {"quote", _name3}}
_x129.special = join({"fn", _args3}, body)
local form = join(_x129, keys(body))
eval(form)
return(form)
end})
setenv("define-symbol", {_stash = true, macro = function (name, expansion)
setenv(name, {_stash = true, symbol = expansion})
local _x135 = {"setenv", {"quote", name}}
_x135.symbol = {"quote", expansion}
return(_x135)
end})
setenv("define-reader", {_stash = true, macro = function (_x144, ...)
local _id26 = _x144
local char = _id26[1]
local s = _id26[2]
local _r35 = unstash({...})
local __x144 = destash33(_x144, _r35)
local _id27 = _r35
local body = cut(_id27, 0)
return({"set", {"get", "read-table", char}, join({"fn", {s}}, body)})
end})
setenv("define", {_stash = true, macro = function (name, x, ...)
local _r37 = unstash({...})
local _name5 = destash33(name, _r37)
local _x155 = destash33(x, _r37)
local _id29 = _r37
local body = cut(_id29, 0)
setenv(_name5, {_stash = true, variable = true})
if some63(body) then
return(join({"%local-function", _name5}, bind42(_x155, body)))
else
return({"%local", _name5, _x155})
end
end})
setenv("define-global", {_stash = true, macro = function (name, x, ...)
local _r39 = unstash({...})
local _name7 = destash33(name, _r39)
local _x163 = destash33(x, _r39)
local _id31 = _r39
local body = cut(_id31, 0)
setenv(_name7, {_stash = true, toplevel = true, variable = true})
if some63(body) then
return(join({"%global-function", _name7}, bind42(_x163, body)))
else
return({"set", _name7, _x163})
end
end})
setenv("with-frame", {_stash = true, macro = function (...)
local body = unstash({...})
local x = unique("x")
return({"do", {"add", "environment", {"obj"}}, {"with", x, join({"do"}, body), {"drop", "environment"}}})
end})
setenv("with-bindings", {_stash = true, macro = function (_x185, ...)
local _id34 = _x185
local names = _id34[1]
local _r41 = unstash({...})
local __x185 = destash33(_x185, _r41)
local _id35 = _r41
local body = cut(_id35, 0)
local x = unique("x")
local _x189 = {"setenv", x}
_x189.variable = true
return(join({"with-frame", {"each", x, names, _x189}}, body))
end})
setenv("let-macro", {_stash = true, macro = function (definitions, ...)
local _r44 = unstash({...})
local _definitions1 = destash33(definitions, _r44)
local _id37 = _r44
local body = cut(_id37, 0)
add(environment, {})
map(function (m)
return(macroexpand(join({"define-macro"}, m)))
end, _definitions1)
local _x195 = join({"do"}, macroexpand(body))
drop(environment)
return(_x195)
end})
setenv("let-symbol", {_stash = true, macro = function (expansions, ...)
local _r48 = unstash({...})
local _expansions1 = destash33(expansions, _r48)
local _id40 = _r48
local body = cut(_id40, 0)
add(environment, {})
map(function (_x205)
local _id41 = _x205
local name = _id41[1]
local exp = _id41[2]
return(macroexpand({"define-symbol", name, exp}))
end, pair(_expansions1))
local _x204 = join({"do"}, macroexpand(body))
drop(environment)
return(_x204)
end})
setenv("let-unique", {_stash = true, macro = function (names, ...)
local _r52 = unstash({...})
local _names1 = destash33(names, _r52)
local _id43 = _r52
local body = cut(_id43, 0)
local bs = map(function (n)
return({n, {"unique", {"quote", n}}})
end, _names1)
return(join({"let", apply(join, bs)}, body))
end})
setenv("fn", {_stash = true, macro = function (args, ...)
local _r55 = unstash({...})
local _args5 = destash33(args, _r55)
local _id45 = _r55
local body = cut(_id45, 0)
return(join({"%function"}, bind42(_args5, body)))
end})
setenv("apply", {_stash = true, macro = function (f, ...)
local _r57 = unstash({...})
local _f1 = destash33(f, _r57)
local _id47 = _r57
local args = cut(_id47, 0)
if _35(args) > 1 then
return({{"do", "apply"}, _f1, {"join", join({"list"}, almost(args)), last(args)}})
else
return(join({{"do", "apply"}, _f1}, args))
end
end})
setenv("guard", {_stash = true, macro = function (expr)
if target == "js" then
return({{"fn", join(), {"%try", {"list", true, expr}}}})
else
local x = unique("x")
local msg = unique("msg")
local trace = unique("trace")
local _x287 = {"obj"}
_x287.stack = trace
_x287.message = msg
return({"let", {x, "nil", msg, "nil", trace, "nil"}, {"if", {"xpcall", {"fn", join(), {"set", x, expr}}, {"fn", {"m"}, {"set", trace, {{"get", "debug", {"quote", "traceback"}}}, msg, {"if", {"string?", "m"}, {"clip", "m", {"+", {"search", "m", "\": \""}, 2}}, {"nil?", "m"}, "\"\"", {"str", "m"}}}}}, {"list", true, x}, {"list", false, _x287}}})
end
end})
setenv("each", {_stash = true, macro = function (x, t, ...)
local _r61 = unstash({...})
local _x304 = destash33(x, _r61)
local _t1 = destash33(t, _r61)
local _id50 = _r61
local body = cut(_id50, 0)
local o = unique("o")
local n = unique("n")
local i = unique("i")
local _e5
if atom63(_x304) then
_e5 = {i, _x304}
else
local _e6
if _35(_x304) > 1 then
_e6 = _x304
else
_e6 = {i, hd(_x304)}
end
_e5 = _e6
end
local _id51 = _e5
local k = _id51[1]
local v = _id51[2]
local _e7
if target == "lua" then
_e7 = body
else
_e7 = {join({"let", k, {"if", {"numeric?", k}, {"parseInt", k}, k}}, body)}
end
return({"let", {o, _t1, k, "nil"}, {"%for", o, k, join({"let", {v, {"get", o, k}}}, _e7)}})
end})
setenv("for", {_stash = true, macro = function (i, to, ...)
local _r63 = unstash({...})
local _i3 = destash33(i, _r63)
local _to1 = destash33(to, _r63)
local _id53 = _r63
local body = cut(_id53, 0)
return({"let", _i3, 0, join({"while", {"<", _i3, _to1}}, body, {{"inc", _i3}})})
end})
setenv("step", {_stash = true, macro = function (v, t, ...)
local _r65 = unstash({...})
local _v5 = destash33(v, _r65)
local _t3 = destash33(t, _r65)
local _id55 = _r65
local body = cut(_id55, 0)
local x = unique("x")
local i = unique("i")
return({"let", {x, _t3}, {"for", i, {"#", x}, join({"let", {_v5, {"at", x, i}}}, body)}})
end})
setenv("set-of", {_stash = true, macro = function (...)
local xs = unstash({...})
local l = {}
local _o3 = xs
local _i5 = nil
for _i5 in next, _o3 do
local x = _o3[_i5]
l[x] = true
end
return(join({"obj"}, l))
end})
setenv("language", {_stash = true, macro = function ()
return({"quote", target})
end})
setenv("target", {_stash = true, macro = function (...)
local clauses = unstash({...})
return(clauses[target])
end})
setenv("join!", {_stash = true, macro = function (a, ...)
local _r69 = unstash({...})
local _a1 = destash33(a, _r69)
local _id57 = _r69
local bs = cut(_id57, 0)
return({"set", _a1, join({"join", _a1}, bs)})
end})
setenv("cat!", {_stash = true, macro = function (a, ...)
local _r71 = unstash({...})
local _a3 = destash33(a, _r71)
local _id59 = _r71
local bs = cut(_id59, 0)
return({"set", _a3, join({"cat", _a3}, bs)})
end})
setenv("inc", {_stash = true, macro = function (n, by)
local _e8
if nil63(by) then
_e8 = 1
else
_e8 = by
end
return({"set", n, {"+", n, _e8}})
end})
setenv("dec", {_stash = true, macro = function (n, by)
local _e9
if nil63(by) then
_e9 = 1
else
_e9 = by
end
return({"set", n, {"-", n, _e9}})
end})
setenv("with-indent", {_stash = true, macro = function (form)
local x = unique("x")
return({"do", {"inc", "indent-level"}, {"with", x, form, {"dec", "indent-level"}}})
end})
setenv("export", {_stash = true, macro = function (...)
local names = unstash({...})
if target == "js" then
return(join({"do"}, map(function (k)
return({"set", {"get", "exports", {"quote", k}}, k})
end, names)))
else
local x = {}
local _o5 = names
local _i7 = nil
for _i7 in next, _o5 do
local k = _o5[_i7]
x[k] = k
end
return({"return", join({"obj"}, x)})
end
end})
setenv("when-compiling", {_stash = true, macro = function (...)
local body = unstash({...})
return(eval(join({"do"}, body)))
end})
local delimiters = {["("] = true, ["\n"] = true, [")"] = true, [";"] = true}
local whitespace = {["\n"] = true, ["\t"] = true, [" "] = true}
local function stream(str, more)
return({len = _35(str), string = str, more = more, pos = 0})
end
local function peek_char(s)
local _id = s
local string = _id.string
local len = _id.len
local pos = _id.pos
if pos < len then
return(char(string, pos))
end
end
local function read_char(s)
local c = peek_char(s)
if c then
s.pos = s.pos + 1
return(c)
end
end
local function skip_non_code(s)
while true do
local c = peek_char(s)
if nil63(c) then
break
else
if whitespace[c] then
read_char(s)
else
if c == ";" then
while c and not( c == "\n") do
c = read_char(s)
end
skip_non_code(s)
else
break
end
end
end
end
end
local read_table = {}
local eof = {}
local function read(s)
skip_non_code(s)
local c = peek_char(s)
if is63(c) then
return((read_table[c] or read_table[""])(s))
else
return(eof)
end
end
local function read_all(s)
local l = {}
while true do
local form = read(s)
if form == eof then
break
end
add(l, form)
end
return(l)
end
function read_string(str, more)
local x = read(stream(str, more))
if not( x == eof) then
return(x)
end
end
local function key63(atom)
return(string63(atom) and _35(atom) > 1 and char(atom, edge(atom)) == ":")
end
local function flag63(atom)
return(string63(atom) and _35(atom) > 1 and char(atom, 0) == ":")
end
local function expected(s, c)
local _id1 = s
local more = _id1.more
local pos = _id1.pos
local _id2 = more
local _e
if _id2 then
_e = _id2
else
error("Expected " .. c .. " at " .. pos)
_e = nil
end
return(_e)
end
local function wrap(s, x)
local y = read(s)
if y == s.more then
return(y)
else
return({x, y})
end
end
local function maybe_number(str)
if number_code63(code(str, edge(str))) then
return(number(str))
end
end
local function real63(x)
return(number63(x) and not nan63(x) and not inf63(x))
end
local function valid_access63(str)
return(_35(str) > 2 and not( "." == char(str, 0)) and not( "." == char(str, edge(str))) and not search(str, ".."))
end
local function parse_access(str)
return(reduce(function (a, b)
local n = number(a)
if is63(n) then
return({"at", b, n})
else
return({"get", b, {"quote", a}})
end
end, reverse(split(str, "."))))
end
read_table[""] = function (s)
local str = ""
local dot63 = false
while true do
local c = peek_char(s)
if c and (not whitespace[c] and not delimiters[c]) then
if c == "." then
dot63 = true
end
str = str .. read_char(s)
else
break
end
end
if str == "true" then
return(true)
else
if str == "false" then
return(false)
else
if str == "nan" then
return(nan)
else
if str == "-nan" then
return(nan)
else
if str == "inf" then
return(inf)
else
if str == "-inf" then
return(-inf)
else
local n = maybe_number(str)
if real63(n) then
return(n)
else
if dot63 and valid_access63(str) then
return(parse_access(str))
else
return(str)
end
end
end
end
end
end
end
end
end
read_table["("] = function (s)
read_char(s)
local r = nil
local l = {}
while nil63(r) do
skip_non_code(s)
local c = peek_char(s)
if c == ")" then
read_char(s)
r = l
else
if nil63(c) then
r = expected(s, ")")
else
local x = read(s)
if key63(x) then
local k = clip(x, 0, edge(x))
local v = read(s)
l[k] = v
else
if flag63(x) then
l[clip(x, 1)] = true
else
add(l, x)
end
end
end
end
end
return(r)
end
read_table[")"] = function (s)
error("Unexpected ) at " .. s.pos)
end
read_table["\""] = function (s)
read_char(s)
local r = nil
local str = "\""
while nil63(r) do
local c = peek_char(s)
if c == "\"" then
r = str .. read_char(s)
else
if nil63(c) then
r = expected(s, "\"")
else
if c == "\\" then
str = str .. read_char(s)
end
str = str .. read_char(s)
end
end
end
return(r)
end
read_table["|"] = function (s)
read_char(s)
local r = nil
local str = "|"
while nil63(r) do
local c = peek_char(s)
if c == "|" then
r = str .. read_char(s)
else
if nil63(c) then
r = expected(s, "|")
else
str = str .. read_char(s)
end
end
end
return(r)
end
read_table["'"] = function (s)
read_char(s)
return(wrap(s, "quote"))
end
read_table["`"] = function (s)
read_char(s)
return(wrap(s, "quasiquote"))
end
read_table[","] = function (s)
read_char(s)
if peek_char(s) == "@" then
read_char(s)
return(wrap(s, "unquote-splicing"))
else
return(wrap(s, "unquote"))
end
end
reader = ({["read-all"] = read_all, ["read-string"] = read_string, stream = stream, ["read-table"] = read_table, read = read})
local function getenv(k, p)
if string63(k) then
local i = edge(environment)
while i >= 0 do
local b = environment[i + 1][k]
if is63(b) then
local _e9
if p then
_e9 = b[p]
else
_e9 = b
end
return(_e9)
else
i = i - 1
end
end
end
end
local function macro_function(k)
return(getenv(k, "macro"))
end
local function macro63(k)
return(is63(macro_function(k)))
end
local function special63(k)
return(is63(getenv(k, "special")))
end
local function special_form63(form)
return(not atom63(form) and special63(hd(form)))
end
local function statement63(k)
return(special63(k) and getenv(k, "stmt"))
end
local function symbol_expansion(k)
return(getenv(k, "symbol"))
end
local function symbol63(k)
return(is63(symbol_expansion(k)))
end
local function variable63(k)
local b = first(function (frame)
return(frame[k])
end, reverse(environment))
return(not atom63(b) and is63(b.variable))
end
function bound63(x)
return(macro63(x) or special63(x) or symbol63(x) or variable63(x))
end
function quoted(form)
if string63(form) then
return(escape(form))
else
if atom63(form) then
return(form)
else
return(join({"list"}, map(quoted, form)))
end
end
end
local function literal(s)
if string_literal63(s) then
return(s)
else
return(quoted(s))
end
end
local _names = {}
function unique(x)
if _names[x] then
local i = _names[x]
_names[x] = _names[x] + 1
return(unique(x .. i))
else
_names[x] = 1
return("_" .. x)
end
end
local function stash42(args)
if keys63(args) then
local l = {"%object", "\"_stash\"", true}
local _o = args
local k = nil
for k in next, _o do
local v = _o[k]
if not number63(k) then
add(l, literal(k))
add(l, v)
end
end
return(join(args, {l}))
else
return(args)
end
end
local function bias(k)
if number63(k) and not( target == "lua") then
if target == "js" then
k = k - 1
else
k = k + 1
end
end
return(k)
end
function bind(lh, rh)
if atom63(lh) then
return({lh, rh})
else
local id = unique("id")
local bs = {id, rh}
local _o1 = lh
local k = nil
for k in next, _o1 do
local v = _o1[k]
local _e10
if k == "rest" then
_e10 = {"cut", id, _35(lh)}
else
_e10 = {"get", id, {"quote", bias(k)}}
end
local x = _e10
if is63(k) then
local _e11
if v == true then
_e11 = k
else
_e11 = v
end
local _k = _e11
bs = join(bs, bind(_k, x))
end
end
return(bs)
end
end
setenv("arguments%", {_stash = true, macro = function (from)
return({{"get", {"get", {"get", "Array", {"quote", "prototype"}}, {"quote", "slice"}}, {"quote", "call"}}, "arguments", from})
end})
function bind42(args, body)
local args1 = {}
local function rest()
if target == "js" then
return({"unstash", {"arguments%", _35(args1)}})
else
add(args1, "|...|")
return({"unstash", {"list", "|...|"}})
end
end
if atom63(args) then
return({args1, join({"let", {args, rest()}}, body)})
else
local bs = {}
local r = unique("r")
local _o2 = args
local k = nil
for k in next, _o2 do
local v = _o2[k]
if number63(k) then
if atom63(v) then
add(args1, v)
else
local x = unique("x")
add(args1, x)
bs = join(bs, {v, x})
end
end
end
if keys63(args) then
bs = join(bs, {r, rest()})
local _e12
if target == "lua" then
_e12 = edge(args1)
else
_e12 = _35(args1)
end
local n = _e12
local i = 0
while i < n do
local v = args1[i + 1]
bs = join(bs, {v, {"destash!", v, r}})
i = i + 1
end
bs = join(bs, {keys(args), r})
end
return({args1, join({"let", bs}, body)})
end
end
local function quoting63(depth)
return(number63(depth))
end
local function quasiquoting63(depth)
return(quoting63(depth) and depth > 0)
end
local function can_unquote63(depth)
return(quoting63(depth) and depth == 1)
end
local function quasisplice63(x, depth)
return(can_unquote63(depth) and not atom63(x) and hd(x) == "unquote-splicing")
end
local function expand_local(_x36)
local _id = _x36
local x = _id[1]
local name = _id[2]
local value = _id[3]
return({"%local", name, macroexpand(value)})
end
local function expand_function(_x38)
local _id1 = _x38
local x = _id1[1]
local args = _id1[2]
local body = cut(_id1, 2)
add(environment, {})
local _o3 = args
local _i3 = nil
for _i3 in next, _o3 do
local _x39 = _o3[_i3]
setenv(_x39, {_stash = true, variable = true})
end
local _x40 = join({"%function", args}, macroexpand(body))
drop(environment)
return(_x40)
end
local function expand_definition(_x42)
local _id2 = _x42
local x = _id2[1]
local name = _id2[2]
local args = _id2[3]
local body = cut(_id2, 3)
add(environment, {})
local _o4 = args
local _i4 = nil
for _i4 in next, _o4 do
local _x43 = _o4[_i4]
setenv(_x43, {_stash = true, variable = true})
end
local _x44 = join({x, name, args}, macroexpand(body))
drop(environment)
return(_x44)
end
local function expand_macro(form)
return(macroexpand(expand1(form)))
end
function expand1(_x46)
local _id3 = _x46
local name = _id3[1]
local body = cut(_id3, 1)
return(apply(macro_function(name), body))
end
function macroexpand(form)
if symbol63(form) then
return(macroexpand(symbol_expansion(form)))
else
if atom63(form) then
return(form)
else
local x = hd(form)
if x == "%local" then
return(expand_local(form))
else
if x == "%function" then
return(expand_function(form))
else
if x == "%global-function" then
return(expand_definition(form))
else
if x == "%local-function" then
return(expand_definition(form))
else
if macro63(x) then
return(expand_macro(form))
else
return(map(macroexpand, form))
end
end
end
end
end
end
end
end
local function quasiquote_list(form, depth)
local xs = {{"list"}}
local _o5 = form
local k = nil
for k in next, _o5 do
local v = _o5[k]
if not number63(k) then
local _e13
if quasisplice63(v, depth) then
_e13 = quasiexpand(v[2])
else
_e13 = quasiexpand(v, depth)
end
local _v = _e13
last(xs)[k] = _v
end
end
local _x49 = form
local _i6 = 0
while _i6 < _35(_x49) do
local x = _x49[_i6 + 1]
if quasisplice63(x, depth) then
local _x50 = quasiexpand(x[2])
add(xs, _x50)
add(xs, {"list"})
else
add(last(xs), quasiexpand(x, depth))
end
_i6 = _i6 + 1
end
local pruned = keep(function (x)
return(_35(x) > 1 or not( hd(x) == "list") or keys63(x))
end, xs)
if one63(pruned) then
return(hd(pruned))
else
return(join({"join"}, pruned))
end
end
function quasiexpand(form, depth)
if quasiquoting63(depth) then
if atom63(form) then
return({"quote", form})
else
if can_unquote63(depth) and hd(form) == "unquote" then
return(quasiexpand(form[2]))
else
if hd(form) == "unquote" or hd(form) == "unquote-splicing" then
return(quasiquote_list(form, depth - 1))
else
if hd(form) == "quasiquote" then
return(quasiquote_list(form, depth + 1))
else
return(quasiquote_list(form, depth))
end
end
end
end
else
if atom63(form) then
return(form)
else
if hd(form) == "quote" then
return(form)
else
if hd(form) == "quasiquote" then
return(quasiexpand(form[2], 1))
else
return(map(function (x)
return(quasiexpand(x, depth))
end, form))
end
end
end
end
end
function expand_if(_x54)
local _id4 = _x54
local a = _id4[1]
local b = _id4[2]
local c = cut(_id4, 2)
if is63(b) then
return({join({"%if", a, b}, expand_if(c))})
else
if is63(a) then
return({a})
end
end
end
indent_level = 0
function indentation()
local s = ""
local i = 0
while i < indent_level do
s = s .. " "
i = i + 1
end
return(s)
end
local reserved = {["default"] = true, ["until"] = true, ["while"] = true, ["throw"] = true, ["not"] = true, ["nil"] = true, ["typeof"] = true, ["=="] = true, ["in"] = true, ["catch"] = true, ["delete"] = true, ["instanceof"] = true, ["%"] = true, ["or"] = true, ["return"] = true, ["try"] = true, ["debugger"] = true, [">"] = true, ["<"] = true, ["true"] = true, ["var"] = true, ["continue"] = true, ["then"] = true, ["for"] = true, ["finally"] = true, ["function"] = true, ["<="] = true, ["void"] = true, ["local"] = true, ["="] = true, ["false"] = true, ["with"] = true, ["break"] = true, ["-"] = true, ["end"] = true, ["/"] = true, ["and"] = true, ["new"] = true, ["switch"] = true, ["elseif"] = true, ["case"] = true, [">="] = true, ["+"] = true, ["*"] = true, ["do"] = true, ["repeat"] = true, ["else"] = true, ["if"] = true}
function reserved63(x)
return(reserved[x])
end
local function valid_code63(n)
return(number_code63(n) or n > 64 and n < 91 or n > 96 and n < 123 or n == 95)
end
function valid_id63(id)
if none63(id) or reserved63(id) then
return(false)
else
local i = 0
while i < _35(id) do
if not valid_code63(code(id, i)) then
return(false)
end
i = i + 1
end
return(true)
end
end
function key(k)
local i = inner(k)
if valid_id63(i) then
return(i)
else
if target == "js" then
return(k)
else
return("[" .. k .. "]")
end
end
end
function mapo(f, t)
local o = {}
local _o6 = t
local k = nil
for k in next, _o6 do
local v = _o6[k]
local x = f(v)
if is63(x) then
add(o, literal(k))
add(o, x)
end
end
return(o)
end
local __x59 = {}
local _x60 = {}
_x60.js = "!"
_x60.lua = "not"
__x59["not"] = _x60
local __x61 = {}
__x61["/"] = true
__x61["*"] = true
__x61["%"] = true
local __x62 = {}
__x62["-"] = true
__x62["+"] = true
local __x63 = {}
local _x64 = {}
_x64.js = "+"
_x64.lua = ".."
__x63.cat = _x64
local __x65 = {}
__x65["<"] = true
__x65[">"] = true
__x65[">="] = true
__x65["<="] = true
local __x66 = {}
local _x67 = {}
_x67.js = "==="
_x67.lua = "=="
__x66["="] = _x67
local __x68 = {}
local _x69 = {}
_x69.js = "&&"
_x69.lua = "and"
__x68["and"] = _x69
local __x70 = {}
local _x71 = {}
_x71.js = "||"
_x71.lua = "or"
__x70["or"] = _x71
local infix = {__x59, __x61, __x62, __x63, __x65, __x66, __x68, __x70}
local function unary63(form)
return(two63(form) and in63(hd(form), {"not", "-"}))
end
local function index(k)
if number63(k) then
return(k - 1)
end
end
local function precedence(form)
if not( atom63(form) or unary63(form)) then
local _o7 = infix
local k = nil
for k in next, _o7 do
local v = _o7[k]
if v[hd(form)] then
return(index(k))
end
end
end
return(0)
end
local function getop(op)
return(find(function (level)
local x = level[op]
if x == true then
return(op)
else
if is63(x) then
return(x[target])
end
end
end, infix))
end
local function infix63(x)
return(is63(getop(x)))
end
local function compile_args(args)
local s = "("
local c = ""
local _x73 = args
local _i9 = 0
while _i9 < _35(_x73) do
local x = _x73[_i9 + 1]
s = s .. c .. compile(x)
c = ", "
_i9 = _i9 + 1
end
return(s .. ")")
end
local function escape_newlines(s)
local s1 = ""
local i = 0
while i < _35(s) do
local c = char(s, i)
local _e14
if c == "\n" then
_e14 = "\\n"
else
_e14 = c
end
s1 = s1 .. _e14
i = i + 1
end
return(s1)
end
local function id(id)
local _e15
if number_code63(code(id, 0)) then
_e15 = "_"
else
_e15 = ""
end
local id1 = _e15
local i = 0
while i < _35(id) do
local c = char(id, i)
local n = code(c)
local _e16
if c == "-" then
_e16 = "_"
else
local _e17
if valid_code63(n) then
_e17 = c
else
local _e18
if i == 0 then
_e18 = "_" .. n
else
_e18 = n
end
_e17 = _e18
end
_e16 = _e17
end
local c1 = _e16
id1 = id1 .. c1
i = i + 1
end
if reserved63(id1) then
return("_" .. id1)
else
return(id1)
end
end
local function compile_atom(x)
if x == "nil" and target == "lua" then
return(x)
else
if x == "nil" then
return("undefined")
else
if id_literal63(x) then
return(inner(x))
else
if string_literal63(x) then
return(escape_newlines(x))
else
if string63(x) then
return(id(x))
else
if boolean63(x) then
if x then
return("true")
else
return("false")
end
else
if nan63(x) then
return("nan")
else
if x == inf then
return("inf")
else
if x == -inf then
return("-inf")
else
if number63(x) then
return(x .. "")
else
error("Cannot compile atom: " .. str(x))
end
end
end
end
end
end
end
end
end
end
end
local function terminator(stmt63)
if not stmt63 then
return("")
else
if target == "js" then
return(";\n")
else
return("\n")
end
end
end
local function compile_special(form, stmt63)
local _id5 = form
local x = _id5[1]
local args = cut(_id5, 1)
local _id6 = getenv(x)
local stmt = _id6.stmt
local self_tr63 = _id6.tr
local special = _id6.special
local tr = terminator(stmt63 and not self_tr63)
return(apply(special, args) .. tr)
end
local function parenthesize_call63(x)
return(not atom63(x) and hd(x) == "%function" or precedence(x) > 0)
end
local function compile_call(form)
local f = hd(form)
local f1 = compile(f)
local args = compile_args(stash42(tl(form)))
if parenthesize_call63(f) then
return("(" .. f1 .. ")" .. args)
else
return(f1 .. args)
end
end
local function op_delims(parent, child, ...)
local _r56 = unstash({...})
local _parent = destash33(parent, _r56)
local _child = destash33(child, _r56)
local _id7 = _r56
local right = _id7.right
local _e19
if right then
_e19 = _6261
else
_e19 = _62
end
if _e19(precedence(_child), precedence(_parent)) then
return({"(", ")"})
else
return({"", ""})
end
end
local function compile_infix(form)
local _id8 = form
local op = _id8[1]
local _id9 = cut(_id8, 1)
local a = _id9[1]
local b = _id9[2]
local _id10 = op_delims(form, a)
local ao = _id10[1]
local ac = _id10[2]
local _id11 = op_delims(form, b, {_stash = true, right = true})
local bo = _id11[1]
local bc = _id11[2]
local _a = compile(a)
local _b = compile(b)
local _op = getop(op)
if unary63(form) then
return(_op .. ao .. " " .. _a .. ac)
else
return(ao .. _a .. ac .. " " .. _op .. " " .. bo .. _b .. bc)
end
end
function compile_function(args, body, ...)
local _r58 = unstash({...})
local _args = destash33(args, _r58)
local _body = destash33(body, _r58)
local _id12 = _r58
local prefix = _id12.prefix
local name = _id12.name
local _e20
if name then
_e20 = compile(name)
else
_e20 = ""
end
local _id13 = _e20
local _args1 = compile_args(_args)
indent_level = indent_level + 1
local _x78 = compile(_body, {_stash = true, stmt = true})
indent_level = indent_level - 1
local _body1 = _x78
local ind = indentation()
local _e21
if prefix then
_e21 = prefix .. " "
else
_e21 = ""
end
local p = _e21
local _e22
if target == "js" then
_e22 = ""
else
_e22 = "end"
end
local tr = _e22
if name then
tr = tr .. "\n"
end
if target == "js" then
return("function " .. _id13 .. _args1 .. " {\n" .. _body1 .. ind .. "}" .. tr)
else
return(p .. "function " .. _id13 .. _args1 .. "\n" .. _body1 .. ind .. tr)
end
end
local function can_return63(form)
return(is63(form) and (atom63(form) or not( hd(form) == "return") and not statement63(hd(form))))
end
function compile(form, ...)
local _r60 = unstash({...})
local _form = destash33(form, _r60)
local _id14 = _r60
local stmt = _id14.stmt
if nil63(_form) then
return("")
else
if special_form63(_form) then
return(compile_special(_form, stmt))
else
local tr = terminator(stmt)
local _e23
if stmt then
_e23 = indentation()
else
_e23 = ""
end
local ind = _e23
local _e24
if atom63(_form) then
_e24 = compile_atom(_form)
else
local _e25
if infix63(hd(_form)) then
_e25 = compile_infix(_form)
else
_e25 = compile_call(_form)
end
_e24 = _e25
end
local _form1 = _e24
return(ind .. _form1 .. tr)
end
end
end
local function lower_statement(form, tail63)
local hoist = {}
local e = lower(form, hoist, true, tail63)
if some63(hoist) and is63(e) then
return(join({"do"}, hoist, {e}))
else
if is63(e) then
return(e)
else
if _35(hoist) > 1 then
return(join({"do"}, hoist))
else
return(hd(hoist))
end
end
end
end
local function lower_body(body, tail63)
return(lower_statement(join({"do"}, body), tail63))
end
local function literal63(form)
return(atom63(form) or hd(form) == "%array" or hd(form) == "%object")
end
local function standalone63(form)
return(not atom63(form) and not infix63(hd(form)) and not literal63(form) and not( "get" == hd(form)) or id_literal63(form))
end
local function lower_do(args, hoist, stmt63, tail63)
local _x84 = almost(args)
local _i10 = 0
while _i10 < _35(_x84) do
local x = _x84[_i10 + 1]
local _y = lower(x, hoist, stmt63)
if yes(_y) then
local e = _y
if standalone63(e) then
add(hoist, e)
end
end
_i10 = _i10 + 1
end
local e = lower(last(args), hoist, stmt63, tail63)
if tail63 and can_return63(e) then
return({"return", e})
else
return(e)
end
end
local function lower_set(args, hoist, stmt63, tail63)
local _id15 = args
local lh = _id15[1]
local rh = _id15[2]
add(hoist, {"%set", lh, lower(rh, hoist)})
if not( stmt63 and not tail63) then
return(lh)
end
end
local function lower_if(args, hoist, stmt63, tail63)
local _id16 = args
local cond = _id16[1]
local _then = _id16[2]
local _else = _id16[3]
if stmt63 then
local _e27
if is63(_else) then
_e27 = {lower_body({_else}, tail63)}
end
return(add(hoist, join({"%if", lower(cond, hoist), lower_body({_then}, tail63)}, _e27)))
else
local e = unique("e")
add(hoist, {"%local", e})
local _e26
if is63(_else) then
_e26 = {lower({"%set", e, _else})}
end
add(hoist, join({"%if", lower(cond, hoist), lower({"%set", e, _then})}, _e26))
return(e)
end
end
local function lower_short(x, args, hoist)
local _id17 = args
local a = _id17[1]
local b = _id17[2]
local hoist1 = {}
local b1 = lower(b, hoist1)
if some63(hoist1) then
local _id18 = unique("id")
local _e28
if x == "and" then
_e28 = {"%if", _id18, b, _id18}
else
_e28 = {"%if", _id18, _id18, b}
end
return(lower({"do", {"%local", _id18, a}, _e28}, hoist))
else
return({x, lower(a, hoist), b1})
end
end
local function lower_try(args, hoist, tail63)
return(add(hoist, {"%try", lower_body(args, tail63)}))
end
local function lower_while(args, hoist)
local _id19 = args
local c = _id19[1]
local body = cut(_id19, 1)
local pre = {}
local _c = lower(c, pre)
local _e29
if none63(pre) then
_e29 = {"while", _c, lower_body(body)}
else
_e29 = {"while", true, join({"do"}, pre, {{"%if", {"not", _c}, {"break"}}, lower_body(body)})}
end
return(add(hoist, _e29))
end
local function lower_for(args, hoist)
local _id20 = args
local t = _id20[1]
local k = _id20[2]
local body = cut(_id20, 2)
return(add(hoist, {"%for", lower(t, hoist), k, lower_body(body)}))
end
local function lower_function(args)
local _id21 = args
local a = _id21[1]
local body = cut(_id21, 1)
return({"%function", a, lower_body(body, true)})
end
local function lower_definition(kind, args, hoist)
local _id22 = args
local name = _id22[1]
local _args2 = _id22[2]
local body = cut(_id22, 2)
return(add(hoist, {kind, name, _args2, lower_body(body, true)}))
end
local function lower_call(form, hoist)
local _form2 = map(function (x)
return(lower(x, hoist))
end, form)
if some63(_form2) then
return(_form2)
end
end
local function lower_infix63(form)
return(infix63(hd(form)) and _35(form) > 3)
end
local function lower_infix(form, hoist)
local _id23 = form
local x = _id23[1]
local args = cut(_id23, 1)
return(lower(reduce(function (a, b)
return({x, b, a})
end, reverse(args)), hoist))
end
local function lower_special(form, hoist)
local e = lower_call(form, hoist)
if e then
return(add(hoist, e))
end
end
function lower(form, hoist, stmt63, tail63)
if atom63(form) then
return(form)
else
if empty63(form) then
return({"%array"})
else
if nil63(hoist) then
return(lower_statement(form))
else
if lower_infix63(form) then
return(lower_infix(form, hoist))
else
local _id24 = form
local x = _id24[1]
local args = cut(_id24, 1)
if x == "do" then
return(lower_do(args, hoist, stmt63, tail63))
else
if x == "%set" then
return(lower_set(args, hoist, stmt63, tail63))
else
if x == "%if" then
return(lower_if(args, hoist, stmt63, tail63))
else
if x == "%try" then
return(lower_try(args, hoist, tail63))
else
if x == "while" then
return(lower_while(args, hoist))
else
if x == "%for" then
return(lower_for(args, hoist))
else
if x == "%function" then
return(lower_function(args))
else
if x == "%local-function" or x == "%global-function" then
return(lower_definition(x, args, hoist))
else
if in63(x, {"and", "or"}) then
return(lower_short(x, args, hoist))
else
if statement63(x) then
return(lower_special(form, hoist))
else
return(lower_call(form, hoist))
end
end
end
end
end
end
end
end
end
end
end
end
end
end
end
function expand(form)
return(lower(macroexpand(form)))
end
local load1 = loadstring or load
local function run(code)
local f,e = load1(code)
if f then
return(f())
else
error(e .. " in " .. code)
end
end
_37result = nil
function eval(form)
local previous = target
target = "lua"
local code = compile(expand({"set", "%result", form}))
target = previous
run(code)
return(_37result)
end
setenv("do", {_stash = true, stmt = true, tr = true, special = function (...)
local forms = unstash({...})
local s = ""
local _x119 = forms
local _i12 = 0
while _i12 < _35(_x119) do
local x = _x119[_i12 + 1]
s = s .. compile(x, {_stash = true, stmt = true})
if not atom63(x) then
if hd(x) == "return" or hd(x) == "break" then
break
end
end
_i12 = _i12 + 1
end
return(s)
end})
setenv("%if", {_stash = true, stmt = true, tr = true, special = function (cond, cons, alt)
local _cond1 = compile(cond)
indent_level = indent_level + 1
local _x122 = compile(cons, {_stash = true, stmt = true})
indent_level = indent_level - 1
local _cons1 = _x122
local _e30
if alt then
indent_level = indent_level + 1
local _x123 = compile(alt, {_stash = true, stmt = true})
indent_level = indent_level - 1
_e30 = _x123
end
local _alt1 = _e30
local ind = indentation()
local s = ""
if target == "js" then
s = s .. ind .. "if (" .. _cond1 .. ") {\n" .. _cons1 .. ind .. "}"
else
s = s .. ind .. "if " .. _cond1 .. " then\n" .. _cons1
end
if _alt1 and target == "js" then
s = s .. " else {\n" .. _alt1 .. ind .. "}"
else
if _alt1 then
s = s .. ind .. "else\n" .. _alt1
end
end
if target == "lua" then
return(s .. ind .. "end\n")
else
return(s .. "\n")
end
end})
setenv("while", {_stash = true, stmt = true, tr = true, special = function (cond, form)
local _cond3 = compile(cond)
indent_level = indent_level + 1
local _x125 = compile(form, {_stash = true, stmt = true})
indent_level = indent_level - 1
local body = _x125
local ind = indentation()
if target == "js" then
return(ind .. "while (" .. _cond3 .. ") {\n" .. body .. ind .. "}\n")
else
return(ind .. "while " .. _cond3 .. " do\n" .. body .. ind .. "end\n")
end
end})
setenv("%for", {_stash = true, stmt = true, tr = true, special = function (t, k, form)
local _t1 = compile(t)
local ind = indentation()
indent_level = indent_level + 1
local _x127 = compile(form, {_stash = true, stmt = true})
indent_level = indent_level - 1
local body = _x127
if target == "lua" then
return(ind .. "for " .. k .. " in next, " .. _t1 .. " do\n" .. body .. ind .. "end\n")
else
return(ind .. "for (" .. k .. " in " .. _t1 .. ") {\n" .. body .. ind .. "}\n")
end
end})
setenv("%try", {_stash = true, stmt = true, tr = true, special = function (form)
local e = unique("e")
local ind = indentation()
indent_level = indent_level + 1
local _x132 = compile(form, {_stash = true, stmt = true})
indent_level = indent_level - 1
local body = _x132
local hf = {"return", {"%array", false, e}}
indent_level = indent_level + 1
local _x135 = compile(hf, {_stash = true, stmt = true})
indent_level = indent_level - 1
local h = _x135
return(ind .. "try {\n" .. body .. ind .. "}\n" .. ind .. "catch (" .. e .. ") {\n" .. h .. ind .. "}\n")
end})
setenv("%delete", {_stash = true, special = function (place)
return(indentation() .. "delete " .. compile(place))
end, stmt = true})
setenv("break", {_stash = true, special = function ()
return(indentation() .. "break")
end, stmt = true})
setenv("%function", {_stash = true, special = function (args, body)
return(compile_function(args, body))
end})
setenv("%global-function", {_stash = true, stmt = true, tr = true, special = function (name, args, body)
if target == "lua" then
local x = compile_function(args, body, {_stash = true, name = name})
return(indentation() .. x)
else
return(compile({"%set", name, {"%function", args, body}}, {_stash = true, stmt = true}))
end
end})
setenv("%local-function", {_stash = true, stmt = true, tr = true, special = function (name, args, body)
if target == "lua" then
local x = compile_function(args, body, {_stash = true, prefix = "local", name = name})
return(indentation() .. x)
else
return(compile({"%local", name, {"%function", args, body}}, {_stash = true, stmt = true}))
end
end})
setenv("return", {_stash = true, special = function (x)
local _e31
if nil63(x) then
_e31 = "return"
else
_e31 = "return(" .. compile(x) .. ")"
end
local _x145 = _e31
return(indentation() .. _x145)
end, stmt = true})
setenv("new", {_stash = true, special = function (x)
return("new " .. compile(x))
end})
setenv("typeof", {_stash = true, special = function (x)
return("typeof(" .. compile(x) .. ")")
end})
setenv("error", {_stash = true, special = function (x)
local _e32
if target == "js" then
_e32 = "throw " .. compile({"new", {"Error", x}})
else
_e32 = "error(" .. compile(x) .. ")"
end
local e = _e32
return(indentation() .. e)
end, stmt = true})
setenv("%local", {_stash = true, special = function (name, value)
local _id26 = compile(name)
local value1 = compile(value)
local _e33
if is63(value) then
_e33 = " = " .. value1
else
_e33 = ""
end
local rh = _e33
local _e34
if target == "js" then
_e34 = "var "
else
_e34 = "local "
end
local keyword = _e34
local ind = indentation()
return(ind .. keyword .. _id26 .. rh)
end, stmt = true})
setenv("%set", {_stash = true, special = function (lh, rh)
local _lh1 = compile(lh)
local _e35
if nil63(rh) then
_e35 = "nil"
else
_e35 = rh
end
local _rh1 = compile(_e35)
return(indentation() .. _lh1 .. " = " .. _rh1)
end, stmt = true})
setenv("get", {_stash = true, special = function (t, k)
local _t3 = compile(t)
local k1 = compile(k)
if target == "lua" and char(_t3, 0) == "{" then
_t3 = "(" .. _t3 .. ")"
end
if string_literal63(k) and valid_id63(inner(k)) then
return(_t3 .. "." .. inner(k))
else
return(_t3 .. "[" .. k1 .. "]")
end
end})
setenv("%array", {_stash = true, special = function (...)
local forms = unstash({...})
local _e36
if target == "lua" then
_e36 = "{"
else
_e36 = "["
end
local open = _e36
local _e37
if target == "lua" then
_e37 = "}"
else
_e37 = "]"
end
local close = _e37
local s = ""
local c = ""
local _o9 = forms
local k = nil
for k in next, _o9 do
local v = _o9[k]
if number63(k) then
s = s .. c .. compile(v)
c = ", "
end
end
return(open .. s .. close)
end})
setenv("%object", {_stash = true, special = function (...)
local forms = unstash({...})
local s = "{"
local c = ""
local _e38
if target == "lua" then
_e38 = " = "
else
_e38 = ": "
end
local sep = _e38
local _o11 = pair(forms)
local k = nil
for k in next, _o11 do
local v = _o11[k]
if number63(k) then
local _id28 = v
local _k2 = _id28[1]
local _v2 = _id28[2]
if not string63(_k2) then
error("Illegal key: " .. str(_k2))
end
s = s .. c .. key(_k2) .. sep .. compile(_v2)
c = ", "
end
end
return(s .. "}")
end})
compiler = ({run = run, eval = eval, expand = expand, compile = compile})
function str2(x, stack)
if nil63(x) then
return("nil")
else
if nan63(x) then
return("nan")
else
if x == inf then
return("inf")
else
if x == -inf then
return("-inf")
else
if boolean63(x) then
if x then
return("true")
else
return("false")
end
else
if string63(x) then
return(escape(x))
else
if atom63(x) then
return(tostring(x))
end
end
end
end
end
end
end
end
function encode(str)
local html = function(s)
return ('&#%02d;'):format(s:byte())
end
return str:gsub('([<>&\'"])', html)
end
function prn(str)
print(apply(cat, map(function (line)
return "<pre>" .. encode(line) .. "</pre>"
end, split(str, "\n"))))
end
function rep(x)
print(str(eval(read_string("(do " .. x .. ")"))))
end
rep("(((fn (x) (fn (y) (+ x y 1 2 3 4))) 5) 6)")
function comp(code)
return compile(expand(read_string("(do " .. code .. ")")))
end
lisp = [[
(define adder (n)
(fn (y)
(+ n y)))
(define 1+ (adder 1))
(print (1+ 41)) ; prints 42
]]
rep(lisp)
-- compile to Lua.
prn(comp(lisp))
-- let's compile the runtime to Lua.
runtime = [[
(define-global environment (list (obj)))
(define-global target (language))
(define-global nil? (x)
(target
js: (or (= x nil) (= x null))
lua: (= x nil)))
(define-global is? (x) (not (nil? x)))
(define-global no (x) (or (nil? x) (= x false)))
(define-global yes (x) (not (no x)))
(define-global # (x)
(target js: (or (get x 'length) 0) lua: |#x|))
(define-global none? (x) (= (# x) 0))
(define-global some? (x) (> (# x) 0))
(define-global one? (x) (= (# x) 1))
(define-global two? (x) (= (# x) 2))
(define-global hd (l) (at l 0))
(target js: (define-global type (x) (typeof x)))
(define-global string? (x) (= (type x) 'string))
(define-global number? (x) (= (type x) 'number))
(define-global boolean? (x) (= (type x) 'boolean))
(define-global function? (x) (= (type x) 'function))
(define-global obj? (x)
(and (is? x)
(= (type x) (target lua: 'table js: 'object))))
(define-global atom? (x)
(or (nil? x) (string? x) (number? x) (boolean? x)))
(define-global nan (/ 0 0))
(define-global inf (/ 1 0))
(define-global nan? (n)
(not (= n n)))
(define-global inf? (n)
(or (= n inf) (= n -inf)))
(define-global clip (s from upto)
(target js: ((get s 'substring) from upto)
lua: ((get string 'sub) s (+ from 1) upto)))
(define-global cut (x from upto)
(with l ()
(let (j 0
i (if (or (nil? from) (< from 0)) 0 from)
n (# x)
upto (if (or (nil? upto) (> upto n)) n upto))
(while (< i upto)
(set (at l j) (at x i))
(inc i)
(inc j))
(each (k v) x
(unless (number? k)
(set (get l k) v))))))
(define-global keys (x)
(with t ()
(each (k v) x
(unless (number? k)
(set (get t k) v)))))
(define-global edge (x)
(- (# x) 1))
(define-global inner (x)
(clip x 1 (edge x)))
(define-global tl (l) (cut l 1))
(define-global char (s n)
(target js: ((get s 'charAt) n) lua: (clip s n (+ n 1))))
(define-global code (s n)
(target
js: ((get s 'charCodeAt) n)
lua: ((get string 'byte) s (if n (+ n 1)))))
(define-global string-literal? (x)
(and (string? x) (= (char x 0) "\"")))
(define-global id-literal? (x)
(and (string? x) (= (char x 0) "|")))
(define-global add (l x)
(target js: (do ((get l 'push) x) nil)
lua: ((get table 'insert) l x)))
(define-global drop (l)
(target js: ((get l 'pop))
lua: ((get table 'remove) l)))
(define-global last (l)
(at l (edge l)))
(define-global almost (l)
(cut l 0 (edge l)))
(define-global reverse (l)
(with l1 (keys l)
(let i (edge l)
(while (>= i 0)
(add l1 (at l i))
(dec i)))))
(define-global reduce (f x)
(if (none? x) nil
(one? x) (hd x)
(f (hd x) (reduce f (tl x)))))
(define-global join ls
(with r ()
(step l ls
(when l
(let n (# r)
(each (k v) l
(if (number? k) (inc k n))
(set (get r k) v)))))))
(define-global find (f t)
(each x t
(let y (f x)
(if y (return y)))))
(define-global first (f l)
(step x l
(let y (f x)
(if y (return y)))))
(define-global in? (x t)
(find (fn (y) (= x y)) t))
(define-global pair (l)
(with l1 ()
(for i (# l)
(add l1 (list (at l i) (at l (+ i 1))))
(inc i))))
(define-global sort (l f)
(target
lua: (do ((get table 'sort) l f) l)
js: ((get l 'sort) (when f (fn (a b) (if (f a b) -1 1))))))
(define-global map (f x)
(with t ()
(step v x
(let y (f v)
(if (is? y)
(add t y))))
(each (k v) x
(unless (number? k)
(let y (f v)
(when (is? y)
(set (get t k) y)))))))
(define-global keep (f x)
(map (fn (v) (when (yes (f v)) v)) x))
(define-global keys? (t)
(each (k v) t
(unless (number? k)
(return true)))
false)
(define-global empty? (t)
(each x t
(return false))
true)
(define-global stash (args)
(when (keys? args)
(let p ()
(each (k v) args
(unless (number? k)
(set (get p k) v)))
(set (get p '_stash) true)
(add args p)))
args)
(define-global unstash (args)
(if (none? args) ()
(let l (last args)
(if (and (obj? l) (get l '_stash))
(with args1 (almost args)
(each (k v) l
(unless (= k '_stash)
(set (get args1 k) v))))
args))))
(define-global destash! (l args1)
(if (and (obj? l) (get l '_stash))
(each (k v) l
(unless (= k '_stash)
(set (get args1 k) v)))
l))
(define-global search (s pattern start)
(target
js: (let i ((get s 'indexOf) pattern start)
(if (>= i 0) i))
lua: (let (start (if start (+ start 1))
i ((get string 'find) s pattern start true))
(and i (- i 1)))))
(define-global split (s sep)
(if (or (= s "") (= sep "")) ()
(with l ()
(let n (# sep)
(while true
(let i (search s sep)
(if (nil? i) (break)
(do (add l (clip s 0 i))
(set s (clip s (+ i n)))))))
(add l s)))))
(define-global cat xs
(or (reduce (fn (a b) (cat a b)) xs) ""))
(define-global + xs
(or (reduce (fn (a b) (+ a b)) xs) 0))
(define-global - xs
(or (reduce (fn (b a) (- a b)) (reverse xs)) 0))
(define-global * xs
(or (reduce (fn (a b) (* a b)) xs) 1))
(define-global / xs
(or (reduce (fn (b a) (/ a b)) (reverse xs)) 1))
(define-global % xs
(or (reduce (fn (b a) (% a b)) (reverse xs)) 0))
(define-global > (a b) (> a b))
(define-global < (a b) (< a b))
(define-global = (a b) (= a b))
(define-global >= (a b) (>= a b))
(define-global <= (a b) (<= a b))
(define-global number (s)
(target
js: (let n (parseFloat s)
(unless (isNaN n) n))
lua: (tonumber s)))
(define-global number-code? (n)
(and (> n 47) (< n 58)))
(define-global numeric? (s)
(let n (# s)
(for i n
(unless (number-code? (code s i))
(return false))))
true)
(target js: (define tostring (x) ((get x 'toString))))
(define-global escape (s)
(let s1 "\""
(for i (# s)
(let (c (char s i)
c1 (if (= c "\n") "\\n"
(= c "\"") "\\\""
(= c "\\") "\\\\"
c))
(cat! s1 c1)))
(cat s1 "\"")))
(define-global str (x stack)
(if (nil? x) "nil"
(nan? x) "nan"
(= x inf) "inf"
(= x -inf) "-inf"
(boolean? x) (if x "true" "false")
(string? x) (escape x)
(atom? x) (tostring x)
(function? x) "function"
(and stack (in? x stack)) "circular"
(target js: false lua: (not (= (type x) 'table)))
(escape (tostring x))
(let (s "(" sp ""
xs () ks ()
l (or stack ()))
(add l x)
(each (k v) x
(if (number? k)
(set (get xs k) (str v l))
(do (add ks (cat k ":"))
(add ks (str v l)))))
(drop l)
(each v (join xs ks)
(cat! s sp v)
(set sp " "))
(cat s ")"))))
(target lua:
(define values (or unpack (get table 'unpack))))
(define-global apply (f args)
(let args (stash args)
(target js: ((get f 'apply) f args)
lua: (f (values args)))))
(define-global call (f) (f))
(define-global toplevel? ()
(one? environment))
(define-global setenv (k rest: keys)
(when (string? k)
(let (frame (if (get keys 'toplevel)
(hd environment)
(last environment))
entry (or (get frame k) (obj)))
(each (k v) keys
(set (get entry k) v))
(set (get frame k) entry))))
(target js:
(define-global print (x)
((get console 'log) x)))
(define math (target js: Math lua: math))
(define-global abs (get math 'abs))
(define-global acos (get math 'acos))
(define-global asin (get math 'asin))
(define-global atan (get math 'atan))
(define-global atan2 (get math 'atan2))
(define-global ceil (get math 'ceil))
(define-global cos (get math 'cos))
(define-global floor (get math 'floor))
(define-global log (get math 'log))
(define-global log10 (get math 'log10))
(define-global max (get math 'max))
(define-global min (get math 'min))
(define-global pow (get math 'pow))
(define-global random (get math 'random))
(define-global sin (get math 'sin))
(define-global sinh (get math 'sinh))
(define-global sqrt (get math 'sqrt))
(define-global tan (get math 'tan))
(define-global tanh (get math 'tanh))
(define-global trunc (get math 'floor))
]]
prn(comp(runtime))
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment