From 7ea253bfccd4040fa09e4f38dd18a52e37fe2546 Mon Sep 17 00:00:00 2001 From: Fabien Fleutot Date: Thu, 24 Jan 2008 09:36:12 +0100 Subject: [PATCH] introduced quote hygienizer --- src/compiler/bootstrap.lua | 11 +++- src/compiler/compile.lua | 5 +- src/compiler/metalua.mlua | 34 ++++++---- src/compiler/mlp_meta.lua | 16 +++-- src/lib/H.mlua | 121 ++++++++++++++++++++++++++++++++++ src/lib/dollar.mlua | 5 +- src/lib/walk.mlua | 2 +- src/samples/h_test.mlua | 69 +++++++++++++++++++ src/samples/walk_id_test.mlua | 88 +++++++++++++++++++++++++ 9 files changed, 325 insertions(+), 26 deletions(-) create mode 100644 src/lib/H.mlua create mode 100644 src/samples/h_test.mlua create mode 100644 src/samples/walk_id_test.mlua diff --git a/src/compiler/bootstrap.lua b/src/compiler/bootstrap.lua index b7f08dc..e11f72e 100644 --- a/src/compiler/bootstrap.lua +++ b/src/compiler/bootstrap.lua @@ -30,15 +30,23 @@ package.preload.mlc = function() local func = mlc.function_of_ast(ast) return func end + + function mlc.function_of_luafile (name) + local f = io.open(name, 'r') + local src = f:read '*a' + f:close() + return mlc.function_of_luastring (src, name) + end end +require 'verbose_require' require 'base' require 'bytecode' require 'mlp' require 'package2' local function compile_file (src_filename) - print ("Compiling "..src_filename) + io.write("Compiling "..src_filename.."... ") local src_file = io.open (src_filename, 'r') local src = src_file:read '*a'; src_file:close() local ast = mlc.ast_of_luastring (src) @@ -48,6 +56,7 @@ local function compile_file (src_filename) local dst_file = io.open (dst_filename, 'wb') dst_file:write(dump) dst_file:close() + io.write("OK.") end diff --git a/src/compiler/compile.lua b/src/compiler/compile.lua index 9c893a9..fe1f293 100644 --- a/src/compiler/compile.lua +++ b/src/compiler/compile.lua @@ -1178,7 +1178,10 @@ end ------------------------------------------------------------------------ function expr.Index (fs, ast, v) - if #ast ~= 2 then error "generalized indexes not implemented" end + if #ast ~= 2 then + print"\n\nBAD INDEX AST:" + table.print(ast) + error "generalized indexes not implemented" end expr.expr (fs, ast[1], v) luaK:exp2anyreg (fs, v) diff --git a/src/compiler/metalua.mlua b/src/compiler/metalua.mlua index 3abc5f7..73eccf4 100644 --- a/src/compiler/metalua.mlua +++ b/src/compiler/metalua.mlua @@ -6,6 +6,10 @@ require 'metalua.compiler' require 'clopts' require 'springs' +AST_COMPILE_ERROR_NUMBER = -1 +RUNTIME_ERROR_NUMBER = -3 +BYTECODE_SYNTHESE_ERROR_NUMBER = -100 + -{ extension 'match' } local chunks = { } @@ -118,32 +122,26 @@ local function main (...) cfg.run = true end - - ------------------------------------------------------------------- - -- List all sources to compile if verbose - if cfg.verbose then - verb_print "Sources to compile:" - for s in values(chunks) do verb_print(" * %s", table.tostring(s)) end - end - local code = { } ------------------------------------------------------------------- -- Get ASTs from sources for x in values(chunks) do - local ast + verb_print("Compiling %s", table.tostring(x)) + local st, ast match x with - | `Library{ l } -> ast = `Call{ `Id 'require', `String{ l } } + | `Library{ l } -> st, ast = true, `Call{ `Id 'require', `String{ l } } | `Literal{ e } -> local ring = springs.new() ring:dostring (INIT_COMPILATION_RING) - ast = ring:call('mlc.ast_of_luastring', e, 'literal') + st, ast = ring:pcall('mlc.ast_of_luastring', e, 'literal') | `File{ f } -> local ring = springs.new() ring:dostring (INIT_COMPILATION_RING) - ast = ring:call('mlc.ast_of_luafile', f, '@'..f) -- FIXME: handle '-' + st, ast = ring:pcall('mlc.ast_of_luafile', f, '@'..f) -- FIXME: handle '-' ast = +{ function (...) -{ast} end(...) } end + if not st then os.exit (AST_COMPILE_ERROR_NUMBER) end ast.origin = x table.insert(code, ast) end @@ -195,11 +193,16 @@ local function main (...) ------------------------------------------------------------------- -- Run compiled code if cfg.run then - verb_print "Running:" + verb_print "Running" local f = mlc.function_of_luacstring (bytecode) bytecode = nil + -- FIXME: isolate execution in a ring -- FIXME: check for failures - f(unpack (runargs)) + local st, msg = pcall(f, unpack (runargs)) + if not st then + io.stderr:write(msg) + os.exit(RUNTIME_ERROR_NUMBER) + end end ------------------------------------------------------------------- @@ -209,6 +212,9 @@ local function main (...) print "*** !!! Interactive loop not implemented !!!" print ("*":rep(70)) end + + verb_print "Done" + end main(...) \ No newline at end of file diff --git a/src/compiler/mlp_meta.lua b/src/compiler/mlp_meta.lua index 6cdeb8f..19b501c 100644 --- a/src/compiler/mlp_meta.lua +++ b/src/compiler/mlp_meta.lua @@ -68,9 +68,11 @@ function quote (t) local cases = { } function cases.table (t) local mt = { tag = "Table" } + _G.table.insert (mt, { tag = "Pair", quote "quote", { tag = "True" } }) if t.tag == "Splice" then assert (#t==1, "Invalid splice") - return t[1] + local sp = t[1] + return sp elseif t.tag then _G.table.insert (mt, { tag = "Pair", quote "tag", quote (t.tag) }) end @@ -79,8 +81,8 @@ function quote (t) end return mt end - function cases.number (t) return { tag = "Number", t } end - function cases.string (t) return { tag = "String", t } end + function cases.number (t) return { tag = "Number", t, quote = true } end + function cases.string (t) return { tag = "String", t, quote = true } end return cases [ type (t) ] (t) end @@ -130,7 +132,7 @@ function quote_content (lx) local parser if lx:is_keyword (lx:peek(1), ":") then -- +{:parser: content } lx:next() - error "NOT IMPLEMENTED" + errory "NOT IMPLEMENTED" elseif lx:is_keyword (lx:peek(2), ":") then -- +{parser: content } parser = mlp[id(lx)[1]] lx:next() @@ -144,9 +146,9 @@ function quote_content (lx) --print("IN_A_QUOTE") local content = parser (lx) local q_content = quote (content) - --printf("/IN_A_QUOTE:\n* content=\n%s\n* q_content=\n%s\n", - -- _G.table.tostring(content, "nohash", 60), - -- _G.table.tostring(q_content, "nohash", 60)) +-- printf("/IN_A_QUOTE:\n* content=\n%s\n* q_content=\n%s\n", +-- _G.table.tostring(content, "nohash", 60), +-- _G.table.tostring(q_content, "nohash", 60)) in_a_quote = prev_iq return q_content end diff --git a/src/lib/H.mlua b/src/lib/H.mlua new file mode 100644 index 0000000..4a3d4e5 --- /dev/null +++ b/src/lib/H.mlua @@ -0,0 +1,121 @@ +require 'walk.id' + +-{ extension 'log' } + +-- Quasi-quote hygienization +-- ========================= +-- +-- This function intends to address all variable issues that might + +function H(...) + + -- Get and parse args: + -- ast :: ast to parse + -- ast_kind :: string + -- free_vars :: old_name -> new_name for free variables + -- bound_vars :: binder -> old_name -> new_name for bound variables + -- keep :: var_name -> boolean + -- alpha :: `Local statement carrying original free vars alpha convs + -- h_inside, h_outside :: booleans + local local_renames, ast, ast_kind, bound_vars, + free_vars, keep, alpha, h_inside, h_outside do + local cfg + if select('#', ...) > 1 then cfg, ast = ... else cfg, ast = { }, ... end + ast_kind = cfg.kind or 'guess' + local side = cfg.side + h_inside = not side or side=='inside' or side=='both' + h_outside = not side or side=='outside' or side=='both' + if h_inside then local_renames, bound_vars = { }, { } end + if h_outside then free_vars = { } end + + -- kept variables must be in keys, not in values: + keep = cfg.keep or { } + if type(keep)=='string' then keep = { [keep] = 1 } + elseif #keep>0 then keep = table.transpose(keep) end + + if h_outside then + -- extend an existing alpha conversion scheme + alpha = cfg.alpha or `Local{ { }, { } } + if #alpha==0 then alpha <- `Local{ { }, { } } end + local new, old = unpack(alpha) + assert (#new==#old, "Invalid alpha list") + for i = 1, #new do + assert (old[i].tag=='Id' and #old[i]==1, "Invalid lhs in alpha list") + assert (new[i].tag=='Id' and #new[i]==1, "Invalid rhs in alpha list") + free_vars[old[i][1]] = new[i][1] + end + end + end + + -- Config for the id walker + local cfg = { expr = { }, stat = { }, id = { } } + + if h_outside then + -- Rename free variables that are not supposed to be captured. + -- An old_name -> new_name dictionary is kept in free_vars. + function cfg.id.free (id) + local old_name = id[1] + if keep[old_name] then return end + local new_name = free_vars[old_name] + if not new_name then + new_name = mlp.gensym('_X_'..old_name) + free_vars[old_name] = new_name + table.insert(alpha[1], `Id{new_name}) + table.insert(alpha[2], `Id{old_name}) + end + id[1] = new_name + end + end + + if h_inside then + local_renames = { } + + -- Rename a binding `Id, + -- Keep a binder -> old_name -> new_name distionary in bound_vars. + function cfg.binder (id, binder) + if not id.quote then return end + local old_name = id[1] + local binder_table = bound_vars[binder] + if not binder_table then + binder_table = { } + bound_vars[binder] = binder_table + end + local new_name = mlp.gensym('_L_'..old_name)[1] + binder_table[old_name] = new_name + local_renames[id] = new_name + end + -- Rename a bound variable, + -- its new name should already be in bound_vars. + function cfg.id.bound (id, binder) + if not id.quote then return end + local old_name = id[1] + local new_name = bound_vars[binder][old_name] + --$log(bound_vars[binder]) + assert(new_name, "no alpha conversion for a bound var?!") + local_renames[id] = new_name + end + end + + -- Don't traverse trees spliced into the quote + local cut_splices = |x| not x.quote and 'break' or nil + cfg.stat.down, cfg.expr.down = cut_splices, cut_splices + + -- The walker's config is ready, let's go. + -- After that, ids are renamed in ast, free_vars and bound_vars are set. + walk_id[ast_kind](cfg, ast) + + -- Apply local name changes + for id, new_name in pairs(local_renames) do id[1] = new_name end + + return ast, alpha +end + + +-- Notes: +-- * the order of id visitors is wrong: first expr, then id +-- * if there's no splice in it, there's no need to rename vars +-- ==> first pass to mark binders which contain splices, +-- then 2nd pass only touched those which have a splice +-- in them. +-- * $log: put in stdlib, treat all strings before vars as +-- msg, literals 'nohash' and numbers after as print params. diff --git a/src/lib/dollar.mlua b/src/lib/dollar.mlua index 1eb8c94..af0fa8f 100644 --- a/src/lib/dollar.mlua +++ b/src/lib/dollar.mlua @@ -5,7 +5,7 @@ mlp.macros = rawget(mlp, 'macros') or { } -local function dollar_builder(_, call) +local function dollar_builder(call) match call with | `Call{ `Id{name}, ... } -> return mlp.macros[name](select(2, unpack(call))) | `Id{name} -> @@ -20,4 +20,5 @@ local function dollar_builder(_, call) end end -mlp.expr.prefix:add{ '$', prec = 100, builder = dollar_builder } +mlp.expr.prefix:add{ '$', prec = 100, builder = |_, x| dollar_builder(x) } +mlp.stat:add{ '$', mlp.expr, builder = |x| dollar_builder(x[1]) } diff --git a/src/lib/walk.mlua b/src/lib/walk.mlua index 58dc796..58ef30d 100644 --- a/src/lib/walk.mlua +++ b/src/lib/walk.mlua @@ -166,7 +166,7 @@ function walk.traverse.stat (cfg, x, ...) local EL = |y| walk.expr_list (cfg, y, x, unpack(log)) local I = |y| walk.binder_list (cfg, y, x, unpack(log)) match x with - | {...} if x.tag == nil -> for y in ivalues(y) do walk.stat(cfg, y, ...) end + | {...} if x.tag == nil -> for y in ivalues(x) do walk.stat(cfg, y, ...) end -- no tag --> node not inserted in the history log | `Do{...} -> B(x) | `Set{ lhs, rhs } -> EL(lhs); EL(rhs) diff --git a/src/samples/h_test.mlua b/src/samples/h_test.mlua new file mode 100644 index 0000000..e051172 --- /dev/null +++ b/src/samples/h_test.mlua @@ -0,0 +1,69 @@ +-{ extension 'log' } + +require 'metalua.compiler' +require 'H' + +--assert (+{foo}.quote, "no q!?") + +-- Usage samples: + +TEST_CASES = { + + { "everything should be renamed", + +{ block: + local x = 3 + print(x) }, + { } }, + + { "don't get confused between global and local x", + +{ block: + print(x) + local x = 3 + print(x) }, + { alpha = { } } }, + + { "don't rename keepme", + +{ block: + keepme() + dont_keep_me() }, + { keep = 'keepme' , alpha = `Local{ { }, { } } } }, + + { "print shouldn't be renamed the 2nd and 3rd time", + +{ block: + print(i) + -{`Call{`Id 'print', `String 'hi' } } + -- Bugger. I don't detect any non-quoted element , so + -- the -{+{ }} thingie won't protect from capture. + -{+{print 'hi'}} }, + { } }, + + { "print shouldn't be renamed at all", + +{ block: + print(i) + -{`Call{`Id 'print', `String 'hi' } } + -{+{print 'hi'}} }, + { keep = 'print' } }, + + { "Rename print with a pre-specified name, rename x freely, not y", + +{ block: + print (x, y) }, + { alpha = +{stat: local RENAMED_PRINT = print}, + keep = {y = true} } } } + +-- { +{ block: -- +-- }, +-- { } }, + +for case in values(TEST_CASES) do + local comment, ast, cfg = unpack(case) + print ('\n'..'-':rep(70)) + print (comment) + print ("BEFORE PARSING:") + $log (ast, 50, 'nohash') + local _, alpha = H (cfg, ast) + print ("AFTER PARSING:") + $log (ast, alpha, cfg.alpha, 50, 'nohash') +end + +print ('\n'..'=':rep(70)) +$log(TEST_CASES,40) \ No newline at end of file diff --git a/src/samples/walk_id_test.mlua b/src/samples/walk_id_test.mlua new file mode 100644 index 0000000..ee0e217 --- /dev/null +++ b/src/samples/walk_id_test.mlua @@ -0,0 +1,88 @@ +-{ extension 'match' } + +require 'walk.id' + +ast = +{ block: + y = type(1) + function foo(x) + local type = 'number' + assert(x==type or not x) + end + foo(x) } + +disp = |msg,ast| printf("\n%s:\n%s", msg, table.tostring(ast, 80, 'nohash')) +disp('initial term', ast) + +require'autotable' + +do -- Make globals explicit: + local ast = table.deep_copy(ast) + local cfg = { id = { } } + function cfg.id.free(i) + i <- `Index{ `Id '_G', `String{i[1]} } + return 'break' + end + walk_id.block(cfg, ast) + disp('Globals made explicit', ast) +end + + +do -- Alpha rename local vars: + local ast = table.deep_copy(ast) + local cfg = { id = { } } + local translations = autotable() + function cfg.id.bound (id, binder) + local tmp = translations[id[1]] + if not tmp then + printf("new tmp for name %s", id[1]) + tmp = { } + translations[id[i]] = tmp + end + local new_name = tmp[binder] + if not new_name then + printf("new name for name %s binder %s", id[1], tostring(binder)) + new_name = mlp.gensym('_local_'..id[1]) + + tmp[binder] = new_name + end + id[1] = new_name + end + walk_id.block(cfg, ast) + disp('Local alpha-renamed', ast) +end + + +--[=[ + + +local varlist_mt = { __index = function (self, key) + local x={ }; self[key] = x; return x + end } +local bound_vars = setmetatable({ }, varlist_mt) +local free_vars = setmetatable({ }, varlist_mt) + +cfg = { + id = { + bound = |x, binder| table.insert(bound_vars[binder], x), + free = |x| table.insert(free_vars[x[1]], x) } } + +walk_id.block(cfg, x) + +-- Alpha convert bound variables +for binder, occurences in pairs(bound_vars) do + local new_name = "_LOCAL_"..occurences[1][1] + local cfg = { binder = function (x) x[1]=new_name; return 'break' end } + walk.guess(cfg, binder) + for occ in ivalues(occurences) do occ[1] = new_name end +end + +-- Alpha convert free variables +for name, occurences in pairs(free_vars) do + local new_name = "_GLOBAL_"..occurences[1][1] + for occ in ivalues(occurences) do occ[1] = new_name end +end +--]=] + +--print "\n\n TERM AFTER PARSING:" +--table.print(x,60,'nohash') + -- 2.44.0