Step 8 of Make-a-Lisp for Erlang

step0 through step8 passes (sans step5 special case)

erlang/Makefile

@@ -1,14 +1,15 @@
 #####################
 
 SOURCES_BASE = src/step0_repl.erl src/step1_read_print.erl src/step2_eval.erl src/step3_env.erl \
-	src/step4_if_fn_do.erl src/step5_tco.erl src/step6_file.erl src/step7_quote.erl
+	src/step4_if_fn_do.erl src/step5_tco.erl src/step6_file.erl src/step7_quote.erl \
+	src/step8_macros.erl
 SOURCES_LISP = src/core.erl src/env.erl src/printer.erl src/reader.erl src/types.erl
 SOURCES = $(SOURCES_BASE) $(word $(words $(SOURCES_LISP)),${SOURCES_LISP})
 
 #####################
 
 SRCS = step0_repl.erl step1_read_print.erl step2_eval.erl step3_env.erl step4_if_fn_do.erl \
-	step5_tco.erl step6_file.erl step7_quote.erl
+	step5_tco.erl step6_file.erl step7_quote.erl step8_macros.erl
 BINS = $(SRCS:%.erl=%)
 
 #####################

erlang/rebar.config

@@ -17,5 +17,6 @@
     "step4_if_fn_do",
     "step5_tco",
     "step6_file",
-    "step7_quote"
+    "step7_quote",
+    "step8_macros"
 ]}.

erlang/src/core.erl

@@ -25,6 +25,39 @@ empty_q([]) ->
 empty_q(_) ->
     {error, "empty? expects one list argument"}.
 
+nth([{Type, List}, {integer, Index}]) when Type == list orelse Type == vector ->
+    try lists:nth(Index+1, List) of
+        Result -> Result
+    catch
+        error:_Error -> {error, "nth: index out of range"}
+    end;
+nth([_]) ->
+    {error, "nth expects two arguments"}.
+
+first([{Type, [First|_Rest]}]) when Type == list orelse Type == vector ->
+    First;
+first([{Type, []}]) when Type == list orelse Type == vector ->
+    nil;
+first([nil]) ->
+    nil;
+first([_]) ->
+    {error, "first called on non-sequence"};
+first([]) ->
+    {error, "first called with no arguments"};
+first(_) ->
+    {error, "first expects one list argument"}.
+
+rest([{Type, [_First|Rest]}]) when Type == list orelse Type == vector ->
+    {list, Rest};
+rest([{Type, []}]) when Type == list orelse Type == vector ->
+    {list, []};
+rest([_]) ->
+    {error, "rest called on non-sequence"};
+rest([]) ->
+    {error, "rest called with no arguments"};
+rest(_) ->
+    {error, "rest expects one list argument"}.
+
 equal_q(Args) ->
     case Args of
         [nil, nil] -> true;
@@ -162,12 +195,15 @@ ns() ->
         "cons" => fun cons/1,
         "count" => fun count/1,
         "empty?" => fun empty_q/1,
+        "first" => fun first/1,
         "list" => fun types:list/1,
         "list?" => fun types:list_p/1,
+        "nth" => fun nth/1,
         "pr-str" => fun pr_str/1,
         "println" => fun println/1,
         "prn" => fun prn/1,
         "read-string" => fun read_string/1,
+        "rest" => fun rest/1,
         "slurp" => fun slurp/1,
         "str" => fun str/1
     },

erlang/src/env.erl

@@ -10,7 +10,7 @@
 -module(env).
 -behavior(gen_server).
 
--export([new/1, bind/3, get/2, set/3, root/1]).
+-export([new/1, bind/3, find/2, get/2, set/3, root/1]).
 -export([init/1, handle_call/3, handle_cast/2, handle_info/2, terminate/2, code_change/3]).
 
 -record(state, {outer, data}).
@@ -36,9 +36,16 @@ new(Outer) ->
 bind(Pid, Names, Values) ->
     gen_server:call(Pid, {bind, Names, Values}).
 
+-spec find(Pid1, Key) -> Pid2
+    when Pid1 :: pid(),
+         Key  :: {symbol, string()},
+         Pid2 :: pid() | nil.
+find(Pid, {symbol, Name}) ->
+    gen_server:call(Pid, {find_pid, Name}).
+
 -spec get(Pid, Key) -> Value
     when Pid   :: pid(),
-         Key   :: {symbol, term()},
+         Key   :: {symbol, string()},
          Value :: term().
 get(Pid, {symbol, Name}) ->
 	case gen_server:call(Pid, {get, Name}) of
@@ -50,7 +57,7 @@ get(_Pid, _Key) ->
 
 -spec set(Pid, Key, Value) -> ok
     when Pid   :: pid(),
-         Key   :: {symbol, term()},
+         Key   :: {symbol, string()},
          Value :: term().
 set(Pid, {symbol, Name}, Value) ->
     gen_server:call(Pid, {set, Name, Value});
@@ -75,8 +82,10 @@ init([Outer]) ->
 handle_call({bind, Names, Values}, _From, State) ->
     NewEnv = env_bind(State, Names, Values),
     {reply, ok, NewEnv};
-handle_call({find, Name}, _From, State) ->
+handle_call({find_env, Name}, _From, State) ->
     {reply, env_find(State, Name), State};
+handle_call({find_pid, Name}, _From, State) ->
+    {reply, pid_find(State, Name), State};
 handle_call({get, Name}, _From, State) ->
     {reply, env_get(State, Name), State};
 handle_call({set, Name, Value}, _From, State) ->
@@ -103,13 +112,23 @@ code_change(_OldVsn, State, _Extra) ->
 %% Internal functions
 %%
 
+pid_find(Env, Name) ->
+    case maps:is_key(Name, Env#state.data) of
+        true  -> self();
+        false ->
+            case Env#state.outer of
+                undefined -> nil;
+                Outer     -> gen_server:call(Outer, {find_pid, Name})
+            end
+    end.
+
 env_find(Env, Name) ->
     case maps:is_key(Name, Env#state.data) of
         true  -> Env;
         false ->
             case Env#state.outer of
                 undefined -> nil;
-                Outer     -> gen_server:call(Outer, {find, Name})
+                Outer     -> gen_server:call(Outer, {find_env, Name})
             end
     end.
 
@@ -127,7 +146,7 @@ env_bind(Env, [{symbol, Name}|Ntail], [Value|Vtail]) ->
 
 -spec env_get(Env, Key) -> {ok, Value} | {error, string()}
     when Env   :: #state{},
-         Key   :: {symbol, term()},
+         Key   :: {symbol, string()},
          Value :: term().
 env_get(Env, Name) ->
     case env_find(Env, Name) of
@@ -137,7 +156,7 @@ env_get(Env, Name) ->
 
 -spec env_set(Env1, Key, Value) -> Env2
     when Env1  :: #state{},
-         Key   :: {symbol, term()},
+         Key   :: {symbol, string()},
          Value :: term(),
          Env2  :: #state{}.
 env_set(Env, Name, Value) ->

erlang/src/printer.erl

@@ -22,6 +22,7 @@ pr_str(Value, Readably) ->
         {map, Map} -> pr_map(Map, Readably);
         {closure, _Binds, _Body, _Env} -> "#<function>";
         {function, _Func} -> "#<builtin>";
+        {macro, _Binds, _Body, _Env} -> "#<macro>";
         {error, Reason} -> io_lib:format("error: ~s", [Reason])
 	end.
 

erlang/src/step8_macros.erl

@@ -0,0 +1,230 @@
+%%%
+%%% Step 8: Macros
+%%%
+
+-module(step8_macros).
+
+-export([main/1]).
+
+main([File|Args]) ->
+    Env = init(),
+    env:set(Env, {symbol, "*ARGV*"}, {list, Args}),
+    rep("(load-file \"" ++ File ++ "\")", Env);
+main([]) ->
+    Env = init(),
+    env:set(Env, {symbol, "*ARGV*"}, {list, []}),
+    loop(Env).
+
+init() ->
+    Env = core:ns(),
+    eval(read("(def! not (fn* (a) (if a false true)))"), Env),
+    eval(read("(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))"), Env),
+    eval(read("(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)))))))"), Env),
+    eval(read("(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))))))))"), Env),
+    Env.
+
+loop(Env) ->
+    case io:get_line(standard_io, "user> ") of
+        eof -> io:format("~n");
+        {error, Reason} -> exit(Reason);
+        Line ->
+            rep(string:strip(Line, both, $\n), Env),
+            loop(Env)
+    end.
+
+rep(Input, Env) ->
+    try eval(read(Input), Env) of
+        Result -> print(Result)
+    catch
+        throw:Reason -> io:format("error: ~s~n", [Reason])
+    end.
+
+read(Input) ->
+    case reader:read_str(Input) of
+        {ok, Value} -> Value;
+        {error, Reason} -> throw(Reason)
+    end.
+
+eval(Value, Env) ->
+    case Value of
+        {list, _L1} ->
+            case macroexpand(Value, Env) of
+                {list, _L2} = List -> eval_list(List, Env);
+                AST -> AST
+            end;
+        _ -> eval_ast(Value, Env)
+    end.
+
+eval_list({list, []}, _Env) ->
+    [];
+eval_list({list, [{symbol, "def!"}, {symbol, A1}, A2]}, Env) ->
+    Result = eval(A2, Env),
+    case Result of
+        {error, _R1} -> Result;
+        _ ->
+            env:set(Env, {symbol, A1}, Result),
+            Result
+    end;
+eval_list({list, [{symbol, "def!"}, _A1, _A2]}, _Env) ->
+    throw("def! called with non-symbol");
+eval_list({list, [{symbol, "def!"}|_]}, _Env) ->
+    throw("def! requires exactly two arguments");
+eval_list({list, [{symbol, "let*"}, A1, A2]}, Env) ->
+    NewEnv = env:new(Env),
+    let_star(NewEnv, A1),
+    eval(A2, NewEnv);
+eval_list({list, [{symbol, "let*"}|_]}, _Env) ->
+    throw("let* requires exactly two arguments");
+eval_list({list, [{symbol, "do"}|Args]}, Env) ->
+    eval_ast({list, lists:droplast(Args)}, Env),
+    eval(lists:last(Args), Env);
+eval_list({list, [{symbol, "if"}, Test, Consequent|Alternate]}, Env) ->
+    case eval(Test, Env) of
+        Cond when Cond == false orelse Cond == nil ->
+            case Alternate of
+                []  -> nil;
+                [A] -> eval(A, Env);
+                _   -> throw("if takes 2 or 3 arguments")
+            end;
+        _ -> eval(Consequent, Env)
+    end;
+eval_list({list, [{symbol, "if"}|_]}, _Env) ->
+    throw("if requires test and consequent");
+eval_list({list, [{symbol, "fn*"}, {vector, Binds}, Body]}, Env) ->
+    {closure, Binds, Body, Env};
+eval_list({list, [{symbol, "fn*"}, {list, Binds}, Body]}, Env) ->
+    {closure, Binds, Body, Env};
+eval_list({list, [{symbol, "fn*"}|_]}, _Env) ->
+    throw("fn* requires 2 arguments");
+eval_list({list, [{symbol, "eval"}, AST]}, Env) ->
+    % Must use the root environment so the variables set within the parsed
+    % expression will be visible within the repl.
+    eval(eval(AST, Env), env:root(Env));
+eval_list({list, [{symbol, "eval"}|_]}, _Env) ->
+    throw("eval requires 1 argument");
+eval_list({list, [{symbol, "quote"}, AST]}, _Env) ->
+    AST;
+eval_list({list, [{symbol, "quote"}|_]}, _Env) ->
+    throw("quote requires 1 argument");
+eval_list({list, [{symbol, "quasiquote"}, AST]}, Env) ->
+    eval(quasiquote(AST), Env);
+eval_list({list, [{symbol, "quasiquote"}|_]}, _Env) ->
+    throw("quasiquote requires 1 argument");
+eval_list({list, [{symbol, "defmacro!"}, {symbol, A1}, A2]}, Env) ->
+    case eval(A2, Env) of
+        {closure, Binds, Body, CE} ->
+            Result = {macro, Binds, Body, CE},
+            env:set(Env, {symbol, A1}, Result),
+            Result;
+        Result -> env:set(Env, {symbol, A1}, Result), Result
+    end,
+    Result;
+eval_list({list, [{symbol, "defmacro!"}, _A1, _A2]}, _Env) ->
+    throw("defmacro! called with non-symbol");
+eval_list({list, [{symbol, "defmacro!"}|_]}, _Env) ->
+    throw("defmacro! requires exactly two arguments");
+eval_list({list, [{symbol, "macroexpand"}, Macro]}, Env) ->
+    macroexpand(Macro, Env);
+eval_list({list, List}, Env) ->
+    case eval_ast({list, List}, Env) of
+        {list, [{closure, Binds, Body, CE}|A]} ->
+            % The args may be a single element or a list, so always make it
+            % a list and then flatten it so it becomes a list.
+            NewEnv = env:new(CE),
+            env:bind(NewEnv, Binds, lists:flatten([A])),
+            eval(Body, NewEnv);
+        {list, [{function, F}|A]} -> erlang:apply(F, [A]);
+        {list, [{error, Reason}]} -> {error, Reason};
+        A -> io:format("eval_list received ~w~n", [A]), throw("expected a list")
+    end.
+
+eval_ast({symbol, _Sym}=Value, Env) ->
+    env:get(Env, Value);
+eval_ast({Type, Seq}, Env) when Type == list orelse Type == vector ->
+    {Type, lists:map(fun(Elem) -> eval(Elem, Env) end, Seq)};
+eval_ast({map, M}, Env) ->
+    {map, maps:map(fun(_Key, Val) -> eval(Val, Env) end, M)};
+eval_ast(Value, _Env) ->
+    Value.
+
+print(none) ->
+    % if nothing meaningful was entered, print nothing at all
+    ok;
+print(Value) ->
+    io:format("~s~n", [printer:pr_str(Value, true)]).
+
+let_star(Env, Bindings) ->
+    Bind = fun({Name, Expr}) ->
+        case Name of
+            {symbol, _Sym} -> env:set(Env, Name, eval(Expr, Env));
+            _ -> throw("let* with non-symbol binding")
+        end
+    end,
+    case Bindings of
+        {Type, Binds} when Type == list orelse Type == vector ->
+            case list_to_proplist(Binds) of
+                {error, Reason} -> throw(Reason);
+                Props -> lists:foreach(Bind, Props)
+            end;
+        _ -> throw("let* with non-list bindings")
+    end.
+
+list_to_proplist(L) ->
+    list_to_proplist(L, []).
+
+list_to_proplist([], AccIn) ->
+    lists:reverse(AccIn);
+list_to_proplist([_H], _AccIn) ->
+    {error, "mismatch in let* name/value bindings"};
+list_to_proplist([K,V|T], AccIn) ->
+    list_to_proplist(T, [{K, V}|AccIn]).
+
+quasiquote({T, [{list, [{symbol, "splice-unquote"}, First]}|Rest]}) when T == list orelse T == vector ->
+    % 3. if is_pair of first element of ast is true and the first element of
+    %    first element of ast (ast[0][0]) is a symbol named "splice-unquote":
+    %    return a new list containing: a symbol named "concat", the second element
+    %    of first element of ast (ast[0][1]), and the result of calling quasiquote
+    %    with the second through last element of ast.
+    {list, [{symbol, "concat"}, First] ++ [quasiquote({list, Rest})]};
+quasiquote({T, [{symbol, "splice-unquote"}]}) when T == list orelse T == vector ->
+    {error, "splice-unquote requires an argument"};
+quasiquote({T, [{symbol, "unquote"}, AST]}) when T == list orelse T == vector ->
+    % 2. else if the first element of ast is a symbol named "unquote": return
+    %    the second element of ast.
+    AST;
+quasiquote({T, [{symbol, "unquote"}|_]}) when T == list orelse T == vector ->
+    {error, "unquote expects one argument"};
+quasiquote({T, [First|Rest]}) when T == list orelse T == vector ->
+    % 4. otherwise: return a new list containing: a symbol named "cons",
+    %    the result of calling quasiquote on first element of ast (ast[0]),
+    %    and result of calling quasiquote with the second through last
+    %    element of ast.
+    {list, [{symbol, "cons"}, quasiquote(First)] ++ [quasiquote({list, Rest})]};
+quasiquote(AST) ->
+    % 1. if is_pair of ast is false: return a new list containing:
+    %    a symbol named "quote" and ast.
+    {list, [{symbol, "quote"}, AST]}.
+
+is_macro_call({list, [{symbol, Name}|_]}, Env) ->
+    case env:find(Env, {symbol, Name}) of
+        nil -> false;
+        Env2 ->
+            case env:get(Env2, {symbol, Name}) of
+                {macro, _Binds, _Body, _ME} -> true;
+                _ -> false
+            end
+    end;
+is_macro_call(_AST, _Env) ->
+    false.
+
+macroexpand(AST, Env) ->
+    case is_macro_call(AST, Env) of
+        true ->
+            {list, [Name|A]} = AST,
+            {macro, Binds, Body, ME} = env:get(Env, Name),
+            NewEnv = env:new(ME),
+            env:bind(NewEnv, Binds, lists:flatten([A])),
+            NewAST = eval(Body, NewEnv),
+            macroexpand(NewAST, Env);
+        false -> AST
+    end.