diff --git a/fennel.lua b/fennel.lua
index ec5cef1..6663866 100644
--- a/fennel.lua
+++ b/fennel.lua
@@ -30,20 +30,42 @@ local unpack = unpack or table.unpack
-- Main Types and support functions
--
+-- Map function f over sequential table t, removing values where f returns nil.
+-- Optionally takes a target table to insert the mapped values into.
+local function map(t, f, out)
+ out = out or {}
+ if type(f) ~= "function" then local s = f f = function(x) return x[s] end end
+ for _,x in ipairs(t) do
+ local v = f(x)
+ if v then table.insert(out, v) end
+ end
+ return out
+end
+
+-- Map function f over key/value table t, similar to above, but it can return a
+-- sequential table if f returns a single value or a k/v table if f returns two.
+-- Optionally takes a target table to insert the mapped values into.
+local function kvmap(t, f, out)
+ out = out or {}
+ if type(f) ~= "function" then local s = f f = function(x) return x[s] end end
+ for k,x in pairs(t) do
+ local korv, v = f(k, x)
+ if korv and not v then table.insert(out, korv) end
+ if korv and v then out[korv] = v end
+ end
+ return out
+end
+
local function deref(self) return self[1] end
-local SYMBOL_MT = { 'SYMBOL', __tostring = deref }
+local function listToString(self, tostring2)
+ return '(' .. table.concat(map(self, tostring2 or tostring), ' ', 1, #self) .. ')'
+end
+
+local SYMBOL_MT = { 'SYMBOL', __tostring = deref, __fennelview = deref }
local EXPR_MT = { 'EXPR', __tostring = deref }
local VARARG = setmetatable({ '...' }, { 'VARARG', __tostring = deref })
-local LIST_MT = { 'LIST',
- __tostring = function (self)
- local strs = {}
- for _, s in ipairs(self) do
- table.insert(strs, tostring(s))
- end
- return '(' .. table.concat(strs, ' ', 1, #self) .. ')'
- end
-}
+local LIST_MT = { 'LIST', __tostring = listToString, __fennelview = listToString }
local SEQUENCE_MT = { 'SEQUENCE' }
-- Load code with an environment in all recent Lua versions
@@ -58,23 +80,28 @@ local function loadCode(code, environment, filename)
end
end
--- Create a new list
+-- Create a new list. Lists are a compile-time construct in Fennel; they are
+-- represented as tables with a special marker metatable. They only come from
+-- the parser, and they represent code which comes from reading a paren form;
+-- they are specifically not cons cells.
local function list(...)
return setmetatable({...}, LIST_MT)
end
--- Create a new symbol
+-- Create a new symbol. Symbols are a compile-time construct in Fennel and are
+-- not exposed outside the compiler. Symbols have metadata describing what file,
+-- line, etc that they came from.
local function sym(str, scope, meta)
local s = {str, scope = scope}
- if meta then
- for k, v in pairs(meta) do
- if type(k) == 'string' then s[k] = v end
- end
+ for k, v in pairs(meta or {}) do
+ if type(k) == 'string' then s[k] = v end
end
return setmetatable(s, SYMBOL_MT)
end
--- Create a new sequence
+-- Create a new sequence. Sequences are tables that come from the parser when
+-- it encounters a form with square brackets. They are treated as regular tables
+-- except when certain macros need to look for binding forms, etc specifically.
local function sequence(...)
return setmetatable({...}, SEQUENCE_MT)
end
@@ -120,6 +147,13 @@ local function isSequence(x)
return type(x) == 'table' and getmetatable(x) == SEQUENCE_MT and x
end
+-- Returns a shallow copy of its table argument. Returns an empty table on nil.
+local function copy(from)
+ local to = {}
+ for k, v in pairs(from or {}) do to[k] = v end
+ return to
+end
+
--
-- Parser
--
@@ -196,6 +230,11 @@ local prefixes = { -- prefix chars substituted while reading
[35] = 'hashfn' -- #
}
+-- The resetRoot function needs to be called at every exit point of the compiler
+-- including when there's a parse error or compiler error. Introduce it up here
+-- so error functions have access to it, and set it when we have values below.
+local resetRoot = nil
+
-- Parse one value given a function that
-- returns sequential bytes. Will throw an error as soon
-- as possible without getting more bytes on bad input. Returns
@@ -228,6 +267,7 @@ local function parser(getbyte, filename)
return r
end
local function parseError(msg)
+ if resetRoot then resetRoot() end
return error(msg .. ' in ' .. (filename or 'unknown') .. ':' .. line, 0)
end
@@ -254,10 +294,7 @@ local function parser(getbyte, filename)
-- Throw nice error when we expect more characters
-- but reach end of stream.
local function badend()
- local accum = {}
- for _, item in ipairs(stack) do
- accum[#accum + 1] = item.closer
- end
+ local accum = map(stack, "closer")
parseError(('expected closing delimiter%s %s'):format(
#stack == 1 and "" or "s",
string.char(unpack(accum))))
@@ -317,7 +354,8 @@ local function parser(getbyte, filename)
end
val = {}
for i = 1, #last, 2 do
- if tostring(last[i]) == ":" and isSym(last[i + 1]) then
+ if(tostring(last[i]) == ":" and isSym(last[i + 1])
+ and isSym(last[i])) then
last[i] = tostring(last[i + 1])
end
val[last[i]] = last[i + 1]
@@ -376,7 +414,7 @@ local function parser(getbyte, filename)
if rawstr == 'true' then dispatch(true)
elseif rawstr == 'false' then dispatch(false)
elseif rawstr == '...' then dispatch(VARARG)
- elseif rawstr:match('^:.+$') then -- keyword style strings
+ elseif rawstr:match('^:.+$') then -- colon style strings
dispatch(rawstr:sub(2))
elseif rawstr:match("^~") and rawstr ~= "~=" then
-- for backwards-compatibility, special-case allowance of ~=
@@ -424,15 +462,25 @@ end
--
-- Top level compilation bindings.
-local rootChunk
-local rootScope
-local rootOptions
+local rootChunk, rootScope, rootOptions
--- Create a new Scope, optionally under a parent scope. Scopes are compile time constructs
--- that are responsible for keeping track of local variables, name mangling, and macros.
--- They are accessible to user code via the '*compiler' special form (may change). They
--- use metatables to implement nesting via inheritance.
+local function setResetRoot(oldChunk, oldScope, oldOptions)
+ local oldResetRoot = resetRoot -- this needs to nest!
+ resetRoot = function()
+ rootChunk, rootScope, rootOptions = oldChunk, oldScope, oldOptions
+ resetRoot = oldResetRoot
+ end
+end
+
+local GLOBAL_SCOPE
+
+-- Create a new Scope, optionally under a parent scope. Scopes are compile time
+-- constructs that are responsible for keeping track of local variables, name
+-- mangling, and macros. They are accessible to user code via the
+-- 'eval-compiler' special form (may change). They use metatables to implement
+-- nesting via metatables.
local function makeScope(parent)
+ if not parent then parent = GLOBAL_SCOPE end
return {
unmanglings = setmetatable({}, {
__index = parent and parent.unmanglings
@@ -449,6 +497,9 @@ local function makeScope(parent)
includes = setmetatable({}, {
__index = parent and parent.includes
}),
+ refedglobals = setmetatable({}, {
+ __index = parent and parent.refedglobals
+ }),
autogensyms = {},
parent = parent,
vararg = parent and parent.vararg,
@@ -462,6 +513,7 @@ end
local function assertCompile(condition, msg, ast)
-- if we use regular `assert' we can't provide the `level' argument of zero
if not condition then
+ if resetRoot then resetRoot() end
error(string.format("Compile error in '%s' %s:%s: %s",
isSym(ast[1]) and ast[1][1] or ast[1] or '()',
ast.filename or "unknown", ast.line or '?', msg), 0)
@@ -469,7 +521,7 @@ local function assertCompile(condition, msg, ast)
return condition
end
-local GLOBAL_SCOPE = makeScope()
+GLOBAL_SCOPE = makeScope()
GLOBAL_SCOPE.vararg = true
local SPECIALS = GLOBAL_SCOPE.specials
local COMPILER_SCOPE = makeScope(GLOBAL_SCOPE)
@@ -479,9 +531,8 @@ local luaKeywords = {
'if', 'in', 'local', 'nil', 'not', 'or', 'repeat', 'return', 'then', 'true',
'until', 'while'
}
-for i, v in ipairs(luaKeywords) do
- luaKeywords[v] = i
-end
+
+for i, v in ipairs(luaKeywords) do luaKeywords[v] = i end
local function isValidLuaIdentifier(str)
return (str:match('^[%a_][%w_]*$') and not luaKeywords[str])
@@ -553,21 +604,31 @@ end
local function globalUnmangling(identifier)
local rest = identifier:match('^__fnl_global__(.*)$')
if rest then
- return rest:gsub('_[%da-f][%da-f]', function (code)
+ local r = rest:gsub('_[%da-f][%da-f]', function (code)
return string.char(tonumber(code:sub(2), 16))
end)
+ return r -- don't return multiple values
else
return identifier
end
end
+-- If there's a provided list of allowed globals, don't let references thru that
+-- aren't on the list. This list is set at the compiler entry points of compile
+-- and compileStream.
+local allowedGlobals
+
+local function globalAllowed(name)
+ if not allowedGlobals then return true end
+ for _, g in ipairs(allowedGlobals) do
+ if g == name then return true end
+ end
+end
+
-- Creates a symbol from a string by mangling it.
-- ensures that the generated symbol is unique
-- if the input string is unique in the scope.
-local function localMangling(str, scope, ast)
- if scope.manglings[str] then
- return scope.manglings[str]
- end
+local function localMangling(str, scope, ast, tempManglings)
local append = 0
local mangling = str
assertCompile(not isMultiSym(str), 'did not expect multi symbol ' .. str, ast)
@@ -581,16 +642,30 @@ local function localMangling(str, scope, ast)
return ('_%02x'):format(c:byte())
end)
+ -- Prevent name collisions with existing symbols
local raw = mangling
while scope.unmanglings[mangling] do
mangling = raw .. append
append = append + 1
end
+
scope.unmanglings[mangling] = str
- scope.manglings[str] = mangling
+ local manglings = tempManglings or scope.manglings
+ manglings[str] = mangling
return mangling
end
+-- Calling this function will mean that further
+-- compilation in scope will use these new manglings
+-- instead of the current manglings.
+local function applyManglings(scope, newManglings, ast)
+ for raw, mangled in pairs(newManglings) do
+ assertCompile(not scope.refedglobals[mangled],
+ "use of global " .. raw .. " is aliased by a local", ast)
+ scope.manglings[raw] = mangled
+ end
+end
+
-- Combine parts of a symbol
local function combineParts(parts, scope)
local ret = scope.manglings[parts[1]] or globalMangling(parts[1])
@@ -637,32 +712,20 @@ local function checkBindingValid(symbol, scope, ast)
assertCompile(not scope.specials[name],
("symbol %s may be overshadowed by a special form or macro"):format(name), ast)
assertCompile(not isQuoted(symbol), 'macro tried to bind ' .. name ..
- ' without gensym; try ' .. name .. '# instead', ast)
+ " without gensym; try ' .. name .. '# instead", ast)
end
-- Declare a local symbol
-local function declareLocal(symbol, meta, scope, ast)
+local function declareLocal(symbol, meta, scope, ast, tempManglings)
checkBindingValid(symbol, scope, ast)
local name = symbol[1]
assertCompile(not isMultiSym(name), "did not expect mutltisym", ast)
- local mangling = localMangling(name, scope, ast)
+ local mangling = localMangling(name, scope, ast, tempManglings)
scope.symmeta[name] = meta
return mangling
end
--- If there's a provided list of allowed globals, don't let references
--- thru that aren't on the list. This list is set at the compiler
--- entry points of compile and compileStream.
-local allowedGlobals
-
-local function globalAllowed(name)
- if not allowedGlobals then return true end
- for _, g in ipairs(allowedGlobals) do
- if g == name then return true end
- end
-end
-
-- Convert symbol to Lua code. Will only work for local symbols
-- if they have already been declared via declareLocal
local function symbolToExpression(symbol, scope, isReference)
@@ -685,6 +748,9 @@ local function symbolToExpression(symbol, scope, isReference)
-- then we need to check for allowed globals
assertCompile(not isReference or isLocal or globalAllowed(parts[1]),
'unknown global in strict mode: ' .. parts[1], symbol)
+ if not isLocal then
+ rootScope.refedglobals[parts[1]] = true
+ end
return expr(combineParts(parts, scope), etype)
end
@@ -709,10 +775,7 @@ local function peephole(chunk)
return peephole(chunk[2])
end
-- Recurse
- for i, v in ipairs(chunk) do
- chunk[i] = peephole(v)
- end
- return chunk
+ return map(chunk, peephole)
end
-- correlate line numbers in input with line numbers in output
@@ -753,15 +816,13 @@ local function flattenChunk(sm, chunk, tab, depth)
if sm then sm[#sm + 1] = info and info.line or -1 end
return code
else
- local parts = {}
- for i = 1, #chunk do
- -- Ignore empty chunks
- if chunk[i].leaf or #(chunk[i]) > 0 then
- local sub = flattenChunk(sm, chunk[i], tab, depth + 1)
+ local parts = map(chunk, function(c)
+ if c.leaf or #c > 0 then -- Ignore empty chunks
+ local sub = flattenChunk(sm, c, tab, depth + 1)
if depth > 0 then sub = tab .. sub:gsub('\n', '\n' .. tab) end
- table.insert(parts, sub)
+ return sub
end
- end
+ end)
return table.concat(parts, '\n')
end
end
@@ -851,16 +912,12 @@ end
local function docSpecial(name, arglist, docstring)
metadata[SPECIALS[name]] =
- { ['fnl/docstring'] = docstring, ['fnl/arglist'] = arglist }
+ { ["fnl/docstring"] = docstring, ["fnl/arglist"] = arglist }
end
-- Convert expressions to Lua string
local function exprs1(exprs)
- local t = {}
- for _, e in ipairs(exprs) do
- t[#t + 1] = e[1]
- end
- return table.concat(t, ', ')
+ return table.concat(map(exprs, 1), ', ')
end
-- Compile side effects for a chunk
@@ -937,6 +994,17 @@ end
-- 'tail' - boolean indicating tail position if set. If set, form will generate a return
-- instruction.
-- 'nval' - The number of values to compile to if it is known to be a fixed value.
+
+-- In Lua, an expression can evaluate to 0 or more values via multiple
+-- returns. In many cases, Lua will drop extra values and convert a 0 value
+-- expression to nil. In other cases, Lua will use all of the values in an
+-- expression, such as in the last argument of a function call. Nval is an
+-- option passed to compile1 to say that the resulting expression should have
+-- at least n values. It lets us generate better code, because if we know we
+-- are only going to use 1 or 2 values from an expression, we can create 1 or 2
+-- locals to store intermediate results rather than turn the expression into a
+-- closure that is called immediately, which we have to do if we don't know.
+
local function compile1(ast, scope, parent, opts)
opts = opts or {}
local exprs = {}
@@ -1038,24 +1106,23 @@ local function compile1(ast, scope, parent, opts)
local nval = i ~= #ast and 1
buffer[#buffer + 1] = exprs1(compile1(ast[i], scope, parent, {nval = nval}))
end
- local keys = {}
- for k, _ in pairs(ast) do -- Write other keys.
+ local function writeOtherValues(k)
if type(k) ~= 'number' or math.floor(k) ~= k or k < 1 or k > #ast then
- local kstr
if type(k) == 'string' and isValidLuaIdentifier(k) then
- kstr = k
+ return {k, k}
else
- kstr = '[' .. tostring(compile1(k, scope, parent, {nval = 1})[1]) .. ']'
+ local kstr = '[' .. tostring(compile1(k, scope, parent,
+ {nval = 1})[1]) .. ']'
+ return { kstr, k }
end
- table.insert(keys, { kstr, k })
end
end
+ local keys = kvmap(ast, writeOtherValues)
table.sort(keys, function (a, b) return a[1] < b[1] end)
- for _, k in ipairs(keys) do
- local v = ast[k[2]]
- buffer[#buffer + 1] = ('%s = %s'):format(
- k[1], tostring(compile1(v, scope, parent, {nval = 1})[1]))
- end
+ map(keys, function(k)
+ local v = tostring(compile1(ast[k[2]], scope, parent, {nval = 1})[1])
+ return ('%s = %s'):format(k[1], v) end,
+ buffer)
local tbl = '{' .. table.concat(buffer, ', ') ..'}'
exprs = handleCompileOpts({expr(tbl, 'expression')}, parent, opts, ast)
else
@@ -1096,13 +1163,15 @@ local function destructure(to, from, ast, scope, parent, opts)
local forceset = opts.forceset
local setter = declaration and "local %s = %s" or "%s = %s"
+ local newManglings = {}
+
-- Get Lua source for symbol, and check for errors
local function getname(symbol, up1)
local raw = symbol[1]
assertCompile(not (nomulti and isMultiSym(raw)),
'did not expect multisym', up1)
if declaration then
- return declareLocal(symbol, {var = isvar}, scope, symbol)
+ return declareLocal(symbol, {var = isvar}, scope, symbol, newManglings)
else
local parts = isMultiSym(raw) or {raw}
local meta = scope.symmeta[parts[1]]
@@ -1114,6 +1183,16 @@ local function destructure(to, from, ast, scope, parent, opts)
assertCompile(not (meta and not meta.var),
'expected local var', up1)
end
+ if forceglobal then
+ assertCompile(not scope.symmeta[scope.unmanglings[raw]],
+ "global " .. raw .. " conflicts with local", ast)
+ scope.manglings[raw] = globalMangling(raw)
+ scope.unmanglings[globalMangling(raw)] = raw
+ if allowedGlobals then
+ table.insert(allowedGlobals, raw)
+ end
+ end
+
return symbolToExpression(symbol, scope)[1]
end
end
@@ -1121,10 +1200,8 @@ local function destructure(to, from, ast, scope, parent, opts)
-- Compile the outer most form. We can generate better Lua in this case.
local function compileTopTarget(lvalues)
-- Calculate initial rvalue
- local inits = {}
- for _, x in ipairs(lvalues) do
- table.insert(inits, scope.manglings[x] and x or 'nil')
- end
+ local inits = map(lvalues, function(x)
+ return scope.manglings[x] and x or 'nil' end)
local init = table.concat(inits, ', ')
local lvalue = table.concat(lvalues, ', ')
@@ -1198,7 +1275,9 @@ local function destructure(to, from, ast, scope, parent, opts)
if top then return {returned = true} end
end
- return destructure1(to, nil, ast, true)
+ local ret = destructure1(to, nil, ast, true)
+ applyManglings(scope, newManglings, ast)
+ return ret
end
-- Unlike most expressions and specials, 'values' resolves with multiple
@@ -1234,6 +1313,15 @@ local function compileDo(ast, scope, parent, start)
end
end
+-- Raises compile error if unused locals are found and we're checking for them.
+local function checkUnused(scope, ast)
+ if not rootOptions.checkUnusedLocals then return end
+ for symName in pairs(scope.symmeta) do
+ assertCompile(scope.symmeta[symName].used or symName:find("^_"),
+ ("unused local %s"):format(symName), ast)
+ end
+end
+
-- Implements a do statement, starting at the 'start' element. By default, start is 2.
local function doImpl(ast, scope, parent, opts, start, chunk, subScope)
start = start or 2
@@ -1293,20 +1381,21 @@ local function doImpl(ast, scope, parent, opts, start, chunk, subScope)
end
emit(parent, chunk, ast)
emit(parent, 'end', ast)
+ checkUnused(subScope, ast)
return retexprs
end
-SPECIALS['do'] = doImpl
-docSpecial('do', {'...'}, 'Evaluate multiple forms; return last value.')
+SPECIALS["do"] = doImpl
+docSpecial("do", {"..."}, "Evaluate multiple forms; return last value.")
-SPECIALS['values'] = values
-docSpecial('values', {'...'},
- 'Return multiple values from a function. Must be in tail position.')
+SPECIALS["values"] = values
+docSpecial("values", {"..."},
+ "Return multiple values from a function. Must be in tail position.")
-- The fn special declares a function. Syntax is similar to other lisps;
-- (fn optional-name [arg ...] (body))
-- Further decoration such as docstrings, meta info, and multibody functions a possibility.
-SPECIALS['fn'] = function(ast, scope, parent)
+SPECIALS["fn"] = function(ast, scope, parent)
local fScope = makeScope(scope)
local fChunk = {}
local index = 2
@@ -1327,25 +1416,26 @@ SPECIALS['fn'] = function(ast, scope, parent)
fnName = gensym(scope)
end
local argList = assertCompile(isTable(ast[index]),
- 'expected vector arg list [a b ...]', ast)
- local argNameList = {}
- for i = 1, #argList do
- if isVarg(argList[i]) then
- assertCompile(i == #argList, "expected vararg in last parameter position", ast)
- argNameList[i] = '...'
+ "expected vector arg list [a b ...]", ast)
+ local function getArgName(i, name)
+ if isVarg(name) then
+ assertCompile(i == #argList, "expected vararg as last parameter", ast)
fScope.vararg = true
- elseif(isSym(argList[i]) and argList[i][1] ~= "nil"
- and not isMultiSym(argList[i][1])) then
- argNameList[i] = declareLocal(argList[i], {}, fScope, ast)
- elseif isTable(argList[i]) then
+ return "..."
+ elseif(isSym(name) and deref(name) ~= "nil"
+ and not isMultiSym(deref(name))) then
+ return declareLocal(name, {}, fScope, ast)
+ elseif isTable(name) then
local raw = sym(gensym(scope))
- argNameList[i] = declareLocal(raw, {}, fScope, ast)
- destructure(argList[i], raw, ast, fScope, fChunk,
+ local declared = declareLocal(raw, {}, fScope, ast)
+ destructure(name, raw, ast, fScope, fChunk,
{ declaration = true, nomulti = true })
+ return declared
else
- assertCompile(false, 'expected symbol for function parameter', ast)
+ assertCompile(false, "expected symbol for function parameter", ast)
end
end
+ local argNameList = kvmap(argList, getArgName)
if type(ast[index + 1]) == 'string' and index + 1 < #ast then
index = index + 1
docstring = ast[index]
@@ -1368,11 +1458,10 @@ SPECIALS['fn'] = function(ast, scope, parent)
emit(parent, 'end', ast)
if rootOptions.useMetadata then
- local args = {}
- for i, v in ipairs(argList) do
+ local args = map(argList, function(v)
-- TODO: show destructured args properly instead of replacing
- args[i] = isTable(v) and '"#
"' or string.format('"%s"', tostring(v))
- end
+ return isTable(v) and '"#"' or string.format('"%s"', tostring(v))
+ end)
local metaFields = {
'"fnl/arglist"', '{' .. table.concat(args, ', ') .. '}',
@@ -1388,13 +1477,14 @@ SPECIALS['fn'] = function(ast, scope, parent)
fnName, table.concat(metaFields, ', ')))
end
+ checkUnused(fScope, ast)
return expr(fnName, 'sym')
end
-docSpecial('fn', {'name?', 'args', 'docstring?', '...'},
- 'Function syntax. May optionally include a name and docstring.'
- ..'\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.')
+docSpecial("fn", {"name?", "args", "docstring?", "..."},
+ "Function syntax. May optionally include a name and docstring."
+ .."\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.")
-- (lua "print('hello!')") -> prints hello, evaluates to nil
-- (lua "print 'hello!'" "10") -> prints hello, evaluates to the number 10
@@ -1427,11 +1517,11 @@ SPECIALS['doc'] = function(ast, scope, parent)
:format(rootOptions.moduleName or "fennel", value, tostring(ast[2]))
end
end
-docSpecial('doc', {'x'},
- 'Print the docstring and arglist for a function, macro, or special form.')
+docSpecial("doc", {"x"},
+ "Print the docstring and arglist for a function, macro, or special form.")
-- Table lookup
-SPECIALS['.'] = function(ast, scope, parent)
+SPECIALS["."] = function(ast, scope, parent)
local len = #ast
assertCompile(len > 1, "expected table argument", ast)
local lhs = compile1(ast[2], scope, parent, {nval = 1})
@@ -1456,51 +1546,45 @@ SPECIALS['.'] = function(ast, scope, parent)
end
end
end
-docSpecial('.', {'tbl', 'key1', '...'},
- 'Look up key1 in tbl table. If more args are provided, do a nested lookup.')
+docSpecial(".", {"tbl", "key1", "..."},
+ "Look up key1 in tbl table. If more args are provided, do a nested lookup.")
-SPECIALS['global'] = function(ast, scope, parent)
+SPECIALS["global"] = function(ast, scope, parent)
assertCompile(#ast == 3, "expected name and value", ast)
- -- globals tracking doesn't currently work with multi-values/destructuring
- if allowedGlobals and isSym(ast[2]) then
- for _,global in ipairs(isList(ast[2]) and ast[2] or {ast[2]}) do
- table.insert(allowedGlobals, deref(global))
- end
- end
destructure(ast[2], ast[3], ast, scope, parent, {
nomulti = true,
forceglobal = true
})
end
-docSpecial('global', {'name', 'val'}, 'Set name as a global with val.')
+docSpecial("global", {"name", "val"}, "Set name as a global with val.")
-SPECIALS['set'] = function(ast, scope, parent)
+SPECIALS["set"] = function(ast, scope, parent)
assertCompile(#ast == 3, "expected name and value", ast)
destructure(ast[2], ast[3], ast, scope, parent, {
noundef = true
})
end
-docSpecial('set', {'name', 'val'},
- 'Set a local variable to a new value. Only works on locals using var.')
+docSpecial("set", {"name", "val"},
+ "Set a local variable to a new value. Only works on locals using var.")
-SPECIALS['set-forcibly!'] = function(ast, scope, parent)
+SPECIALS["set-forcibly!"] = function(ast, scope, parent)
assertCompile(#ast == 3, "expected name and value", ast)
destructure(ast[2], ast[3], ast, scope, parent, {
forceset = true
})
end
-SPECIALS['local'] = function(ast, scope, parent)
+SPECIALS["local"] = function(ast, scope, parent)
assertCompile(#ast == 3, "expected name and value", ast)
destructure(ast[2], ast[3], ast, scope, parent, {
declaration = true,
nomulti = true
})
end
-docSpecial('local', {'name', 'val'},
- 'Introduce new top-level immutable local.')
+docSpecial("local", {"name", "val"},
+ "Introduce new top-level immutable local.")
-SPECIALS['var'] = function(ast, scope, parent)
+SPECIALS["var"] = function(ast, scope, parent)
assertCompile(#ast == 3, "expected name and value", ast)
destructure(ast[2], ast[3], ast, scope, parent, {
declaration = true,
@@ -1508,16 +1592,16 @@ SPECIALS['var'] = function(ast, scope, parent)
isvar = true
})
end
-docSpecial('var', {'name', 'val'},
- 'Introduce new mutable local.')
+docSpecial("var", {"name", "val"},
+ "Introduce new mutable local.")
-SPECIALS['let'] = function(ast, scope, parent, opts)
+SPECIALS["let"] = function(ast, scope, parent, opts)
local bindings = ast[2]
assertCompile(isList(bindings) or isTable(bindings),
- 'expected table for destructuring', ast)
+ "expected table for destructuring", ast)
assertCompile(#bindings % 2 == 0,
- 'expected even number of name/value bindings', ast)
- assertCompile(#ast >= 3, 'missing body expression', ast)
+ "expected even number of name/value bindings", ast)
+ assertCompile(#ast >= 3, "missing body expression", ast)
local subScope = makeScope(scope)
local subChunk = {}
for i = 1, #bindings, 2 do
@@ -1528,12 +1612,12 @@ SPECIALS['let'] = function(ast, scope, parent, opts)
end
return doImpl(ast, scope, parent, opts, 3, subChunk, subScope)
end
-docSpecial('let', {'[name1 val1 ... nameN valN]', '...'},
- 'Introduces a new scope in which a given set of local bindings are used.')
+docSpecial("let", {"[name1 val1 ... nameN valN]", "..."},
+ "Introduces a new scope in which a given set of local bindings are used.")
-- For setting items in a table
-SPECIALS['tset'] = function(ast, scope, parent)
- assertCompile(#ast > 3, ('tset form needs table, key, and value'), ast)
+SPECIALS["tset"] = function(ast, scope, parent)
+ assertCompile(#ast > 3, ("tset form needs table, key, and value"), ast)
local root = compile1(ast[2], scope, parent, {nval = 1})[1]
local keys = {}
for i = 3, #ast - 1 do
@@ -1543,17 +1627,18 @@ SPECIALS['tset'] = function(ast, scope, parent)
local value = compile1(ast[#ast], scope, parent, {nval = 1})[1]
local rootstr = tostring(root)
-- Prefix 'do end ' so parens are not ambiguous (grouping or function call?)
- local fmtstr = (rootstr:match('^{')) and 'do end (%s)[%s] = %s' or '%s[%s] = %s'
+ local fmtstr = (rootstr:match("^{")) and "do end (%s)[%s] = %s" or "%s[%s] = %s"
emit(parent, fmtstr:format(tostring(root),
table.concat(keys, ']['),
tostring(value)), ast)
end
-docSpecial('tset', {'tbl', 'key1', 'val1', '...', 'keyN', 'valN'},
- 'Set the fields of a table to new values. Takes 1 or more key/value pairs.')
+docSpecial("tset", {"tbl", "key1", "...", "keyN", "val"},
+ "Set the value of a table field. Can take additional keys to set"
+ .. "nested values,\nbut all parents must contain an existing table.")
-- The if special form behaves like the cond form in
-- many languages
-SPECIALS['if'] = function(ast, scope, parent, opts)
+SPECIALS["if"] = function(ast, scope, parent, opts)
local doScope = makeScope(scope)
local branches = {}
local elseBranch = nil
@@ -1635,6 +1720,10 @@ SPECIALS['if'] = function(ast, scope, parent, opts)
if hasElse then
emit(lastBuffer, 'else', ast)
emit(lastBuffer, elseBranch.chunk, ast)
+ -- TODO: Consolidate use of condLine ~= "else" with hasElse
+ elseif(innerTarget and condLine ~= 'else') then
+ emit(lastBuffer, 'else', ast)
+ emit(lastBuffer, ("%s = nil"):format(innerTarget), ast)
end
emit(lastBuffer, 'end', ast)
elseif not branches[i + 1].nested then
@@ -1666,60 +1755,63 @@ SPECIALS['if'] = function(ast, scope, parent, opts)
return targetExprs
end
end
-docSpecial('if', {'cond1', 'body1', '...', 'condN', 'bodyN'},
- 'Conditional form.\n' ..
- 'Takes any number of condition/body pairs and evaluates the first body where'
- .. '\nthe condition evaluates to truthy. Similar to cond in other lisps.')
+docSpecial("if", {"cond1", "body1", "...", "condN", "bodyN"},
+ "Conditional form.\n" ..
+ "Takes any number of condition/body pairs and evaluates the first body where"
+ .. "\nthe condition evaluates to truthy. Similar to cond in other lisps.")
-- (each [k v (pairs t)] body...) => []
-SPECIALS['each'] = function(ast, scope, parent)
- local binding = assertCompile(isTable(ast[2]), 'expected binding table', ast)
+SPECIALS["each"] = function(ast, scope, parent)
+ local binding = assertCompile(isTable(ast[2]), "expected binding table", ast)
local iter = table.remove(binding, #binding) -- last item is iterator call
- local bindVars = {}
local destructures = {}
- for _, v in ipairs(binding) do
- assertCompile(isSym(v) or isTable(v),
- 'expected iterator symbol or table', ast)
- if(isSym(v)) then
- table.insert(bindVars, declareLocal(v, {}, scope, ast))
+ local newManglings = {}
+ local function destructureBinding(v)
+ assertCompile(isSym(v) or isTable(v), "expected iterator symbol or table", ast)
+ if isSym(v) then
+ return declareLocal(v, {}, scope, ast, newManglings)
else
local raw = sym(gensym(scope))
destructures[raw] = v
- table.insert(bindVars, declareLocal(raw, {}, scope, ast))
+ return declareLocal(raw, {}, scope, ast)
end
end
- emit(parent, ('for %s in %s do'):format(
- table.concat(bindVars, ', '),
- tostring(compile1(iter, scope, parent, {nval = 1})[1])), ast)
+ local bindVars = map(binding, destructureBinding)
+ local vals = compile1(iter, scope, parent)
+ local valNames = map(vals, tostring)
+
+ emit(parent, ('for %s in %s do'):format(table.concat(bindVars, ', '),
+ table.concat(valNames, ", ")), ast)
local chunk = {}
for raw, args in pairs(destructures) do
destructure(args, raw, ast, scope, chunk,
{ declaration = true, nomulti = true })
end
+ applyManglings(scope, newManglings, ast)
compileDo(ast, scope, chunk, 3)
emit(parent, chunk, ast)
emit(parent, 'end', ast)
end
-docSpecial('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.')
+docSpecial("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.")
-- (while condition body...) => []
-SPECIALS['while'] = function(ast, scope, parent)
+SPECIALS["while"] = function(ast, scope, parent)
local len1 = #parent
local condition = compile1(ast[2], scope, parent, {nval = 1})[1]
local len2 = #parent
local subChunk = {}
if len1 ~= len2 then
-- Compound condition
- emit(parent, 'while true do', ast)
-- Move new compilation to subchunk
for i = len1 + 1, len2 do
subChunk[#subChunk + 1] = parent[i]
parent[i] = nil
end
- emit(parent, ('if %s then break end'):format(condition[1]), ast)
+ emit(parent, 'while true do', ast)
+ emit(subChunk, ('if not %s then break end'):format(condition[1]), ast)
else
-- Simple condition
emit(parent, 'while ' .. tostring(condition) .. ' do', ast)
@@ -1728,13 +1820,13 @@ SPECIALS['while'] = function(ast, scope, parent)
emit(parent, subChunk, ast)
emit(parent, 'end', ast)
end
-docSpecial('while', {'condition', '...'},
- 'The classic while loop. Evaluates body until a condition is non-truthy.')
+docSpecial("while", {"condition", "..."},
+ "The classic while loop. Evaluates body until a condition is non-truthy.")
-SPECIALS['for'] = function(ast, scope, parent)
- local ranges = assertCompile(isTable(ast[2]), 'expected binding table', ast)
+SPECIALS["for"] = function(ast, scope, parent)
+ local ranges = assertCompile(isTable(ast[2]), "expected binding table", ast)
local bindingSym = assertCompile(isSym(table.remove(ast[2], 1)),
- 'expected iterator symbol', ast)
+ "expected iterator symbol", ast)
local rangeArgs = {}
for i = 1, math.min(#ranges, 3) do
rangeArgs[i] = tostring(compile1(ranges[i], scope, parent, {nval = 1})[1])
@@ -1747,11 +1839,11 @@ SPECIALS['for'] = function(ast, scope, parent)
emit(parent, chunk, ast)
emit(parent, 'end', ast)
end
-docSpecial('for', {'[index start stop step?]', '...'}, 'Numeric loop construct.' ..
- '\nEvaluates body once for each value between start and stop (inclusive).')
+docSpecial("for", {"[index start stop step?]", "..."}, "Numeric loop construct." ..
+ "\nEvaluates body once for each value between start and stop (inclusive).")
-SPECIALS[':'] = function(ast, scope, parent)
- assertCompile(#ast >= 3, 'expected at least 3 arguments', ast)
+SPECIALS[":"] = function(ast, scope, parent)
+ assertCompile(#ast >= 3, "expected at least 3 arguments", ast)
-- Compile object
local objectexpr = compile1(ast[2], scope, parent, {nval = 1})[1]
-- Compile method selector
@@ -1770,9 +1862,7 @@ SPECIALS[':'] = function(ast, scope, parent)
local subexprs = compile1(ast[i], scope, parent, {
nval = i ~= #ast and 1 or nil
})
- for j = 1, #subexprs do
- args[#args + 1] = tostring(subexprs[j])
- end
+ map(subexprs, tostring, args)
end
local fstring
if not methodident then
@@ -1791,21 +1881,21 @@ SPECIALS[':'] = function(ast, scope, parent)
methodstring,
table.concat(args, ', ')), 'statement')
end
-docSpecial(':', {'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.')
+docSpecial(":", {"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.")
-SPECIALS['comment'] = function(ast, _, parent)
+SPECIALS["comment"] = function(ast, _, parent)
local els = {}
for i = 2, #ast do
els[#els + 1] = tostring(ast[i]):gsub('\n', ' ')
end
emit(parent, ' -- ' .. table.concat(els, ' '), ast)
end
-docSpecial('comment', {'...'}, 'Comment which will be emitted in Lua output.')
+docSpecial("comment", {"..."}, "Comment which will be emitted in Lua output.")
-SPECIALS['hashfn'] = function(ast, scope, parent)
+SPECIALS["hashfn"] = function(ast, scope, parent)
assertCompile(#ast == 2, "expected one argument", ast)
local fScope = makeScope(scope)
local fChunk = {}
@@ -1826,7 +1916,7 @@ SPECIALS['hashfn'] = function(ast, scope, parent)
emit(parent, 'end', ast)
return expr(name, 'sym')
end
-docSpecial('hashfn', {'...'}, 'Function literal shorthand; args are $1, $2, etc.')
+docSpecial("hashfn", {"..."}, "Function literal shorthand; args are $1, $2, etc.")
local function defineArithmeticSpecial(name, zeroArity, unaryPrefix)
local paddedOp = ' ' .. name .. ' '
@@ -1841,9 +1931,7 @@ local function defineArithmeticSpecial(name, zeroArity, unaryPrefix)
local subexprs = compile1(ast[i], scope, parent, {
nval = (i == 1 and 1 or nil)
})
- for j = 1, #subexprs do
- operands[#operands + 1] = tostring(subexprs[j])
- end
+ map(subexprs, tostring, operands)
end
if #operands == 1 then
if unaryPrefix then
@@ -1856,8 +1944,8 @@ local function defineArithmeticSpecial(name, zeroArity, unaryPrefix)
end
end
end
- docSpecial(name, {'a', 'b', '...'},
- 'Arithmetic operator; works the same as Lua but accepts more arguments.')
+ docSpecial(name, {"a", "b", "..."},
+ "Arithmetic operator; works the same as Lua but accepts more arguments.")
end
defineArithmeticSpecial('+', '0')
@@ -1871,18 +1959,18 @@ defineArithmeticSpecial('//', nil, '1')
defineArithmeticSpecial('or', 'false')
defineArithmeticSpecial('and', 'true')
-docSpecial('and', {'a', 'b', '...'},
- 'Boolean operator; works the same as Lua but accepts more arguments.')
-docSpecial('or', {'a', 'b', '...'},
- 'Boolean operator; works the same as Lua but accepts more arguments.')
-docSpecial('..', {'a', 'b', '...'},
- 'String concatenation operator; works the same as Lua but accepts more arguments.')
+docSpecial("and", {"a", "b", "..."},
+ "Boolean operator; works the same as Lua but accepts more arguments.")
+docSpecial("or", {"a", "b", "..."},
+ "Boolean operator; works the same as Lua but accepts more arguments.")
+docSpecial("..", {"a", "b", "..."},
+ "String concatenation operator; works the same as Lua but accepts more arguments.")
local function defineComparatorSpecial(name, realop, chainOp)
local op = realop or name
SPECIALS[name] = function(ast, scope, parent)
local len = #ast
- assertCompile(len > 2, 'expected at least two arguments', ast)
+ assertCompile(len > 2, "expected at least two arguments", ast)
local lhs = compile1(ast[2], scope, parent, {nval = 1})[1]
local lastval = compile1(ast[3], scope, parent, {nval = 1})[1]
-- avoid double-eval by introducing locals for possible side-effects
@@ -1901,8 +1989,8 @@ local function defineComparatorSpecial(name, realop, chainOp)
end
return out
end
- docSpecial(name, {name, 'a', 'b', '...'},
- 'Comparison operator; works the same as Lua but accepts more arguments.')
+ docSpecial(name, {"a", "b", "..."},
+ "Comparison operator; works the same as Lua but accepts more arguments.")
end
defineComparatorSpecial('>')
@@ -1921,12 +2009,12 @@ local function defineUnarySpecial(op, realop)
end
end
-defineUnarySpecial('not', 'not ')
-docSpecial('not', {'x'}, 'Boolean operator; works the same as Lua.')
+defineUnarySpecial("not", "not ")
+docSpecial("not", {"x"}, "Logical operator; works the same as Lua.")
-defineUnarySpecial('length', '#')
-docSpecial('length', {'x'}, 'Returns the length of a table or string.')
-SPECIALS['#'] = SPECIALS['length']
+defineUnarySpecial("length", "#")
+docSpecial("length", {"x"}, "Returns the length of a table or string.")
+SPECIALS["#"] = SPECIALS["length"]
-- Save current macro scope
local macroCurrentScope = GLOBAL_SCOPE
@@ -1951,38 +2039,20 @@ end
local requireSpecial
local function compile(ast, options)
- options = options or {}
+ local opts = copy(options)
local oldGlobals = allowedGlobals
- local oldChunk = rootChunk
- local oldScope = rootScope
- local oldOptions = rootOptions
- allowedGlobals = options.allowedGlobals
- if options.indent == nil then options.indent = ' ' end
+ setResetRoot(rootChunk, rootScope, rootOptions)
+ allowedGlobals = opts.allowedGlobals
+ if opts.indent == nil then opts.indent = ' ' end
local chunk = {}
- local scope = options.scope or makeScope(GLOBAL_SCOPE)
- rootChunk = chunk
- rootScope = scope
- rootOptions = options
- if options.requireAsInclude then scope.specials.require = requireSpecial end
+ local scope = opts.scope or makeScope(GLOBAL_SCOPE)
+ rootChunk, rootScope, rootOptions = chunk, scope, opts
+ if opts.requireAsInclude then scope.specials.require = requireSpecial end
local exprs = compile1(ast, scope, chunk, {tail = true})
keepSideEffects(exprs, chunk, nil, ast)
allowedGlobals = oldGlobals
- rootChunk = oldChunk
- rootScope = oldScope
- rootOptions = oldOptions
- return flatten(chunk, options)
-end
-
--- map a function across all pairs in a table
-local function quoteTmap(f, t)
- local res = {}
- for k,v in pairs(t) do
- local nk, nv = f(k, v)
- if nk then
- res[nk] = nv
- end
- end
- return res
+ resetRoot()
+ return flatten(chunk, opts)
end
-- make a transformer for key / value table pairs, preserving all numeric keys
@@ -2040,11 +2110,11 @@ local function doQuote (form, scope, parent, runtime)
-- list
elseif isList(form) then
assertCompile(not runtime, "lists may only be used at compile time", form)
- local mapped = quoteTmap(entryTransform(no, q), form)
+ local mapped = kvmap(form, entryTransform(no, q))
return 'list(' .. mixedConcat(mapped, ", ") .. ')'
-- table
elseif type(form) == 'table' then
- local mapped = quoteTmap(entryTransform(q, q), form)
+ local mapped = kvmap(form, entryTransform(q, q))
return '{' .. mixedConcat(mapped, ", ") .. '}'
-- string
elseif type(form) == 'string' then
@@ -2066,24 +2136,20 @@ end
docSpecial('quote', {'x'}, 'Quasiquote the following form. Only works in macro/compiler scope.')
local function compileStream(strm, options)
- options = options or {}
+ local opts = copy(options)
local oldGlobals = allowedGlobals
- local oldChunk = rootChunk
- local oldScope = rootScope
- local oldOptions = rootOptions
- allowedGlobals = options.allowedGlobals
- if options.indent == nil then options.indent = ' ' end
- local scope = options.scope or makeScope(GLOBAL_SCOPE)
- if options.requireAsInclude then scope.specials.require = requireSpecial end
+ setResetRoot(rootChunk, rootScope, rootOptions)
+ allowedGlobals = opts.allowedGlobals
+ if opts.indent == nil then opts.indent = ' ' end
+ local scope = opts.scope or makeScope(GLOBAL_SCOPE)
+ if opts.requireAsInclude then scope.specials.require = requireSpecial end
local vals = {}
- for ok, val in parser(strm, options.filename) do
+ for ok, val in parser(strm, opts.filename) do
if not ok then break end
vals[#vals + 1] = val
end
local chunk = {}
- rootChunk = chunk
- rootScope = scope
- rootOptions = options
+ rootChunk, rootScope, rootOptions = chunk, scope, opts
for i = 1, #vals do
local exprs = compile1(vals[i], scope, chunk, {
tail = i == #vals,
@@ -2091,10 +2157,8 @@ local function compileStream(strm, options)
keepSideEffects(exprs, chunk, nil, vals[i])
end
allowedGlobals = oldGlobals
- rootChunk = oldChunk
- rootScope = oldScope
- rootOptions = oldOptions
- return flatten(chunk, options)
+ resetRoot()
+ return flatten(chunk, opts)
end
local function compileString(str, options)
@@ -2127,14 +2191,10 @@ local function wrapEnv(env)
-- checking the __pairs metamethod won't work automatically in Lua 5.1
-- sadly, but it's important for 5.2+ and can be done manually in 5.1
__pairs = function()
- local pt = {}
- for key, value in pairs(env) do
- if type(key) == 'string' then
- pt[globalUnmangling(key)] = value
- else
- pt[key] = value
- end
+ local function putenv(k, v)
+ return type(k) == 'string' and globalUnmangling(k) or k, v
end
+ local pt = kvmap(env, putenv)
return next, pt, nil
end,
})
@@ -2147,8 +2207,12 @@ local function traceback(msg, start)
local level = start or 2 -- Can be used to skip some frames
local lines = {}
if msg then
- local stripped = msg:gsub('^[^:]*:%d+:%s+', 'runtime error: ')
- table.insert(lines, stripped)
+ if msg:find("^Compile error") then
+ table.insert(lines, msg)
+ else
+ local newmsg = msg:gsub('^[^:]*:%d+:%s+', 'runtime error: ')
+ table.insert(lines, newmsg)
+ end
end
table.insert(lines, 'stack traceback:')
while true do
@@ -2187,212 +2251,44 @@ local function traceback(msg, start)
end
local function currentGlobalNames(env)
- local names = {}
- for k in pairs(env or _G) do
- k = globalUnmangling(k)
- table.insert(names, k)
- end
- return names
+ return kvmap(env or _G, globalUnmangling)
end
local function eval(str, options, ...)
- options = options or {}
+ local opts = copy(options)
-- eval and dofile are considered "live" entry points, so we can assume
-- that the globals available at compile time are a reasonable allowed list
-- UNLESS there's a metatable on env, in which case we can't assume that
-- pairs will return all the effective globals; for instance openresty
-- sets up _G in such a way that all the globals are available thru
-- the __index meta method, but as far as pairs is concerned it's empty.
- if options.allowedGlobals == nil and not getmetatable(options.env) then
- options.allowedGlobals = currentGlobalNames(options.env)
+ if opts.allowedGlobals == nil and not getmetatable(opts.env) then
+ opts.allowedGlobals = currentGlobalNames(opts.env)
end
- local env = options.env and wrapEnv(options.env)
- local luaSource = compileString(str, options)
+ local env = opts.env and wrapEnv(opts.env)
+ local luaSource = compileString(str, opts)
local loader = loadCode(luaSource, env,
- options.filename and ('@' .. options.filename) or str)
+ opts.filename and ('@' .. opts.filename) or str)
+ opts.filename = nil
return loader(...)
end
local function dofileFennel(filename, options, ...)
- options = options or {}
- if options.allowedGlobals == nil then
- options.allowedGlobals = currentGlobalNames(options.env)
+ local opts = copy(options)
+ if opts.allowedGlobals == nil then
+ opts.allowedGlobals = currentGlobalNames(opts.env)
end
local f = assert(io.open(filename, "rb"))
local source = f:read("*all"):gsub("^#![^\n]*\n", "")
f:close()
- options.filename = options.filename or filename
- return eval(source, options, ...)
-end
-
--- Implements a configurable repl
-local function repl(options)
-
- local opts = options or {}
- -- This would get set for us when calling eval, but we want to seed it
- -- with a value that is persistent so it doesn't get reset on each eval.
- if opts.allowedGlobals == nil then
- opts.allowedGlobals = currentGlobalNames(opts.env)
- end
-
- opts.useMetadata = options.useMetadata ~= false
- opts.moduleName = options.moduleName
- rootOptions = opts
-
- local env = opts.env and wrapEnv(opts.env) or setmetatable({}, {
- __index = _ENV or _G
- })
-
- local function defaultReadChunk(parserState)
- io.write(parserState.stackSize > 0 and '.. ' or '>> ')
- io.flush()
- local input = io.read()
- return input and input .. '\n'
- end
-
- local function defaultOnValues(xs)
- io.write(table.concat(xs, '\t'))
- io.write('\n')
- end
-
- local function defaultOnError(errtype, err, luaSource)
- if (errtype == 'Lua Compile') then
- io.write('Bad code generated - likely a bug with the compiler:\n')
- io.write('--- Generated Lua Start ---\n')
- io.write(luaSource .. '\n')
- io.write('--- Generated Lua End ---\n')
- end
- if (errtype == 'Runtime') then
- io.write(traceback(err, 4))
- io.write('\n')
- else
- io.write(('%s error: %s\n'):format(errtype, tostring(err)))
- end
- end
-
- local envdbg = (opts.env or _G)["debug"]
- -- if the environment doesn't support debug.getlocal you can't save locals
- local saveLocals = opts.saveLocals ~= false and envdbg and envdbg.getlocal
- local saveSource = table.
- concat({"local ___i___ = 1",
- "while true do",
- " local name, value = debug.getlocal(1, ___i___)",
- " if(name and name ~= \"___i___\") then",
- " ___replLocals___[name] = value",
- " ___i___ = ___i___ + 1",
- " else break end end"}, "\n")
-
- -- we do some source munging in order to save off locals from each chunk
- -- and reintroduce them to the beginning of the next chunk, allowing
- -- locals to work in the repl the way you'd expect them to.
- local spliceSaveLocals = function(luaSource)
- env.___replLocals___ = env.___replLocals___ or {}
- local splicedSource = {}
- for line in luaSource:gmatch("([^\n]+)\n?") do
- table.insert(splicedSource, line)
- end
- -- reintroduce locals from the previous time around
- local bind = "local %s = ___replLocals___['%s']"
- for name in pairs(env.___replLocals___) do
- table.insert(splicedSource, 1, bind:format(name, name))
- end
- -- save off new locals at the end - if safe to do so (i.e. last line is a return)
- if (string.match(splicedSource[#splicedSource], "^ *return .*$")) then
- if (#splicedSource > 1) then
- table.insert(splicedSource, #splicedSource, saveSource)
- end
- end
- return table.concat(splicedSource, "\n")
- end
-
- -- Read options
- local readChunk = opts.readChunk or defaultReadChunk
- local onValues = opts.onValues or defaultOnValues
- local onError = opts.onError or defaultOnError
- local pp = opts.pp or tostring
-
- -- Make parser
- local bytestream, clearstream = granulate(readChunk)
- local chars = {}
- local read, reset = parser(function (parserState)
- local c = bytestream(parserState)
- chars[#chars + 1] = c
- return c
- end)
-
- local scope = makeScope(GLOBAL_SCOPE)
-
- local replCompleter = function(text)
- local matches = {}
- local inputFragment = text:gsub("[%s)(]*(.+)", "%1")
-
- -- adds any matching keys from the provided generator/iterator to matches
- local function addMatchesFromGen(next, param, state)
- for k in next, param, state do
- if #matches >= 40 then break -- cap completions at 40 to avoid overwhelming
- elseif inputFragment == k:sub(0, #inputFragment) then
- table.insert(matches, k)
- end
- end
- end
- addMatchesFromGen(pairs(env._ENV or env._G or {}))
- addMatchesFromGen(pairs(env.___replLocals___ or {}))
- addMatchesFromGen(pairs(SPECIALS or {}))
- addMatchesFromGen(pairs(scope.specials or {}))
- return matches
- end
- if opts.registerCompleter then opts.registerCompleter(replCompleter) end
-
- -- REPL loop
- while true do
- chars = {}
- local ok, parseok, x = pcall(read)
- local srcstring = string.char(unpack(chars))
- if not ok then
- onError('Parse', parseok)
- clearstream()
- reset()
- else
- if not parseok then break end -- eof
- local compileOk, luaSource = pcall(compile, x, {
- correlate = opts.correlate,
- source = srcstring,
- scope = scope,
- useMetadata = opts.useMetadata,
- moduleName = opts.moduleName,
- })
- if not compileOk then
- clearstream()
- onError('Compile', luaSource) -- luaSource is error message in this case
- else
- if saveLocals then
- luaSource = spliceSaveLocals(luaSource)
- end
- local luacompileok, loader = pcall(loadCode, luaSource, env)
- if not luacompileok then
- clearstream()
- onError('Lua Compile', loader, luaSource)
- else
- local loadok, ret = xpcall(function () return {loader()} end,
- function (runtimeErr)
- onError('Runtime', runtimeErr)
- end)
- if loadok then
- env._ = ret[1]
- env.__ = ret
- for i = 1, #ret do ret[i] = pp(ret[i]) end
- onValues(ret)
- end
- end
- end
- end
- end
+ opts.filename = filename
+ return eval(source, opts, ...)
end
local macroLoaded = {}
local pathTable = {"./?.fnl", "./?/init.fnl"}
-local osPath = os.getenv("FENNEL_PATH")
+local osPath = os and os.getenv and os.getenv("FENNEL_PATH")
if osPath then
table.insert(pathTable, osPath)
end
@@ -2405,6 +2301,7 @@ local module = {
compileString = compileString,
compileStream = compileStream,
compile1 = compile1,
+ loadCode = loadCode,
mangle = globalMangling,
unmangle = globalUnmangling,
list = list,
@@ -2413,14 +2310,166 @@ local module = {
scope = makeScope,
gensym = gensym,
eval = eval,
- repl = repl,
dofile = dofileFennel,
macroLoaded = macroLoaded,
path = table.concat(pathTable, ";"),
traceback = traceback,
- version = "0.3.0",
+ version = "0.4.0-dev",
}
+-- In order to make this more readable, you can switch your editor to treating
+-- this file as if it were Fennel for the purposes of this section
+local replsource = [===[(local (fennel internals) ...)
+
+(fn default-read-chunk [parser-state]
+ (io.write (if (< 0 parser-state.stackSize) ".." ">> "))
+ (io.flush)
+ (let [input (io.read)]
+ (and input (.. input "\n"))))
+
+(fn default-on-values [xs]
+ (io.write (table.concat xs "\t"))
+ (io.write "\n"))
+
+(fn default-on-error [errtype err lua-source]
+ (io.write
+ (match errtype
+ "Lua Compile" (.. "Bad code generated - likely a bug with the compiler:\n"
+ "--- Generated Lua Start ---\n"
+ lua-source
+ "--- Generated Lua End ---\n")
+ "Runtime" (.. (fennel.traceback err 4) "\n")
+ _ (: "%s error: %s\n" :format errtype (tostring err)))))
+
+(local save-source
+ (table.concat ["local ___i___ = 1"
+ "while true do"
+ " local name, value = debug.getlocal(1, ___i___)"
+ " if(name and name ~= \"___i___\") then"
+ " ___replLocals___[name] = value"
+ " ___i___ = ___i___ + 1"
+ " else break end end"] "\n"))
+
+(fn splice-save-locals [env lua-source]
+ (set env.___replLocals___ (or env.___replLocals___ {}))
+ (let [spliced-source []
+ bind "local %s = ___replLocals___['%s']"]
+ (each [line (lua-source:gmatch "([^\n]+)\n?")]
+ (table.insert spliced-source line))
+ (each [name (pairs env.___replLocals___)]
+ (table.insert spliced-source 1 (bind:format name name)))
+ (when (and (: (. spliced-source (# spliced-source)) :match "^ *return .*$")
+ (< 1 (# spliced-source)))
+ (table.insert spliced-source (# spliced-source) save-source))
+ (table.concat spliced-source "\n")))
+
+(fn completer [env scope text]
+ (let [matches []
+ input-fragment (text:gsub ".*[%s)(]+" "")]
+ (fn add-partials [input tbl prefix] ; add partial key matches in tbl
+ (each [k (pairs tbl)]
+ (let [k (if (or (= tbl env) (= tbl env.___replLocals___))
+ (. scope.unmanglings k)
+ k)]
+ (when (and (< (# matches) 40)
+ (= (type k) "string")
+ (= input (k:sub 0 (# input))))
+ (table.insert matches (.. prefix k))))))
+ (fn add-matches [input tbl prefix] ; add matches, descending into tbl fields
+ (let [prefix (if prefix (.. prefix ".") "")]
+ (if (not (input:find "%.")) ; no more dots, so add matches
+ (add-partials input tbl prefix)
+ (let [(head tail) (input:match "^([^.]+)%.(.*)")
+ raw-head (if (or (= tbl env) (= tbl env.___replLocals___))
+ (. scope.manglings head)
+ head)]
+ (when (= (type (. tbl raw-head)) "table")
+ (add-matches tail (. tbl raw-head) (.. prefix head)))))))
+
+ (add-matches input-fragment (or scope.specials []))
+ (add-matches input-fragment (or internals.SPECIALS []))
+ (add-matches input-fragment (or env.___replLocals___ []))
+ (add-matches input-fragment env)
+ (add-matches input-fragment (or env._ENV env._G []))
+ matches))
+
+(fn repl [options]
+ (let [old-root-options internals.rootOptions
+ env (if options.env
+ (internals.wrapEnv options.env)
+ (setmetatable {} {:__index (or _G._ENV _G)}))
+ save-locals? (and (not= options.saveLocals false)
+ env.debug env.debug.getlocal)
+ opts {}
+ _ (each [k v (pairs options)] (tset opts k v))
+ read-chunk (or opts.readChunk default-read-chunk)
+ on-values (or opts.onValues default-on-values)
+ on-error (or opts.onError default-on-error)
+ pp (or opts.pp tostring)
+ ;; make parser
+ (byte-stream clear-stream) (fennel.granulate read-chunk)
+ chars []
+ (read reset) (fennel.parser (fn [parser-state]
+ (let [c (byte-stream parser-state)]
+ (tset chars (+ (# chars) 1) c)
+ c)))
+ scope (fennel.scope)]
+
+ ;; use metadata unless we've specifically disabled it
+ (set opts.useMetadata (not= options.useMetadata false))
+ (when (= opts.allowedGlobals nil)
+ (set opts.allowedGlobals (internals.currentGlobalNames opts.env)))
+
+ (when opts.registerCompleter
+ (opts.registerCompleter (partial completer env scope)))
+
+ (fn loop []
+ (each [k (pairs chars)] (tset chars k nil))
+ (let [(ok parse-ok? x) (pcall read)
+ src-string (string.char ((or _G.unpack table.unpack) chars))]
+ (internals.setRootOptions opts)
+ (if (not ok)
+ (do (on-error "Parse" parse-ok?)
+ (clear-stream)
+ (reset)
+ (loop))
+ (when parse-ok? ; if this is false, we got eof
+ (match (pcall fennel.compile x {:correlate opts.correlate
+ :source src-string
+ :scope scope
+ :useMetadata opts.useMetadata
+ :moduleName opts.moduleName})
+ (false msg) (do (clear-stream)
+ (on-error "Compile" msg))
+ (true source) (let [source (if save-locals?
+ (splice-save-locals env source)
+ source)
+ (lua-ok? loader) (pcall fennel.loadCode
+ source env)]
+ (if (not lua-ok?)
+ (do (clear-stream)
+ (on-error "Lua Compile" loader source))
+ (match (xpcall #[(loader)]
+ (partial on-error "Runtime"))
+ (true ret)
+ (do (set env._ (. ret 1))
+ (set env.__ ret)
+ (on-values (internals.map ret pp)))))))
+ (internals.setRootOptions old-root-options)
+ (loop)))))
+ (loop)))]===]
+
+module.repl = function(options)
+ -- functionality the repl needs that isn't part of the public API yet
+ local internals = { rootOptions = rootOptions,
+ setRootOptions = function(r) rootOptions = r end,
+ currentGlobalNames = currentGlobalNames,
+ wrapEnv = wrapEnv,
+ SPECIALS = SPECIALS,
+ map = map }
+ return eval(replsource, { correlate = true }, module, internals)(options)
+end
+
local function searchModule(modulename, pathstring)
modulename = modulename:gsub("%.", "/")
for path in string.gmatch((pathstring or module.path)..";", "([^;]*);") do
@@ -2438,8 +2487,7 @@ module.makeSearcher = function(options)
-- this will propagate options from the repl but not from eval, because
-- eval unsets rootOptions after compiling but before running the actual
-- calls to require.
- local opts = {}
- for k,v in pairs(rootOptions or {}) do opts[k] = v end
+ local opts = copy(rootOptions)
for k,v in pairs(options or {}) do opts[k] = v end
local filename = searchModule(modulename)
if filename then
@@ -2490,24 +2538,14 @@ local function makeCompilerEnv(ast, scope, parent)
end
local function macroGlobals(env, globals)
- local allowed = {}
- for k in pairs(env) do
- local g = globalUnmangling(k)
- table.insert(allowed, g)
- end
- if globals then
- for _, k in pairs(globals) do
- table.insert(allowed, k)
- end
- end
+ local allowed = currentGlobalNames(env)
+ for _, k in pairs(globals or {}) do table.insert(allowed, k) end
return allowed
end
local function addMacros(macros, ast, scope)
assertCompile(isTable(macros), 'expected macros to be table', ast)
- for k, v in pairs(macros) do
- scope.specials[k] = macroToSpecial(v)
- end
+ kvmap(macros, function(k, v) return k, macroToSpecial(v) end, scope.specials)
end
local function loadMacros(modname, ast, scope, parent)
@@ -2548,10 +2586,7 @@ SPECIALS['include'] = function(ast, scope, parent, opts)
local mod = loadCode(code)()
-- Check cache
- local includeExpr = scope.includes[mod]
- if includeExpr then
- return includeExpr
- end
+ if scope.includes[mod] then return scope.includes[mod] end
-- Find path to source
local path = searchModule(mod)
@@ -2573,32 +2608,45 @@ SPECIALS['include'] = function(ast, scope, parent, opts)
local s = f:read('*all')
f:close()
- -- splice in source and memoize it
- -- so we can include it again without duplication
- local target = gensym(scope)
- local ret = expr(target, 'sym')
+ -- splice in source and memoize it in compiler AND package.preload
+ -- so we can include it again without duplication, even in runtime
+ local target = 'package.preload["' .. mod .. '"]'
+ local ret = expr('require("' .. mod .. '")', 'statement')
+
+ local subChunk, tempChunk = {}, {}
+ emit(tempChunk, subChunk, ast)
+ -- if lua, simply emit the setting of package.preload
+ if not isFennel then
+ emit(tempChunk, target .. ' = ' .. target .. ' or function()\n' .. s .. 'end', ast)
+ end
+ -- Splice tempChunk to begining of rootChunk
+ for i, v in ipairs(tempChunk) do
+ table.insert(rootChunk, i, v)
+ end
+
+ -- For fnl source, compile subChunk AFTER splicing into start of rootChunk.
if isFennel then
- local p = parser(stringStream(s), path)
- local forms = list(sym('do'))
- for _, val in p do table.insert(forms, val) end
+ local subopts = { nval = 1, target = target }
local subscope = makeScope(rootScope.parent)
if rootOptions.requireAsInclude then
subscope.specials.require = requireSpecial
end
- local subopts = {
- nval = 1,
- target = target
- }
- emit(rootChunk, 'local ' .. target, ast)
- compile1(forms, subscope, rootChunk, subopts)
- else
- emit(rootChunk, 'local ' .. target .. ' = (function() ' .. s .. ' end)()', ast)
+ local targetForm = list(sym('.'), sym('package.preload'), mod)
+ -- splice "or" statement in so it uses existing package.preload[modname]
+ -- if it's been set by something else, allowing for overrides
+ local forms = list(sym('or'), targetForm, list(sym('fn'), sequence()))
+ local p = parser(stringStream(s), path)
+ for _, val in p do table.insert(forms[3], val) end
+ compile1(forms, subscope, subChunk, subopts)
end
-- Put in cache and return
rootScope.includes[mod] = ret
return ret
end
+docSpecial('include', {'module-name-literal'},
+ 'Like require, but load the target module during compilation and embed it in the\n'
+ .. 'Lua output. The module must be a string literal and resolvable at compile time.')
local function requireFallback(e)
local code = ('require(%s)'):format(tostring(e))
@@ -2795,7 +2843,7 @@ that argument name begins with ?."
(do (assert (not (. pattern (+ k 2)))
"expected rest argument in final position")
(table.insert bindings (. pattern (+ k 1)))
- (table.insert bindings [`(select ,k ((or unpack table.unpack)
+ (table.insert bindings [`(select ,k ((or _G.unpack table.unpack)
,val))]))
(and (= :number (type k))
(= "&" (tostring (. pattern (- k 1)))))
@@ -2846,19 +2894,21 @@ do
local moduleName = "__fennel-bootstrap__"
package.preload[moduleName] = function() return module end
local env = makeCompilerEnv(nil, COMPILER_SCOPE, {})
- for name, fn in pairs(eval(stdmacros, {
- env = env,
- scope = makeScope(COMPILER_SCOPE),
- -- assume the code to load globals doesn't have any mistaken globals,
- -- otherwise this can be problematic when loading fennel in contexts
- -- where _G is an empty table with an __index metamethod. (openresty)
- allowedGlobals = false,
- useMetadata = true,
- filename = "built-ins",
- moduleName = moduleName,
- })) do
- SPECIALS[name] = macroToSpecial(fn, name)
- end
+ local macros = eval(stdmacros, {
+ env = env,
+ scope = makeScope(COMPILER_SCOPE),
+ -- assume the code to load globals doesn't have any
+ -- mistaken globals, otherwise this can be
+ -- problematic when loading fennel in contexts
+ -- where _G is an empty table with an __index
+ -- metamethod. (openresty)
+ allowedGlobals = false,
+ useMetadata = true,
+ filename = "built-ins",
+ moduleName = moduleName })
+ kvmap(macros,
+ function(name, fn) return name, macroToSpecial(fn, name) end,
+ SPECIALS)
package.preload[moduleName] = nil
end
SPECIALS['λ'] = SPECIALS['lambda']
diff --git a/lib/fennel b/lib/fennel
index d1e7f34..e694461 100755
--- a/lib/fennel
+++ b/lib/fennel
@@ -10,8 +10,9 @@ Usage: fennel [FLAG] [FILE]
Run fennel, a lisp programming language for the Lua runtime.
- --repl : Launch an interactive repl session
- --compile FILES : Compile files and write their Lua to stdout
+ --repl : Command to launch an interactive repl session
+ --compile FILES : Command to compile files and write Lua to stdout
+ --eval SOURCE (-e) : Command to evaluate source code and print the result
--no-searcher : Skip installing package.searchers entry
--indent VAL : Indent compiler output with VAL
@@ -19,12 +20,13 @@ Run fennel, a lisp programming language for the Lua runtime.
--add-fennel-path PATH : Add PATH to fennel.path for finding Fennel modules
--globals G1[,G2...] : Allow these globals in addition to standard ones
--globals-only G1[,G2] : Same as above, but exclude standard ones
+ --check-unused-locals : Raise error when compiling code with unused locals
--require-as-include : Inline required modules in the output
--metadata : Enable function metadata, even in compiled output
--no-metadata : Disable function metadata, even in REPL
--correlate : Make Lua output line numbers match Fennel input
-
- --eval SOURCE (-e) : Evaluate source code and print the result
+ --load FILE (-l) : Load the specified FILE before executing the command
+ --no-fennelrc : Skip loading ~/.fennelrc when launching repl
--help (-h) : Display this text
--version (-v) : Show version
@@ -32,8 +34,8 @@ Run fennel, a lisp programming language for the Lua runtime.
Metadata is typically considered a development feature and is not recommended
for production. It is used for docstrings and enabled by default in the REPL.
- When not given a flag, runs the file given as the first argument.
- When given neither flag nor file, launches a repl.
+ When not given a command, runs the file given as the first argument.
+ When given neither command nor file, launches a repl.
If ~/.fennelrc exists, loads it before launching a repl.]]
@@ -73,9 +75,19 @@ for i=#arg, 1, -1 do
local entry = table.remove(arg, i+1)
fennel.path = entry .. ";" .. fennel.path
table.remove(arg, i)
+ elseif arg[i] == "--load" or arg[i] == "-l" then
+ local file = table.remove(arg, i+1)
+ dosafe(file, options, {})
+ table.remove(arg, i)
+ elseif arg[i] == "--no-fennelrc" then
+ options.fennelrc = false
+ table.remove(arg, i)
elseif arg[i] == "--correlate" then
options.correlate = true
table.remove(arg, i)
+ elseif arg[i] == "--check-unused-locals" then
+ options.checkUnusedLocals = true
+ table.remove(arg, i)
elseif arg[i] == "--globals" then
allowGlobals(table.remove(arg, i+1))
for globalName in pairs(_G) do
@@ -146,16 +158,26 @@ if arg[1] == "--repl" or #arg == 0 then
options.pp = pp
end
end
- local initFilename = (os.getenv("HOME") or "") .. "/.fennelrc"
- local init = io.open(initFilename, "rb")
tryReadline(options)
- if init then
- init:close()
- -- pass in options so fennerlrc can make changes to it
- dosafe(initFilename, options, options)
+ if options.fennelrc ~= false then
+ local home = os.getenv("HOME")
+ local xdg_config_home = os.getenv("XDG_CONFIG_HOME") or home .. "/.config"
+ local xdg_initfile = xdg_config_home .. "/fennel/fennelrc"
+ local home_initfile = home .. "/.fennelrc"
+ local init, initFilename = io.open(xdg_initfile, "rb"), xdg_initfile
+ if not init then
+ init, initFilename = io.open(home_initfile, "rb"), home_initfile
+ end
+
+ if init then
+ init:close()
+ -- pass in options so fennerlrc can make changes to it
+ dosafe(initFilename, options, {options})
+ end
end
+
print("Welcome to Fennel " .. fennel.version .. "!")
if options.useMetadata ~= false then
print("Use (doc something) to view documentation.")
diff --git a/lib/fennel.lua b/lib/fennel.lua
index ec5cef1..6663866 100644
--- a/lib/fennel.lua
+++ b/lib/fennel.lua
@@ -30,20 +30,42 @@ local unpack = unpack or table.unpack
-- Main Types and support functions
--
+-- Map function f over sequential table t, removing values where f returns nil.
+-- Optionally takes a target table to insert the mapped values into.
+local function map(t, f, out)
+ out = out or {}
+ if type(f) ~= "function" then local s = f f = function(x) return x[s] end end
+ for _,x in ipairs(t) do
+ local v = f(x)
+ if v then table.insert(out, v) end
+ end
+ return out
+end
+
+-- Map function f over key/value table t, similar to above, but it can return a
+-- sequential table if f returns a single value or a k/v table if f returns two.
+-- Optionally takes a target table to insert the mapped values into.
+local function kvmap(t, f, out)
+ out = out or {}
+ if type(f) ~= "function" then local s = f f = function(x) return x[s] end end
+ for k,x in pairs(t) do
+ local korv, v = f(k, x)
+ if korv and not v then table.insert(out, korv) end
+ if korv and v then out[korv] = v end
+ end
+ return out
+end
+
local function deref(self) return self[1] end
-local SYMBOL_MT = { 'SYMBOL', __tostring = deref }
+local function listToString(self, tostring2)
+ return '(' .. table.concat(map(self, tostring2 or tostring), ' ', 1, #self) .. ')'
+end
+
+local SYMBOL_MT = { 'SYMBOL', __tostring = deref, __fennelview = deref }
local EXPR_MT = { 'EXPR', __tostring = deref }
local VARARG = setmetatable({ '...' }, { 'VARARG', __tostring = deref })
-local LIST_MT = { 'LIST',
- __tostring = function (self)
- local strs = {}
- for _, s in ipairs(self) do
- table.insert(strs, tostring(s))
- end
- return '(' .. table.concat(strs, ' ', 1, #self) .. ')'
- end
-}
+local LIST_MT = { 'LIST', __tostring = listToString, __fennelview = listToString }
local SEQUENCE_MT = { 'SEQUENCE' }
-- Load code with an environment in all recent Lua versions
@@ -58,23 +80,28 @@ local function loadCode(code, environment, filename)
end
end
--- Create a new list
+-- Create a new list. Lists are a compile-time construct in Fennel; they are
+-- represented as tables with a special marker metatable. They only come from
+-- the parser, and they represent code which comes from reading a paren form;
+-- they are specifically not cons cells.
local function list(...)
return setmetatable({...}, LIST_MT)
end
--- Create a new symbol
+-- Create a new symbol. Symbols are a compile-time construct in Fennel and are
+-- not exposed outside the compiler. Symbols have metadata describing what file,
+-- line, etc that they came from.
local function sym(str, scope, meta)
local s = {str, scope = scope}
- if meta then
- for k, v in pairs(meta) do
- if type(k) == 'string' then s[k] = v end
- end
+ for k, v in pairs(meta or {}) do
+ if type(k) == 'string' then s[k] = v end
end
return setmetatable(s, SYMBOL_MT)
end
--- Create a new sequence
+-- Create a new sequence. Sequences are tables that come from the parser when
+-- it encounters a form with square brackets. They are treated as regular tables
+-- except when certain macros need to look for binding forms, etc specifically.
local function sequence(...)
return setmetatable({...}, SEQUENCE_MT)
end
@@ -120,6 +147,13 @@ local function isSequence(x)
return type(x) == 'table' and getmetatable(x) == SEQUENCE_MT and x
end
+-- Returns a shallow copy of its table argument. Returns an empty table on nil.
+local function copy(from)
+ local to = {}
+ for k, v in pairs(from or {}) do to[k] = v end
+ return to
+end
+
--
-- Parser
--
@@ -196,6 +230,11 @@ local prefixes = { -- prefix chars substituted while reading
[35] = 'hashfn' -- #
}
+-- The resetRoot function needs to be called at every exit point of the compiler
+-- including when there's a parse error or compiler error. Introduce it up here
+-- so error functions have access to it, and set it when we have values below.
+local resetRoot = nil
+
-- Parse one value given a function that
-- returns sequential bytes. Will throw an error as soon
-- as possible without getting more bytes on bad input. Returns
@@ -228,6 +267,7 @@ local function parser(getbyte, filename)
return r
end
local function parseError(msg)
+ if resetRoot then resetRoot() end
return error(msg .. ' in ' .. (filename or 'unknown') .. ':' .. line, 0)
end
@@ -254,10 +294,7 @@ local function parser(getbyte, filename)
-- Throw nice error when we expect more characters
-- but reach end of stream.
local function badend()
- local accum = {}
- for _, item in ipairs(stack) do
- accum[#accum + 1] = item.closer
- end
+ local accum = map(stack, "closer")
parseError(('expected closing delimiter%s %s'):format(
#stack == 1 and "" or "s",
string.char(unpack(accum))))
@@ -317,7 +354,8 @@ local function parser(getbyte, filename)
end
val = {}
for i = 1, #last, 2 do
- if tostring(last[i]) == ":" and isSym(last[i + 1]) then
+ if(tostring(last[i]) == ":" and isSym(last[i + 1])
+ and isSym(last[i])) then
last[i] = tostring(last[i + 1])
end
val[last[i]] = last[i + 1]
@@ -376,7 +414,7 @@ local function parser(getbyte, filename)
if rawstr == 'true' then dispatch(true)
elseif rawstr == 'false' then dispatch(false)
elseif rawstr == '...' then dispatch(VARARG)
- elseif rawstr:match('^:.+$') then -- keyword style strings
+ elseif rawstr:match('^:.+$') then -- colon style strings
dispatch(rawstr:sub(2))
elseif rawstr:match("^~") and rawstr ~= "~=" then
-- for backwards-compatibility, special-case allowance of ~=
@@ -424,15 +462,25 @@ end
--
-- Top level compilation bindings.
-local rootChunk
-local rootScope
-local rootOptions
+local rootChunk, rootScope, rootOptions
--- Create a new Scope, optionally under a parent scope. Scopes are compile time constructs
--- that are responsible for keeping track of local variables, name mangling, and macros.
--- They are accessible to user code via the '*compiler' special form (may change). They
--- use metatables to implement nesting via inheritance.
+local function setResetRoot(oldChunk, oldScope, oldOptions)
+ local oldResetRoot = resetRoot -- this needs to nest!
+ resetRoot = function()
+ rootChunk, rootScope, rootOptions = oldChunk, oldScope, oldOptions
+ resetRoot = oldResetRoot
+ end
+end
+
+local GLOBAL_SCOPE
+
+-- Create a new Scope, optionally under a parent scope. Scopes are compile time
+-- constructs that are responsible for keeping track of local variables, name
+-- mangling, and macros. They are accessible to user code via the
+-- 'eval-compiler' special form (may change). They use metatables to implement
+-- nesting via metatables.
local function makeScope(parent)
+ if not parent then parent = GLOBAL_SCOPE end
return {
unmanglings = setmetatable({}, {
__index = parent and parent.unmanglings
@@ -449,6 +497,9 @@ local function makeScope(parent)
includes = setmetatable({}, {
__index = parent and parent.includes
}),
+ refedglobals = setmetatable({}, {
+ __index = parent and parent.refedglobals
+ }),
autogensyms = {},
parent = parent,
vararg = parent and parent.vararg,
@@ -462,6 +513,7 @@ end
local function assertCompile(condition, msg, ast)
-- if we use regular `assert' we can't provide the `level' argument of zero
if not condition then
+ if resetRoot then resetRoot() end
error(string.format("Compile error in '%s' %s:%s: %s",
isSym(ast[1]) and ast[1][1] or ast[1] or '()',
ast.filename or "unknown", ast.line or '?', msg), 0)
@@ -469,7 +521,7 @@ local function assertCompile(condition, msg, ast)
return condition
end
-local GLOBAL_SCOPE = makeScope()
+GLOBAL_SCOPE = makeScope()
GLOBAL_SCOPE.vararg = true
local SPECIALS = GLOBAL_SCOPE.specials
local COMPILER_SCOPE = makeScope(GLOBAL_SCOPE)
@@ -479,9 +531,8 @@ local luaKeywords = {
'if', 'in', 'local', 'nil', 'not', 'or', 'repeat', 'return', 'then', 'true',
'until', 'while'
}
-for i, v in ipairs(luaKeywords) do
- luaKeywords[v] = i
-end
+
+for i, v in ipairs(luaKeywords) do luaKeywords[v] = i end
local function isValidLuaIdentifier(str)
return (str:match('^[%a_][%w_]*$') and not luaKeywords[str])
@@ -553,21 +604,31 @@ end
local function globalUnmangling(identifier)
local rest = identifier:match('^__fnl_global__(.*)$')
if rest then
- return rest:gsub('_[%da-f][%da-f]', function (code)
+ local r = rest:gsub('_[%da-f][%da-f]', function (code)
return string.char(tonumber(code:sub(2), 16))
end)
+ return r -- don't return multiple values
else
return identifier
end
end
+-- If there's a provided list of allowed globals, don't let references thru that
+-- aren't on the list. This list is set at the compiler entry points of compile
+-- and compileStream.
+local allowedGlobals
+
+local function globalAllowed(name)
+ if not allowedGlobals then return true end
+ for _, g in ipairs(allowedGlobals) do
+ if g == name then return true end
+ end
+end
+
-- Creates a symbol from a string by mangling it.
-- ensures that the generated symbol is unique
-- if the input string is unique in the scope.
-local function localMangling(str, scope, ast)
- if scope.manglings[str] then
- return scope.manglings[str]
- end
+local function localMangling(str, scope, ast, tempManglings)
local append = 0
local mangling = str
assertCompile(not isMultiSym(str), 'did not expect multi symbol ' .. str, ast)
@@ -581,16 +642,30 @@ local function localMangling(str, scope, ast)
return ('_%02x'):format(c:byte())
end)
+ -- Prevent name collisions with existing symbols
local raw = mangling
while scope.unmanglings[mangling] do
mangling = raw .. append
append = append + 1
end
+
scope.unmanglings[mangling] = str
- scope.manglings[str] = mangling
+ local manglings = tempManglings or scope.manglings
+ manglings[str] = mangling
return mangling
end
+-- Calling this function will mean that further
+-- compilation in scope will use these new manglings
+-- instead of the current manglings.
+local function applyManglings(scope, newManglings, ast)
+ for raw, mangled in pairs(newManglings) do
+ assertCompile(not scope.refedglobals[mangled],
+ "use of global " .. raw .. " is aliased by a local", ast)
+ scope.manglings[raw] = mangled
+ end
+end
+
-- Combine parts of a symbol
local function combineParts(parts, scope)
local ret = scope.manglings[parts[1]] or globalMangling(parts[1])
@@ -637,32 +712,20 @@ local function checkBindingValid(symbol, scope, ast)
assertCompile(not scope.specials[name],
("symbol %s may be overshadowed by a special form or macro"):format(name), ast)
assertCompile(not isQuoted(symbol), 'macro tried to bind ' .. name ..
- ' without gensym; try ' .. name .. '# instead', ast)
+ " without gensym; try ' .. name .. '# instead", ast)
end
-- Declare a local symbol
-local function declareLocal(symbol, meta, scope, ast)
+local function declareLocal(symbol, meta, scope, ast, tempManglings)
checkBindingValid(symbol, scope, ast)
local name = symbol[1]
assertCompile(not isMultiSym(name), "did not expect mutltisym", ast)
- local mangling = localMangling(name, scope, ast)
+ local mangling = localMangling(name, scope, ast, tempManglings)
scope.symmeta[name] = meta
return mangling
end
--- If there's a provided list of allowed globals, don't let references
--- thru that aren't on the list. This list is set at the compiler
--- entry points of compile and compileStream.
-local allowedGlobals
-
-local function globalAllowed(name)
- if not allowedGlobals then return true end
- for _, g in ipairs(allowedGlobals) do
- if g == name then return true end
- end
-end
-
-- Convert symbol to Lua code. Will only work for local symbols
-- if they have already been declared via declareLocal
local function symbolToExpression(symbol, scope, isReference)
@@ -685,6 +748,9 @@ local function symbolToExpression(symbol, scope, isReference)
-- then we need to check for allowed globals
assertCompile(not isReference or isLocal or globalAllowed(parts[1]),
'unknown global in strict mode: ' .. parts[1], symbol)
+ if not isLocal then
+ rootScope.refedglobals[parts[1]] = true
+ end
return expr(combineParts(parts, scope), etype)
end
@@ -709,10 +775,7 @@ local function peephole(chunk)
return peephole(chunk[2])
end
-- Recurse
- for i, v in ipairs(chunk) do
- chunk[i] = peephole(v)
- end
- return chunk
+ return map(chunk, peephole)
end
-- correlate line numbers in input with line numbers in output
@@ -753,15 +816,13 @@ local function flattenChunk(sm, chunk, tab, depth)
if sm then sm[#sm + 1] = info and info.line or -1 end
return code
else
- local parts = {}
- for i = 1, #chunk do
- -- Ignore empty chunks
- if chunk[i].leaf or #(chunk[i]) > 0 then
- local sub = flattenChunk(sm, chunk[i], tab, depth + 1)
+ local parts = map(chunk, function(c)
+ if c.leaf or #c > 0 then -- Ignore empty chunks
+ local sub = flattenChunk(sm, c, tab, depth + 1)
if depth > 0 then sub = tab .. sub:gsub('\n', '\n' .. tab) end
- table.insert(parts, sub)
+ return sub
end
- end
+ end)
return table.concat(parts, '\n')
end
end
@@ -851,16 +912,12 @@ end
local function docSpecial(name, arglist, docstring)
metadata[SPECIALS[name]] =
- { ['fnl/docstring'] = docstring, ['fnl/arglist'] = arglist }
+ { ["fnl/docstring"] = docstring, ["fnl/arglist"] = arglist }
end
-- Convert expressions to Lua string
local function exprs1(exprs)
- local t = {}
- for _, e in ipairs(exprs) do
- t[#t + 1] = e[1]
- end
- return table.concat(t, ', ')
+ return table.concat(map(exprs, 1), ', ')
end
-- Compile side effects for a chunk
@@ -937,6 +994,17 @@ end
-- 'tail' - boolean indicating tail position if set. If set, form will generate a return
-- instruction.
-- 'nval' - The number of values to compile to if it is known to be a fixed value.
+
+-- In Lua, an expression can evaluate to 0 or more values via multiple
+-- returns. In many cases, Lua will drop extra values and convert a 0 value
+-- expression to nil. In other cases, Lua will use all of the values in an
+-- expression, such as in the last argument of a function call. Nval is an
+-- option passed to compile1 to say that the resulting expression should have
+-- at least n values. It lets us generate better code, because if we know we
+-- are only going to use 1 or 2 values from an expression, we can create 1 or 2
+-- locals to store intermediate results rather than turn the expression into a
+-- closure that is called immediately, which we have to do if we don't know.
+
local function compile1(ast, scope, parent, opts)
opts = opts or {}
local exprs = {}
@@ -1038,24 +1106,23 @@ local function compile1(ast, scope, parent, opts)
local nval = i ~= #ast and 1
buffer[#buffer + 1] = exprs1(compile1(ast[i], scope, parent, {nval = nval}))
end
- local keys = {}
- for k, _ in pairs(ast) do -- Write other keys.
+ local function writeOtherValues(k)
if type(k) ~= 'number' or math.floor(k) ~= k or k < 1 or k > #ast then
- local kstr
if type(k) == 'string' and isValidLuaIdentifier(k) then
- kstr = k
+ return {k, k}
else
- kstr = '[' .. tostring(compile1(k, scope, parent, {nval = 1})[1]) .. ']'
+ local kstr = '[' .. tostring(compile1(k, scope, parent,
+ {nval = 1})[1]) .. ']'
+ return { kstr, k }
end
- table.insert(keys, { kstr, k })
end
end
+ local keys = kvmap(ast, writeOtherValues)
table.sort(keys, function (a, b) return a[1] < b[1] end)
- for _, k in ipairs(keys) do
- local v = ast[k[2]]
- buffer[#buffer + 1] = ('%s = %s'):format(
- k[1], tostring(compile1(v, scope, parent, {nval = 1})[1]))
- end
+ map(keys, function(k)
+ local v = tostring(compile1(ast[k[2]], scope, parent, {nval = 1})[1])
+ return ('%s = %s'):format(k[1], v) end,
+ buffer)
local tbl = '{' .. table.concat(buffer, ', ') ..'}'
exprs = handleCompileOpts({expr(tbl, 'expression')}, parent, opts, ast)
else
@@ -1096,13 +1163,15 @@ local function destructure(to, from, ast, scope, parent, opts)
local forceset = opts.forceset
local setter = declaration and "local %s = %s" or "%s = %s"
+ local newManglings = {}
+
-- Get Lua source for symbol, and check for errors
local function getname(symbol, up1)
local raw = symbol[1]
assertCompile(not (nomulti and isMultiSym(raw)),
'did not expect multisym', up1)
if declaration then
- return declareLocal(symbol, {var = isvar}, scope, symbol)
+ return declareLocal(symbol, {var = isvar}, scope, symbol, newManglings)
else
local parts = isMultiSym(raw) or {raw}
local meta = scope.symmeta[parts[1]]
@@ -1114,6 +1183,16 @@ local function destructure(to, from, ast, scope, parent, opts)
assertCompile(not (meta and not meta.var),
'expected local var', up1)
end
+ if forceglobal then
+ assertCompile(not scope.symmeta[scope.unmanglings[raw]],
+ "global " .. raw .. " conflicts with local", ast)
+ scope.manglings[raw] = globalMangling(raw)
+ scope.unmanglings[globalMangling(raw)] = raw
+ if allowedGlobals then
+ table.insert(allowedGlobals, raw)
+ end
+ end
+
return symbolToExpression(symbol, scope)[1]
end
end
@@ -1121,10 +1200,8 @@ local function destructure(to, from, ast, scope, parent, opts)
-- Compile the outer most form. We can generate better Lua in this case.
local function compileTopTarget(lvalues)
-- Calculate initial rvalue
- local inits = {}
- for _, x in ipairs(lvalues) do
- table.insert(inits, scope.manglings[x] and x or 'nil')
- end
+ local inits = map(lvalues, function(x)
+ return scope.manglings[x] and x or 'nil' end)
local init = table.concat(inits, ', ')
local lvalue = table.concat(lvalues, ', ')
@@ -1198,7 +1275,9 @@ local function destructure(to, from, ast, scope, parent, opts)
if top then return {returned = true} end
end
- return destructure1(to, nil, ast, true)
+ local ret = destructure1(to, nil, ast, true)
+ applyManglings(scope, newManglings, ast)
+ return ret
end
-- Unlike most expressions and specials, 'values' resolves with multiple
@@ -1234,6 +1313,15 @@ local function compileDo(ast, scope, parent, start)
end
end
+-- Raises compile error if unused locals are found and we're checking for them.
+local function checkUnused(scope, ast)
+ if not rootOptions.checkUnusedLocals then return end
+ for symName in pairs(scope.symmeta) do
+ assertCompile(scope.symmeta[symName].used or symName:find("^_"),
+ ("unused local %s"):format(symName), ast)
+ end
+end
+
-- Implements a do statement, starting at the 'start' element. By default, start is 2.
local function doImpl(ast, scope, parent, opts, start, chunk, subScope)
start = start or 2
@@ -1293,20 +1381,21 @@ local function doImpl(ast, scope, parent, opts, start, chunk, subScope)
end
emit(parent, chunk, ast)
emit(parent, 'end', ast)
+ checkUnused(subScope, ast)
return retexprs
end
-SPECIALS['do'] = doImpl
-docSpecial('do', {'...'}, 'Evaluate multiple forms; return last value.')
+SPECIALS["do"] = doImpl
+docSpecial("do", {"..."}, "Evaluate multiple forms; return last value.")
-SPECIALS['values'] = values
-docSpecial('values', {'...'},
- 'Return multiple values from a function. Must be in tail position.')
+SPECIALS["values"] = values
+docSpecial("values", {"..."},
+ "Return multiple values from a function. Must be in tail position.")
-- The fn special declares a function. Syntax is similar to other lisps;
-- (fn optional-name [arg ...] (body))
-- Further decoration such as docstrings, meta info, and multibody functions a possibility.
-SPECIALS['fn'] = function(ast, scope, parent)
+SPECIALS["fn"] = function(ast, scope, parent)
local fScope = makeScope(scope)
local fChunk = {}
local index = 2
@@ -1327,25 +1416,26 @@ SPECIALS['fn'] = function(ast, scope, parent)
fnName = gensym(scope)
end
local argList = assertCompile(isTable(ast[index]),
- 'expected vector arg list [a b ...]', ast)
- local argNameList = {}
- for i = 1, #argList do
- if isVarg(argList[i]) then
- assertCompile(i == #argList, "expected vararg in last parameter position", ast)
- argNameList[i] = '...'
+ "expected vector arg list [a b ...]", ast)
+ local function getArgName(i, name)
+ if isVarg(name) then
+ assertCompile(i == #argList, "expected vararg as last parameter", ast)
fScope.vararg = true
- elseif(isSym(argList[i]) and argList[i][1] ~= "nil"
- and not isMultiSym(argList[i][1])) then
- argNameList[i] = declareLocal(argList[i], {}, fScope, ast)
- elseif isTable(argList[i]) then
+ return "..."
+ elseif(isSym(name) and deref(name) ~= "nil"
+ and not isMultiSym(deref(name))) then
+ return declareLocal(name, {}, fScope, ast)
+ elseif isTable(name) then
local raw = sym(gensym(scope))
- argNameList[i] = declareLocal(raw, {}, fScope, ast)
- destructure(argList[i], raw, ast, fScope, fChunk,
+ local declared = declareLocal(raw, {}, fScope, ast)
+ destructure(name, raw, ast, fScope, fChunk,
{ declaration = true, nomulti = true })
+ return declared
else
- assertCompile(false, 'expected symbol for function parameter', ast)
+ assertCompile(false, "expected symbol for function parameter", ast)
end
end
+ local argNameList = kvmap(argList, getArgName)
if type(ast[index + 1]) == 'string' and index + 1 < #ast then
index = index + 1
docstring = ast[index]
@@ -1368,11 +1458,10 @@ SPECIALS['fn'] = function(ast, scope, parent)
emit(parent, 'end', ast)
if rootOptions.useMetadata then
- local args = {}
- for i, v in ipairs(argList) do
+ local args = map(argList, function(v)
-- TODO: show destructured args properly instead of replacing
- args[i] = isTable(v) and '"#"' or string.format('"%s"', tostring(v))
- end
+ return isTable(v) and '"#"' or string.format('"%s"', tostring(v))
+ end)
local metaFields = {
'"fnl/arglist"', '{' .. table.concat(args, ', ') .. '}',
@@ -1388,13 +1477,14 @@ SPECIALS['fn'] = function(ast, scope, parent)
fnName, table.concat(metaFields, ', ')))
end
+ checkUnused(fScope, ast)
return expr(fnName, 'sym')
end
-docSpecial('fn', {'name?', 'args', 'docstring?', '...'},
- 'Function syntax. May optionally include a name and docstring.'
- ..'\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.')
+docSpecial("fn", {"name?", "args", "docstring?", "..."},
+ "Function syntax. May optionally include a name and docstring."
+ .."\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.")
-- (lua "print('hello!')") -> prints hello, evaluates to nil
-- (lua "print 'hello!'" "10") -> prints hello, evaluates to the number 10
@@ -1427,11 +1517,11 @@ SPECIALS['doc'] = function(ast, scope, parent)
:format(rootOptions.moduleName or "fennel", value, tostring(ast[2]))
end
end
-docSpecial('doc', {'x'},
- 'Print the docstring and arglist for a function, macro, or special form.')
+docSpecial("doc", {"x"},
+ "Print the docstring and arglist for a function, macro, or special form.")
-- Table lookup
-SPECIALS['.'] = function(ast, scope, parent)
+SPECIALS["."] = function(ast, scope, parent)
local len = #ast
assertCompile(len > 1, "expected table argument", ast)
local lhs = compile1(ast[2], scope, parent, {nval = 1})
@@ -1456,51 +1546,45 @@ SPECIALS['.'] = function(ast, scope, parent)
end
end
end
-docSpecial('.', {'tbl', 'key1', '...'},
- 'Look up key1 in tbl table. If more args are provided, do a nested lookup.')
+docSpecial(".", {"tbl", "key1", "..."},
+ "Look up key1 in tbl table. If more args are provided, do a nested lookup.")
-SPECIALS['global'] = function(ast, scope, parent)
+SPECIALS["global"] = function(ast, scope, parent)
assertCompile(#ast == 3, "expected name and value", ast)
- -- globals tracking doesn't currently work with multi-values/destructuring
- if allowedGlobals and isSym(ast[2]) then
- for _,global in ipairs(isList(ast[2]) and ast[2] or {ast[2]}) do
- table.insert(allowedGlobals, deref(global))
- end
- end
destructure(ast[2], ast[3], ast, scope, parent, {
nomulti = true,
forceglobal = true
})
end
-docSpecial('global', {'name', 'val'}, 'Set name as a global with val.')
+docSpecial("global", {"name", "val"}, "Set name as a global with val.")
-SPECIALS['set'] = function(ast, scope, parent)
+SPECIALS["set"] = function(ast, scope, parent)
assertCompile(#ast == 3, "expected name and value", ast)
destructure(ast[2], ast[3], ast, scope, parent, {
noundef = true
})
end
-docSpecial('set', {'name', 'val'},
- 'Set a local variable to a new value. Only works on locals using var.')
+docSpecial("set", {"name", "val"},
+ "Set a local variable to a new value. Only works on locals using var.")
-SPECIALS['set-forcibly!'] = function(ast, scope, parent)
+SPECIALS["set-forcibly!"] = function(ast, scope, parent)
assertCompile(#ast == 3, "expected name and value", ast)
destructure(ast[2], ast[3], ast, scope, parent, {
forceset = true
})
end
-SPECIALS['local'] = function(ast, scope, parent)
+SPECIALS["local"] = function(ast, scope, parent)
assertCompile(#ast == 3, "expected name and value", ast)
destructure(ast[2], ast[3], ast, scope, parent, {
declaration = true,
nomulti = true
})
end
-docSpecial('local', {'name', 'val'},
- 'Introduce new top-level immutable local.')
+docSpecial("local", {"name", "val"},
+ "Introduce new top-level immutable local.")
-SPECIALS['var'] = function(ast, scope, parent)
+SPECIALS["var"] = function(ast, scope, parent)
assertCompile(#ast == 3, "expected name and value", ast)
destructure(ast[2], ast[3], ast, scope, parent, {
declaration = true,
@@ -1508,16 +1592,16 @@ SPECIALS['var'] = function(ast, scope, parent)
isvar = true
})
end
-docSpecial('var', {'name', 'val'},
- 'Introduce new mutable local.')
+docSpecial("var", {"name", "val"},
+ "Introduce new mutable local.")
-SPECIALS['let'] = function(ast, scope, parent, opts)
+SPECIALS["let"] = function(ast, scope, parent, opts)
local bindings = ast[2]
assertCompile(isList(bindings) or isTable(bindings),
- 'expected table for destructuring', ast)
+ "expected table for destructuring", ast)
assertCompile(#bindings % 2 == 0,
- 'expected even number of name/value bindings', ast)
- assertCompile(#ast >= 3, 'missing body expression', ast)
+ "expected even number of name/value bindings", ast)
+ assertCompile(#ast >= 3, "missing body expression", ast)
local subScope = makeScope(scope)
local subChunk = {}
for i = 1, #bindings, 2 do
@@ -1528,12 +1612,12 @@ SPECIALS['let'] = function(ast, scope, parent, opts)
end
return doImpl(ast, scope, parent, opts, 3, subChunk, subScope)
end
-docSpecial('let', {'[name1 val1 ... nameN valN]', '...'},
- 'Introduces a new scope in which a given set of local bindings are used.')
+docSpecial("let", {"[name1 val1 ... nameN valN]", "..."},
+ "Introduces a new scope in which a given set of local bindings are used.")
-- For setting items in a table
-SPECIALS['tset'] = function(ast, scope, parent)
- assertCompile(#ast > 3, ('tset form needs table, key, and value'), ast)
+SPECIALS["tset"] = function(ast, scope, parent)
+ assertCompile(#ast > 3, ("tset form needs table, key, and value"), ast)
local root = compile1(ast[2], scope, parent, {nval = 1})[1]
local keys = {}
for i = 3, #ast - 1 do
@@ -1543,17 +1627,18 @@ SPECIALS['tset'] = function(ast, scope, parent)
local value = compile1(ast[#ast], scope, parent, {nval = 1})[1]
local rootstr = tostring(root)
-- Prefix 'do end ' so parens are not ambiguous (grouping or function call?)
- local fmtstr = (rootstr:match('^{')) and 'do end (%s)[%s] = %s' or '%s[%s] = %s'
+ local fmtstr = (rootstr:match("^{")) and "do end (%s)[%s] = %s" or "%s[%s] = %s"
emit(parent, fmtstr:format(tostring(root),
table.concat(keys, ']['),
tostring(value)), ast)
end
-docSpecial('tset', {'tbl', 'key1', 'val1', '...', 'keyN', 'valN'},
- 'Set the fields of a table to new values. Takes 1 or more key/value pairs.')
+docSpecial("tset", {"tbl", "key1", "...", "keyN", "val"},
+ "Set the value of a table field. Can take additional keys to set"
+ .. "nested values,\nbut all parents must contain an existing table.")
-- The if special form behaves like the cond form in
-- many languages
-SPECIALS['if'] = function(ast, scope, parent, opts)
+SPECIALS["if"] = function(ast, scope, parent, opts)
local doScope = makeScope(scope)
local branches = {}
local elseBranch = nil
@@ -1635,6 +1720,10 @@ SPECIALS['if'] = function(ast, scope, parent, opts)
if hasElse then
emit(lastBuffer, 'else', ast)
emit(lastBuffer, elseBranch.chunk, ast)
+ -- TODO: Consolidate use of condLine ~= "else" with hasElse
+ elseif(innerTarget and condLine ~= 'else') then
+ emit(lastBuffer, 'else', ast)
+ emit(lastBuffer, ("%s = nil"):format(innerTarget), ast)
end
emit(lastBuffer, 'end', ast)
elseif not branches[i + 1].nested then
@@ -1666,60 +1755,63 @@ SPECIALS['if'] = function(ast, scope, parent, opts)
return targetExprs
end
end
-docSpecial('if', {'cond1', 'body1', '...', 'condN', 'bodyN'},
- 'Conditional form.\n' ..
- 'Takes any number of condition/body pairs and evaluates the first body where'
- .. '\nthe condition evaluates to truthy. Similar to cond in other lisps.')
+docSpecial("if", {"cond1", "body1", "...", "condN", "bodyN"},
+ "Conditional form.\n" ..
+ "Takes any number of condition/body pairs and evaluates the first body where"
+ .. "\nthe condition evaluates to truthy. Similar to cond in other lisps.")
-- (each [k v (pairs t)] body...) => []
-SPECIALS['each'] = function(ast, scope, parent)
- local binding = assertCompile(isTable(ast[2]), 'expected binding table', ast)
+SPECIALS["each"] = function(ast, scope, parent)
+ local binding = assertCompile(isTable(ast[2]), "expected binding table", ast)
local iter = table.remove(binding, #binding) -- last item is iterator call
- local bindVars = {}
local destructures = {}
- for _, v in ipairs(binding) do
- assertCompile(isSym(v) or isTable(v),
- 'expected iterator symbol or table', ast)
- if(isSym(v)) then
- table.insert(bindVars, declareLocal(v, {}, scope, ast))
+ local newManglings = {}
+ local function destructureBinding(v)
+ assertCompile(isSym(v) or isTable(v), "expected iterator symbol or table", ast)
+ if isSym(v) then
+ return declareLocal(v, {}, scope, ast, newManglings)
else
local raw = sym(gensym(scope))
destructures[raw] = v
- table.insert(bindVars, declareLocal(raw, {}, scope, ast))
+ return declareLocal(raw, {}, scope, ast)
end
end
- emit(parent, ('for %s in %s do'):format(
- table.concat(bindVars, ', '),
- tostring(compile1(iter, scope, parent, {nval = 1})[1])), ast)
+ local bindVars = map(binding, destructureBinding)
+ local vals = compile1(iter, scope, parent)
+ local valNames = map(vals, tostring)
+
+ emit(parent, ('for %s in %s do'):format(table.concat(bindVars, ', '),
+ table.concat(valNames, ", ")), ast)
local chunk = {}
for raw, args in pairs(destructures) do
destructure(args, raw, ast, scope, chunk,
{ declaration = true, nomulti = true })
end
+ applyManglings(scope, newManglings, ast)
compileDo(ast, scope, chunk, 3)
emit(parent, chunk, ast)
emit(parent, 'end', ast)
end
-docSpecial('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.')
+docSpecial("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.")
-- (while condition body...) => []
-SPECIALS['while'] = function(ast, scope, parent)
+SPECIALS["while"] = function(ast, scope, parent)
local len1 = #parent
local condition = compile1(ast[2], scope, parent, {nval = 1})[1]
local len2 = #parent
local subChunk = {}
if len1 ~= len2 then
-- Compound condition
- emit(parent, 'while true do', ast)
-- Move new compilation to subchunk
for i = len1 + 1, len2 do
subChunk[#subChunk + 1] = parent[i]
parent[i] = nil
end
- emit(parent, ('if %s then break end'):format(condition[1]), ast)
+ emit(parent, 'while true do', ast)
+ emit(subChunk, ('if not %s then break end'):format(condition[1]), ast)
else
-- Simple condition
emit(parent, 'while ' .. tostring(condition) .. ' do', ast)
@@ -1728,13 +1820,13 @@ SPECIALS['while'] = function(ast, scope, parent)
emit(parent, subChunk, ast)
emit(parent, 'end', ast)
end
-docSpecial('while', {'condition', '...'},
- 'The classic while loop. Evaluates body until a condition is non-truthy.')
+docSpecial("while", {"condition", "..."},
+ "The classic while loop. Evaluates body until a condition is non-truthy.")
-SPECIALS['for'] = function(ast, scope, parent)
- local ranges = assertCompile(isTable(ast[2]), 'expected binding table', ast)
+SPECIALS["for"] = function(ast, scope, parent)
+ local ranges = assertCompile(isTable(ast[2]), "expected binding table", ast)
local bindingSym = assertCompile(isSym(table.remove(ast[2], 1)),
- 'expected iterator symbol', ast)
+ "expected iterator symbol", ast)
local rangeArgs = {}
for i = 1, math.min(#ranges, 3) do
rangeArgs[i] = tostring(compile1(ranges[i], scope, parent, {nval = 1})[1])
@@ -1747,11 +1839,11 @@ SPECIALS['for'] = function(ast, scope, parent)
emit(parent, chunk, ast)
emit(parent, 'end', ast)
end
-docSpecial('for', {'[index start stop step?]', '...'}, 'Numeric loop construct.' ..
- '\nEvaluates body once for each value between start and stop (inclusive).')
+docSpecial("for", {"[index start stop step?]", "..."}, "Numeric loop construct." ..
+ "\nEvaluates body once for each value between start and stop (inclusive).")
-SPECIALS[':'] = function(ast, scope, parent)
- assertCompile(#ast >= 3, 'expected at least 3 arguments', ast)
+SPECIALS[":"] = function(ast, scope, parent)
+ assertCompile(#ast >= 3, "expected at least 3 arguments", ast)
-- Compile object
local objectexpr = compile1(ast[2], scope, parent, {nval = 1})[1]
-- Compile method selector
@@ -1770,9 +1862,7 @@ SPECIALS[':'] = function(ast, scope, parent)
local subexprs = compile1(ast[i], scope, parent, {
nval = i ~= #ast and 1 or nil
})
- for j = 1, #subexprs do
- args[#args + 1] = tostring(subexprs[j])
- end
+ map(subexprs, tostring, args)
end
local fstring
if not methodident then
@@ -1791,21 +1881,21 @@ SPECIALS[':'] = function(ast, scope, parent)
methodstring,
table.concat(args, ', ')), 'statement')
end
-docSpecial(':', {'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.')
+docSpecial(":", {"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.")
-SPECIALS['comment'] = function(ast, _, parent)
+SPECIALS["comment"] = function(ast, _, parent)
local els = {}
for i = 2, #ast do
els[#els + 1] = tostring(ast[i]):gsub('\n', ' ')
end
emit(parent, ' -- ' .. table.concat(els, ' '), ast)
end
-docSpecial('comment', {'...'}, 'Comment which will be emitted in Lua output.')
+docSpecial("comment", {"..."}, "Comment which will be emitted in Lua output.")
-SPECIALS['hashfn'] = function(ast, scope, parent)
+SPECIALS["hashfn"] = function(ast, scope, parent)
assertCompile(#ast == 2, "expected one argument", ast)
local fScope = makeScope(scope)
local fChunk = {}
@@ -1826,7 +1916,7 @@ SPECIALS['hashfn'] = function(ast, scope, parent)
emit(parent, 'end', ast)
return expr(name, 'sym')
end
-docSpecial('hashfn', {'...'}, 'Function literal shorthand; args are $1, $2, etc.')
+docSpecial("hashfn", {"..."}, "Function literal shorthand; args are $1, $2, etc.")
local function defineArithmeticSpecial(name, zeroArity, unaryPrefix)
local paddedOp = ' ' .. name .. ' '
@@ -1841,9 +1931,7 @@ local function defineArithmeticSpecial(name, zeroArity, unaryPrefix)
local subexprs = compile1(ast[i], scope, parent, {
nval = (i == 1 and 1 or nil)
})
- for j = 1, #subexprs do
- operands[#operands + 1] = tostring(subexprs[j])
- end
+ map(subexprs, tostring, operands)
end
if #operands == 1 then
if unaryPrefix then
@@ -1856,8 +1944,8 @@ local function defineArithmeticSpecial(name, zeroArity, unaryPrefix)
end
end
end
- docSpecial(name, {'a', 'b', '...'},
- 'Arithmetic operator; works the same as Lua but accepts more arguments.')
+ docSpecial(name, {"a", "b", "..."},
+ "Arithmetic operator; works the same as Lua but accepts more arguments.")
end
defineArithmeticSpecial('+', '0')
@@ -1871,18 +1959,18 @@ defineArithmeticSpecial('//', nil, '1')
defineArithmeticSpecial('or', 'false')
defineArithmeticSpecial('and', 'true')
-docSpecial('and', {'a', 'b', '...'},
- 'Boolean operator; works the same as Lua but accepts more arguments.')
-docSpecial('or', {'a', 'b', '...'},
- 'Boolean operator; works the same as Lua but accepts more arguments.')
-docSpecial('..', {'a', 'b', '...'},
- 'String concatenation operator; works the same as Lua but accepts more arguments.')
+docSpecial("and", {"a", "b", "..."},
+ "Boolean operator; works the same as Lua but accepts more arguments.")
+docSpecial("or", {"a", "b", "..."},
+ "Boolean operator; works the same as Lua but accepts more arguments.")
+docSpecial("..", {"a", "b", "..."},
+ "String concatenation operator; works the same as Lua but accepts more arguments.")
local function defineComparatorSpecial(name, realop, chainOp)
local op = realop or name
SPECIALS[name] = function(ast, scope, parent)
local len = #ast
- assertCompile(len > 2, 'expected at least two arguments', ast)
+ assertCompile(len > 2, "expected at least two arguments", ast)
local lhs = compile1(ast[2], scope, parent, {nval = 1})[1]
local lastval = compile1(ast[3], scope, parent, {nval = 1})[1]
-- avoid double-eval by introducing locals for possible side-effects
@@ -1901,8 +1989,8 @@ local function defineComparatorSpecial(name, realop, chainOp)
end
return out
end
- docSpecial(name, {name, 'a', 'b', '...'},
- 'Comparison operator; works the same as Lua but accepts more arguments.')
+ docSpecial(name, {"a", "b", "..."},
+ "Comparison operator; works the same as Lua but accepts more arguments.")
end
defineComparatorSpecial('>')
@@ -1921,12 +2009,12 @@ local function defineUnarySpecial(op, realop)
end
end
-defineUnarySpecial('not', 'not ')
-docSpecial('not', {'x'}, 'Boolean operator; works the same as Lua.')
+defineUnarySpecial("not", "not ")
+docSpecial("not", {"x"}, "Logical operator; works the same as Lua.")
-defineUnarySpecial('length', '#')
-docSpecial('length', {'x'}, 'Returns the length of a table or string.')
-SPECIALS['#'] = SPECIALS['length']
+defineUnarySpecial("length", "#")
+docSpecial("length", {"x"}, "Returns the length of a table or string.")
+SPECIALS["#"] = SPECIALS["length"]
-- Save current macro scope
local macroCurrentScope = GLOBAL_SCOPE
@@ -1951,38 +2039,20 @@ end
local requireSpecial
local function compile(ast, options)
- options = options or {}
+ local opts = copy(options)
local oldGlobals = allowedGlobals
- local oldChunk = rootChunk
- local oldScope = rootScope
- local oldOptions = rootOptions
- allowedGlobals = options.allowedGlobals
- if options.indent == nil then options.indent = ' ' end
+ setResetRoot(rootChunk, rootScope, rootOptions)
+ allowedGlobals = opts.allowedGlobals
+ if opts.indent == nil then opts.indent = ' ' end
local chunk = {}
- local scope = options.scope or makeScope(GLOBAL_SCOPE)
- rootChunk = chunk
- rootScope = scope
- rootOptions = options
- if options.requireAsInclude then scope.specials.require = requireSpecial end
+ local scope = opts.scope or makeScope(GLOBAL_SCOPE)
+ rootChunk, rootScope, rootOptions = chunk, scope, opts
+ if opts.requireAsInclude then scope.specials.require = requireSpecial end
local exprs = compile1(ast, scope, chunk, {tail = true})
keepSideEffects(exprs, chunk, nil, ast)
allowedGlobals = oldGlobals
- rootChunk = oldChunk
- rootScope = oldScope
- rootOptions = oldOptions
- return flatten(chunk, options)
-end
-
--- map a function across all pairs in a table
-local function quoteTmap(f, t)
- local res = {}
- for k,v in pairs(t) do
- local nk, nv = f(k, v)
- if nk then
- res[nk] = nv
- end
- end
- return res
+ resetRoot()
+ return flatten(chunk, opts)
end
-- make a transformer for key / value table pairs, preserving all numeric keys
@@ -2040,11 +2110,11 @@ local function doQuote (form, scope, parent, runtime)
-- list
elseif isList(form) then
assertCompile(not runtime, "lists may only be used at compile time", form)
- local mapped = quoteTmap(entryTransform(no, q), form)
+ local mapped = kvmap(form, entryTransform(no, q))
return 'list(' .. mixedConcat(mapped, ", ") .. ')'
-- table
elseif type(form) == 'table' then
- local mapped = quoteTmap(entryTransform(q, q), form)
+ local mapped = kvmap(form, entryTransform(q, q))
return '{' .. mixedConcat(mapped, ", ") .. '}'
-- string
elseif type(form) == 'string' then
@@ -2066,24 +2136,20 @@ end
docSpecial('quote', {'x'}, 'Quasiquote the following form. Only works in macro/compiler scope.')
local function compileStream(strm, options)
- options = options or {}
+ local opts = copy(options)
local oldGlobals = allowedGlobals
- local oldChunk = rootChunk
- local oldScope = rootScope
- local oldOptions = rootOptions
- allowedGlobals = options.allowedGlobals
- if options.indent == nil then options.indent = ' ' end
- local scope = options.scope or makeScope(GLOBAL_SCOPE)
- if options.requireAsInclude then scope.specials.require = requireSpecial end
+ setResetRoot(rootChunk, rootScope, rootOptions)
+ allowedGlobals = opts.allowedGlobals
+ if opts.indent == nil then opts.indent = ' ' end
+ local scope = opts.scope or makeScope(GLOBAL_SCOPE)
+ if opts.requireAsInclude then scope.specials.require = requireSpecial end
local vals = {}
- for ok, val in parser(strm, options.filename) do
+ for ok, val in parser(strm, opts.filename) do
if not ok then break end
vals[#vals + 1] = val
end
local chunk = {}
- rootChunk = chunk
- rootScope = scope
- rootOptions = options
+ rootChunk, rootScope, rootOptions = chunk, scope, opts
for i = 1, #vals do
local exprs = compile1(vals[i], scope, chunk, {
tail = i == #vals,
@@ -2091,10 +2157,8 @@ local function compileStream(strm, options)
keepSideEffects(exprs, chunk, nil, vals[i])
end
allowedGlobals = oldGlobals
- rootChunk = oldChunk
- rootScope = oldScope
- rootOptions = oldOptions
- return flatten(chunk, options)
+ resetRoot()
+ return flatten(chunk, opts)
end
local function compileString(str, options)
@@ -2127,14 +2191,10 @@ local function wrapEnv(env)
-- checking the __pairs metamethod won't work automatically in Lua 5.1
-- sadly, but it's important for 5.2+ and can be done manually in 5.1
__pairs = function()
- local pt = {}
- for key, value in pairs(env) do
- if type(key) == 'string' then
- pt[globalUnmangling(key)] = value
- else
- pt[key] = value
- end
+ local function putenv(k, v)
+ return type(k) == 'string' and globalUnmangling(k) or k, v
end
+ local pt = kvmap(env, putenv)
return next, pt, nil
end,
})
@@ -2147,8 +2207,12 @@ local function traceback(msg, start)
local level = start or 2 -- Can be used to skip some frames
local lines = {}
if msg then
- local stripped = msg:gsub('^[^:]*:%d+:%s+', 'runtime error: ')
- table.insert(lines, stripped)
+ if msg:find("^Compile error") then
+ table.insert(lines, msg)
+ else
+ local newmsg = msg:gsub('^[^:]*:%d+:%s+', 'runtime error: ')
+ table.insert(lines, newmsg)
+ end
end
table.insert(lines, 'stack traceback:')
while true do
@@ -2187,212 +2251,44 @@ local function traceback(msg, start)
end
local function currentGlobalNames(env)
- local names = {}
- for k in pairs(env or _G) do
- k = globalUnmangling(k)
- table.insert(names, k)
- end
- return names
+ return kvmap(env or _G, globalUnmangling)
end
local function eval(str, options, ...)
- options = options or {}
+ local opts = copy(options)
-- eval and dofile are considered "live" entry points, so we can assume
-- that the globals available at compile time are a reasonable allowed list
-- UNLESS there's a metatable on env, in which case we can't assume that
-- pairs will return all the effective globals; for instance openresty
-- sets up _G in such a way that all the globals are available thru
-- the __index meta method, but as far as pairs is concerned it's empty.
- if options.allowedGlobals == nil and not getmetatable(options.env) then
- options.allowedGlobals = currentGlobalNames(options.env)
+ if opts.allowedGlobals == nil and not getmetatable(opts.env) then
+ opts.allowedGlobals = currentGlobalNames(opts.env)
end
- local env = options.env and wrapEnv(options.env)
- local luaSource = compileString(str, options)
+ local env = opts.env and wrapEnv(opts.env)
+ local luaSource = compileString(str, opts)
local loader = loadCode(luaSource, env,
- options.filename and ('@' .. options.filename) or str)
+ opts.filename and ('@' .. opts.filename) or str)
+ opts.filename = nil
return loader(...)
end
local function dofileFennel(filename, options, ...)
- options = options or {}
- if options.allowedGlobals == nil then
- options.allowedGlobals = currentGlobalNames(options.env)
+ local opts = copy(options)
+ if opts.allowedGlobals == nil then
+ opts.allowedGlobals = currentGlobalNames(opts.env)
end
local f = assert(io.open(filename, "rb"))
local source = f:read("*all"):gsub("^#![^\n]*\n", "")
f:close()
- options.filename = options.filename or filename
- return eval(source, options, ...)
-end
-
--- Implements a configurable repl
-local function repl(options)
-
- local opts = options or {}
- -- This would get set for us when calling eval, but we want to seed it
- -- with a value that is persistent so it doesn't get reset on each eval.
- if opts.allowedGlobals == nil then
- opts.allowedGlobals = currentGlobalNames(opts.env)
- end
-
- opts.useMetadata = options.useMetadata ~= false
- opts.moduleName = options.moduleName
- rootOptions = opts
-
- local env = opts.env and wrapEnv(opts.env) or setmetatable({}, {
- __index = _ENV or _G
- })
-
- local function defaultReadChunk(parserState)
- io.write(parserState.stackSize > 0 and '.. ' or '>> ')
- io.flush()
- local input = io.read()
- return input and input .. '\n'
- end
-
- local function defaultOnValues(xs)
- io.write(table.concat(xs, '\t'))
- io.write('\n')
- end
-
- local function defaultOnError(errtype, err, luaSource)
- if (errtype == 'Lua Compile') then
- io.write('Bad code generated - likely a bug with the compiler:\n')
- io.write('--- Generated Lua Start ---\n')
- io.write(luaSource .. '\n')
- io.write('--- Generated Lua End ---\n')
- end
- if (errtype == 'Runtime') then
- io.write(traceback(err, 4))
- io.write('\n')
- else
- io.write(('%s error: %s\n'):format(errtype, tostring(err)))
- end
- end
-
- local envdbg = (opts.env or _G)["debug"]
- -- if the environment doesn't support debug.getlocal you can't save locals
- local saveLocals = opts.saveLocals ~= false and envdbg and envdbg.getlocal
- local saveSource = table.
- concat({"local ___i___ = 1",
- "while true do",
- " local name, value = debug.getlocal(1, ___i___)",
- " if(name and name ~= \"___i___\") then",
- " ___replLocals___[name] = value",
- " ___i___ = ___i___ + 1",
- " else break end end"}, "\n")
-
- -- we do some source munging in order to save off locals from each chunk
- -- and reintroduce them to the beginning of the next chunk, allowing
- -- locals to work in the repl the way you'd expect them to.
- local spliceSaveLocals = function(luaSource)
- env.___replLocals___ = env.___replLocals___ or {}
- local splicedSource = {}
- for line in luaSource:gmatch("([^\n]+)\n?") do
- table.insert(splicedSource, line)
- end
- -- reintroduce locals from the previous time around
- local bind = "local %s = ___replLocals___['%s']"
- for name in pairs(env.___replLocals___) do
- table.insert(splicedSource, 1, bind:format(name, name))
- end
- -- save off new locals at the end - if safe to do so (i.e. last line is a return)
- if (string.match(splicedSource[#splicedSource], "^ *return .*$")) then
- if (#splicedSource > 1) then
- table.insert(splicedSource, #splicedSource, saveSource)
- end
- end
- return table.concat(splicedSource, "\n")
- end
-
- -- Read options
- local readChunk = opts.readChunk or defaultReadChunk
- local onValues = opts.onValues or defaultOnValues
- local onError = opts.onError or defaultOnError
- local pp = opts.pp or tostring
-
- -- Make parser
- local bytestream, clearstream = granulate(readChunk)
- local chars = {}
- local read, reset = parser(function (parserState)
- local c = bytestream(parserState)
- chars[#chars + 1] = c
- return c
- end)
-
- local scope = makeScope(GLOBAL_SCOPE)
-
- local replCompleter = function(text)
- local matches = {}
- local inputFragment = text:gsub("[%s)(]*(.+)", "%1")
-
- -- adds any matching keys from the provided generator/iterator to matches
- local function addMatchesFromGen(next, param, state)
- for k in next, param, state do
- if #matches >= 40 then break -- cap completions at 40 to avoid overwhelming
- elseif inputFragment == k:sub(0, #inputFragment) then
- table.insert(matches, k)
- end
- end
- end
- addMatchesFromGen(pairs(env._ENV or env._G or {}))
- addMatchesFromGen(pairs(env.___replLocals___ or {}))
- addMatchesFromGen(pairs(SPECIALS or {}))
- addMatchesFromGen(pairs(scope.specials or {}))
- return matches
- end
- if opts.registerCompleter then opts.registerCompleter(replCompleter) end
-
- -- REPL loop
- while true do
- chars = {}
- local ok, parseok, x = pcall(read)
- local srcstring = string.char(unpack(chars))
- if not ok then
- onError('Parse', parseok)
- clearstream()
- reset()
- else
- if not parseok then break end -- eof
- local compileOk, luaSource = pcall(compile, x, {
- correlate = opts.correlate,
- source = srcstring,
- scope = scope,
- useMetadata = opts.useMetadata,
- moduleName = opts.moduleName,
- })
- if not compileOk then
- clearstream()
- onError('Compile', luaSource) -- luaSource is error message in this case
- else
- if saveLocals then
- luaSource = spliceSaveLocals(luaSource)
- end
- local luacompileok, loader = pcall(loadCode, luaSource, env)
- if not luacompileok then
- clearstream()
- onError('Lua Compile', loader, luaSource)
- else
- local loadok, ret = xpcall(function () return {loader()} end,
- function (runtimeErr)
- onError('Runtime', runtimeErr)
- end)
- if loadok then
- env._ = ret[1]
- env.__ = ret
- for i = 1, #ret do ret[i] = pp(ret[i]) end
- onValues(ret)
- end
- end
- end
- end
- end
+ opts.filename = filename
+ return eval(source, opts, ...)
end
local macroLoaded = {}
local pathTable = {"./?.fnl", "./?/init.fnl"}
-local osPath = os.getenv("FENNEL_PATH")
+local osPath = os and os.getenv and os.getenv("FENNEL_PATH")
if osPath then
table.insert(pathTable, osPath)
end
@@ -2405,6 +2301,7 @@ local module = {
compileString = compileString,
compileStream = compileStream,
compile1 = compile1,
+ loadCode = loadCode,
mangle = globalMangling,
unmangle = globalUnmangling,
list = list,
@@ -2413,14 +2310,166 @@ local module = {
scope = makeScope,
gensym = gensym,
eval = eval,
- repl = repl,
dofile = dofileFennel,
macroLoaded = macroLoaded,
path = table.concat(pathTable, ";"),
traceback = traceback,
- version = "0.3.0",
+ version = "0.4.0-dev",
}
+-- In order to make this more readable, you can switch your editor to treating
+-- this file as if it were Fennel for the purposes of this section
+local replsource = [===[(local (fennel internals) ...)
+
+(fn default-read-chunk [parser-state]
+ (io.write (if (< 0 parser-state.stackSize) ".." ">> "))
+ (io.flush)
+ (let [input (io.read)]
+ (and input (.. input "\n"))))
+
+(fn default-on-values [xs]
+ (io.write (table.concat xs "\t"))
+ (io.write "\n"))
+
+(fn default-on-error [errtype err lua-source]
+ (io.write
+ (match errtype
+ "Lua Compile" (.. "Bad code generated - likely a bug with the compiler:\n"
+ "--- Generated Lua Start ---\n"
+ lua-source
+ "--- Generated Lua End ---\n")
+ "Runtime" (.. (fennel.traceback err 4) "\n")
+ _ (: "%s error: %s\n" :format errtype (tostring err)))))
+
+(local save-source
+ (table.concat ["local ___i___ = 1"
+ "while true do"
+ " local name, value = debug.getlocal(1, ___i___)"
+ " if(name and name ~= \"___i___\") then"
+ " ___replLocals___[name] = value"
+ " ___i___ = ___i___ + 1"
+ " else break end end"] "\n"))
+
+(fn splice-save-locals [env lua-source]
+ (set env.___replLocals___ (or env.___replLocals___ {}))
+ (let [spliced-source []
+ bind "local %s = ___replLocals___['%s']"]
+ (each [line (lua-source:gmatch "([^\n]+)\n?")]
+ (table.insert spliced-source line))
+ (each [name (pairs env.___replLocals___)]
+ (table.insert spliced-source 1 (bind:format name name)))
+ (when (and (: (. spliced-source (# spliced-source)) :match "^ *return .*$")
+ (< 1 (# spliced-source)))
+ (table.insert spliced-source (# spliced-source) save-source))
+ (table.concat spliced-source "\n")))
+
+(fn completer [env scope text]
+ (let [matches []
+ input-fragment (text:gsub ".*[%s)(]+" "")]
+ (fn add-partials [input tbl prefix] ; add partial key matches in tbl
+ (each [k (pairs tbl)]
+ (let [k (if (or (= tbl env) (= tbl env.___replLocals___))
+ (. scope.unmanglings k)
+ k)]
+ (when (and (< (# matches) 40)
+ (= (type k) "string")
+ (= input (k:sub 0 (# input))))
+ (table.insert matches (.. prefix k))))))
+ (fn add-matches [input tbl prefix] ; add matches, descending into tbl fields
+ (let [prefix (if prefix (.. prefix ".") "")]
+ (if (not (input:find "%.")) ; no more dots, so add matches
+ (add-partials input tbl prefix)
+ (let [(head tail) (input:match "^([^.]+)%.(.*)")
+ raw-head (if (or (= tbl env) (= tbl env.___replLocals___))
+ (. scope.manglings head)
+ head)]
+ (when (= (type (. tbl raw-head)) "table")
+ (add-matches tail (. tbl raw-head) (.. prefix head)))))))
+
+ (add-matches input-fragment (or scope.specials []))
+ (add-matches input-fragment (or internals.SPECIALS []))
+ (add-matches input-fragment (or env.___replLocals___ []))
+ (add-matches input-fragment env)
+ (add-matches input-fragment (or env._ENV env._G []))
+ matches))
+
+(fn repl [options]
+ (let [old-root-options internals.rootOptions
+ env (if options.env
+ (internals.wrapEnv options.env)
+ (setmetatable {} {:__index (or _G._ENV _G)}))
+ save-locals? (and (not= options.saveLocals false)
+ env.debug env.debug.getlocal)
+ opts {}
+ _ (each [k v (pairs options)] (tset opts k v))
+ read-chunk (or opts.readChunk default-read-chunk)
+ on-values (or opts.onValues default-on-values)
+ on-error (or opts.onError default-on-error)
+ pp (or opts.pp tostring)
+ ;; make parser
+ (byte-stream clear-stream) (fennel.granulate read-chunk)
+ chars []
+ (read reset) (fennel.parser (fn [parser-state]
+ (let [c (byte-stream parser-state)]
+ (tset chars (+ (# chars) 1) c)
+ c)))
+ scope (fennel.scope)]
+
+ ;; use metadata unless we've specifically disabled it
+ (set opts.useMetadata (not= options.useMetadata false))
+ (when (= opts.allowedGlobals nil)
+ (set opts.allowedGlobals (internals.currentGlobalNames opts.env)))
+
+ (when opts.registerCompleter
+ (opts.registerCompleter (partial completer env scope)))
+
+ (fn loop []
+ (each [k (pairs chars)] (tset chars k nil))
+ (let [(ok parse-ok? x) (pcall read)
+ src-string (string.char ((or _G.unpack table.unpack) chars))]
+ (internals.setRootOptions opts)
+ (if (not ok)
+ (do (on-error "Parse" parse-ok?)
+ (clear-stream)
+ (reset)
+ (loop))
+ (when parse-ok? ; if this is false, we got eof
+ (match (pcall fennel.compile x {:correlate opts.correlate
+ :source src-string
+ :scope scope
+ :useMetadata opts.useMetadata
+ :moduleName opts.moduleName})
+ (false msg) (do (clear-stream)
+ (on-error "Compile" msg))
+ (true source) (let [source (if save-locals?
+ (splice-save-locals env source)
+ source)
+ (lua-ok? loader) (pcall fennel.loadCode
+ source env)]
+ (if (not lua-ok?)
+ (do (clear-stream)
+ (on-error "Lua Compile" loader source))
+ (match (xpcall #[(loader)]
+ (partial on-error "Runtime"))
+ (true ret)
+ (do (set env._ (. ret 1))
+ (set env.__ ret)
+ (on-values (internals.map ret pp)))))))
+ (internals.setRootOptions old-root-options)
+ (loop)))))
+ (loop)))]===]
+
+module.repl = function(options)
+ -- functionality the repl needs that isn't part of the public API yet
+ local internals = { rootOptions = rootOptions,
+ setRootOptions = function(r) rootOptions = r end,
+ currentGlobalNames = currentGlobalNames,
+ wrapEnv = wrapEnv,
+ SPECIALS = SPECIALS,
+ map = map }
+ return eval(replsource, { correlate = true }, module, internals)(options)
+end
+
local function searchModule(modulename, pathstring)
modulename = modulename:gsub("%.", "/")
for path in string.gmatch((pathstring or module.path)..";", "([^;]*);") do
@@ -2438,8 +2487,7 @@ module.makeSearcher = function(options)
-- this will propagate options from the repl but not from eval, because
-- eval unsets rootOptions after compiling but before running the actual
-- calls to require.
- local opts = {}
- for k,v in pairs(rootOptions or {}) do opts[k] = v end
+ local opts = copy(rootOptions)
for k,v in pairs(options or {}) do opts[k] = v end
local filename = searchModule(modulename)
if filename then
@@ -2490,24 +2538,14 @@ local function makeCompilerEnv(ast, scope, parent)
end
local function macroGlobals(env, globals)
- local allowed = {}
- for k in pairs(env) do
- local g = globalUnmangling(k)
- table.insert(allowed, g)
- end
- if globals then
- for _, k in pairs(globals) do
- table.insert(allowed, k)
- end
- end
+ local allowed = currentGlobalNames(env)
+ for _, k in pairs(globals or {}) do table.insert(allowed, k) end
return allowed
end
local function addMacros(macros, ast, scope)
assertCompile(isTable(macros), 'expected macros to be table', ast)
- for k, v in pairs(macros) do
- scope.specials[k] = macroToSpecial(v)
- end
+ kvmap(macros, function(k, v) return k, macroToSpecial(v) end, scope.specials)
end
local function loadMacros(modname, ast, scope, parent)
@@ -2548,10 +2586,7 @@ SPECIALS['include'] = function(ast, scope, parent, opts)
local mod = loadCode(code)()
-- Check cache
- local includeExpr = scope.includes[mod]
- if includeExpr then
- return includeExpr
- end
+ if scope.includes[mod] then return scope.includes[mod] end
-- Find path to source
local path = searchModule(mod)
@@ -2573,32 +2608,45 @@ SPECIALS['include'] = function(ast, scope, parent, opts)
local s = f:read('*all')
f:close()
- -- splice in source and memoize it
- -- so we can include it again without duplication
- local target = gensym(scope)
- local ret = expr(target, 'sym')
+ -- splice in source and memoize it in compiler AND package.preload
+ -- so we can include it again without duplication, even in runtime
+ local target = 'package.preload["' .. mod .. '"]'
+ local ret = expr('require("' .. mod .. '")', 'statement')
+
+ local subChunk, tempChunk = {}, {}
+ emit(tempChunk, subChunk, ast)
+ -- if lua, simply emit the setting of package.preload
+ if not isFennel then
+ emit(tempChunk, target .. ' = ' .. target .. ' or function()\n' .. s .. 'end', ast)
+ end
+ -- Splice tempChunk to begining of rootChunk
+ for i, v in ipairs(tempChunk) do
+ table.insert(rootChunk, i, v)
+ end
+
+ -- For fnl source, compile subChunk AFTER splicing into start of rootChunk.
if isFennel then
- local p = parser(stringStream(s), path)
- local forms = list(sym('do'))
- for _, val in p do table.insert(forms, val) end
+ local subopts = { nval = 1, target = target }
local subscope = makeScope(rootScope.parent)
if rootOptions.requireAsInclude then
subscope.specials.require = requireSpecial
end
- local subopts = {
- nval = 1,
- target = target
- }
- emit(rootChunk, 'local ' .. target, ast)
- compile1(forms, subscope, rootChunk, subopts)
- else
- emit(rootChunk, 'local ' .. target .. ' = (function() ' .. s .. ' end)()', ast)
+ local targetForm = list(sym('.'), sym('package.preload'), mod)
+ -- splice "or" statement in so it uses existing package.preload[modname]
+ -- if it's been set by something else, allowing for overrides
+ local forms = list(sym('or'), targetForm, list(sym('fn'), sequence()))
+ local p = parser(stringStream(s), path)
+ for _, val in p do table.insert(forms[3], val) end
+ compile1(forms, subscope, subChunk, subopts)
end
-- Put in cache and return
rootScope.includes[mod] = ret
return ret
end
+docSpecial('include', {'module-name-literal'},
+ 'Like require, but load the target module during compilation and embed it in the\n'
+ .. 'Lua output. The module must be a string literal and resolvable at compile time.')
local function requireFallback(e)
local code = ('require(%s)'):format(tostring(e))
@@ -2795,7 +2843,7 @@ that argument name begins with ?."
(do (assert (not (. pattern (+ k 2)))
"expected rest argument in final position")
(table.insert bindings (. pattern (+ k 1)))
- (table.insert bindings [`(select ,k ((or unpack table.unpack)
+ (table.insert bindings [`(select ,k ((or _G.unpack table.unpack)
,val))]))
(and (= :number (type k))
(= "&" (tostring (. pattern (- k 1)))))
@@ -2846,19 +2894,21 @@ do
local moduleName = "__fennel-bootstrap__"
package.preload[moduleName] = function() return module end
local env = makeCompilerEnv(nil, COMPILER_SCOPE, {})
- for name, fn in pairs(eval(stdmacros, {
- env = env,
- scope = makeScope(COMPILER_SCOPE),
- -- assume the code to load globals doesn't have any mistaken globals,
- -- otherwise this can be problematic when loading fennel in contexts
- -- where _G is an empty table with an __index metamethod. (openresty)
- allowedGlobals = false,
- useMetadata = true,
- filename = "built-ins",
- moduleName = moduleName,
- })) do
- SPECIALS[name] = macroToSpecial(fn, name)
- end
+ local macros = eval(stdmacros, {
+ env = env,
+ scope = makeScope(COMPILER_SCOPE),
+ -- assume the code to load globals doesn't have any
+ -- mistaken globals, otherwise this can be
+ -- problematic when loading fennel in contexts
+ -- where _G is an empty table with an __index
+ -- metamethod. (openresty)
+ allowedGlobals = false,
+ useMetadata = true,
+ filename = "built-ins",
+ moduleName = moduleName })
+ kvmap(macros,
+ function(name, fn) return name, macroToSpecial(fn, name) end,
+ SPECIALS)
package.preload[moduleName] = nil
end
SPECIALS['λ'] = SPECIALS['lambda']
diff --git a/lib/fennelview.lua b/lib/fennelview.lua
index 0ecb721..5497cb1 100644
--- a/lib/fennelview.lua
+++ b/lib/fennelview.lua
@@ -15,9 +15,9 @@ do
long_control_char_escapes = long
end
local function escape(str)
- local str = str:gsub("\\", "\\\\")
- local str = str:gsub("(%c)%f[0-9]", long_control_char_escapes)
- return str:gsub("%c", short_control_char_escapes)
+ local str0 = str:gsub("\\", "\\\\")
+ local str1 = str0:gsub("(%c)%f[0-9]", long_control_char_escapes)
+ return str1:gsub("%c", short_control_char_escapes)
end
local function sequence_key_3f(k, len)
return ((type(k) == "number") and (1 <= k) and (k <= len) and (math.floor(k) == k))
@@ -103,11 +103,14 @@ local function put_sequential_table(self, t, len)
puts(self, "[")
self.level = (self.level + 1)
for i = 1, len do
- puts(self, " ")
+ local _0_ = (1 + len)
+ if ((1 < i) and (i < _0_)) then
+ puts(self, " ")
+ end
put_value(self, t[i])
end
self.level = (self.level - 1)
- return puts(self, " ]")
+ return puts(self, "]")
end
local function put_key(self, k)
if ((type(k) == "string") and k:find("^[-%w?\\^_!$%&*+./@:|<=>]+$")) then
@@ -136,10 +139,26 @@ local function put_kv_table(self, t, ordered_keys)
return puts(self, "}")
end
local function put_table(self, t)
+ local metamethod = nil
+ do
+ local _0_0 = t
+ if _0_0 then
+ local _1_0 = getmetatable(_0_0)
+ if _1_0 then
+ metamethod = _1_0.__fennelview
+ else
+ metamethod = _1_0
+ end
+ else
+ metamethod = _0_0
+ end
+ end
if (already_visited_3f(self, t) and self["detect-cycles?"]) then
return puts(self, "#")
elseif (self.level >= self.depth) then
return puts(self, "{...}")
+ elseif metamethod then
+ return puts(self, metamethod(t, self.fennelview))
elseif "else" then
local non_seq_keys, len = get_nonsequential_keys(t)
local id = get_id(self, t)
@@ -172,20 +191,23 @@ local function one_line(str)
return ret
end
local function fennelview(x, options)
- local options = (options or {})
- local inspector = inspector
- local function _1_()
- if options["one-line"] then
+ local options0 = (options or {})
+ local inspector = nil
+ local function _1_(_241)
+ return fennelview(_241, options0)
+ end
+ local function _2_()
+ if options0["one-line"] then
return ""
else
return " "
end
end
- inspector = {["detect-cycles?"] = not (false == options["detect-cycles?"]), ["max-ids"] = {}, appearances = count_table_appearances(x, {}), buffer = {}, depth = (options.depth or 128), ids = {}, indent = (options.indent or _1_()), level = 0}
+ inspector = {["detect-cycles?"] = not (false == options0["detect-cycles?"]), ["max-ids"] = {}, appearances = count_table_appearances(x, {}), buffer = {}, depth = (options0.depth or 128), fennelview = _1_, ids = {}, indent = (options0.indent or _2_()), level = 0}
put_value(inspector, x)
do
local str = table.concat(inspector.buffer)
- if options["one-line"] then
+ if options0["one-line"] then
return one_line(str)
else
return str