lua/step8_macros.lua

   1 #!/usr/bin/env lua
   2
   3 local table = require('table')
   4
   5 local readline = require('readline')
   6 local utils = require('utils')
   7 local types = require('types')
   8 local reader = require('reader')
   9 local printer = require('printer')
  10 local Env = require('env')
  11 local core = require('core')
  12 local List, Vector, HashMap = types.List, types.Vector, types.HashMap
  13
  14 -- read
  15 function READ(str)
  16     return reader.read_str(str)
  17 end
  18
  19 -- eval
  20 function is_pair(x)
  21     return types._sequential_Q(x) and #x > 0
  22 end
  23
  24 function quasiquote(ast)
  25     if not is_pair(ast) then
  26         return types.List:new({types.Symbol:new("quote"), ast})
  27     elseif types._symbol_Q(ast[1]) and ast[1].val == 'unquote' then
  28         return ast[2]
  29     elseif is_pair(ast[1]) and
  30            types._symbol_Q(ast[1][1]) and
  31            ast[1][1].val == 'splice-unquote' then
  32         return types.List:new({types.Symbol:new("concat"),
  33                                ast[1][2],
  34                                quasiquote(ast:slice(2))})
  35     else
  36         return types.List:new({types.Symbol:new("cons"),
  37                                quasiquote(ast[1]),
  38                                quasiquote(ast:slice(2))})
  39     end
  40 end
  41
  42 function is_macro_call(ast, env)
  43     if types._list_Q(ast) and
  44        types._symbol_Q(ast[1]) and
  45        env:find(ast[1]) then
  46         local f = env:get(ast[1])
  47         return types._malfunc_Q(f) and f.ismacro
  48     end
  49 end
  50
  51 function macroexpand(ast, env)
  52     while is_macro_call(ast, env) do
  53         local mac = env:get(ast[1])
  54         ast = mac.fn(unpack(ast:slice(2)))
  55     end
  56     return ast
  57 end
  58
  59 function eval_ast(ast, env)
  60     if types._symbol_Q(ast) then
  61         return env:get(ast)
  62     elseif types._list_Q(ast) then
  63         return List:new(utils.map(function(x) return EVAL(x,env) end,ast))
  64     elseif types._vector_Q(ast) then
  65         return Vector:new(utils.map(function(x) return EVAL(x,env) end,ast))
  66     elseif types._hash_map_Q(ast) then
  67         local new_hm = {}
  68         for k,v in pairs(ast) do
  69             new_hm[EVAL(k, env)] = EVAL(v, env)
  70         end
  71         return HashMap:new(new_hm)
  72     else
  73         return ast
  74     end
  75 end
  76
  77 function EVAL(ast, env)
  78   while true do
  79     --print("EVAL: "..printer._pr_str(ast,true))
  80     if not types._list_Q(ast) then return eval_ast(ast, env) end
  81
  82     -- apply list
  83     ast = macroexpand(ast, env)
  84     if not types._list_Q(ast) then return ast end
  85
  86     local a0,a1,a2,a3 = ast[1], ast[2],ast[3],ast[4]
  87     local a0sym = types._symbol_Q(a0) and a0.val or ""
  88     if 'def!' == a0sym then
  89         return env:set(a1, EVAL(a2, env))
  90     elseif 'let*' == a0sym then
  91         local let_env = Env:new(env)
  92         for i = 1,#a1,2 do
  93             let_env:set(a1[i], EVAL(a1[i+1], let_env))
  94         end
  95         env = let_env
  96         ast = a2 -- TCO
  97     elseif 'quote' == a0sym then
  98         return a1
  99     elseif 'quasiquote' == a0sym then
 100         ast = quasiquote(a1) -- TCO
 101     elseif 'defmacro!' == a0sym then
 102         local mac = EVAL(a2, env)
 103         mac.ismacro = true
 104         return env:set(a1, mac)
 105     elseif 'macroexpand' == a0sym then
 106         return macroexpand(a1, env)
 107     elseif 'do' == a0sym then
 108         local el = eval_ast(ast:slice(2,#ast-1), env)
 109         ast = ast[#ast]  -- TCO
 110     elseif 'if' == a0sym then
 111         local cond = EVAL(a1, env)
 112         if cond == types.Nil or cond == false then
 113             if a3 then ast = a3 else return types.Nil end -- TCO
 114         else
 115             ast = a2 -- TCO
 116         end
 117     elseif 'fn*' == a0sym then
 118         return types.MalFunc:new(function(...)
 119             return EVAL(a2, Env:new(env, a1, arg))
 120         end, a2, env, a1)
 121     else
 122         local args = eval_ast(ast, env)
 123         local f = table.remove(args, 1)
 124         if types._malfunc_Q(f) then
 125             ast = f.ast
 126             env = Env:new(f.env, f.params, args) -- TCO
 127         else
 128             return f(unpack(args))
 129         end
 130     end
 131   end
 132 end
 133
 134 -- print
 135 function PRINT(exp)
 136     return printer._pr_str(exp, true)
 137 end
 138
 139 -- repl
 140 local repl_env = Env:new()
 141 function rep(str)
 142     return PRINT(EVAL(READ(str),repl_env))
 143 end
 144
 145 -- core.lua: defined using Lua
 146 for k,v in pairs(core.ns) do
 147     repl_env:set(types.Symbol:new(k), v)
 148 end
 149 repl_env:set(types.Symbol:new('eval'),
 150              function(ast) return EVAL(ast, repl_env) end)
 151 repl_env:set(types.Symbol:new('*ARGV*'), types.List:new(types.slice(arg,2)))
 152
 153 -- core.mal: defined using mal
 154 rep("(def! not (fn* (a) (if a false true)))")
 155 rep("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))")
 156 rep("(defmacro! cond (fn* (& xs) (if (> (count xs) 0) (list 'if (first xs) (if (> (count xs) 1) (nth xs 1) (throw \"odd number of forms to cond\")) (cons 'cond (rest (rest xs)))))))")
 157 rep("(defmacro! or (fn* (& xs) (if (empty? xs) nil (if (= 1 (count xs)) (first xs) `(let* (or_FIXME ~(first xs)) (if or_FIXME or_FIXME (or ~@(rest xs))))))))")
 158
 159 if #arg > 0 then
 160     rep("(load-file \""..arg[1].."\")")
 161     os.exit(0)
 162 end
 163
 164 while true do
 165     line = readline.readline("user> ")
 166     if not line then break end
 167     xpcall(function()
 168         print(rep(line))
 169     end, function(exc)
 170         if exc then
 171             if types._malexception_Q(exc) then
 172                 exc = printer._pr_str(exc.val, true)
 173             end
 174             print("Error: " .. exc)
 175             print(debug.traceback())
 176         end
 177     end)
 178 end