%% Copyright (c) 2008-2021 Robert Virding
%%
%% Licensed under the Apache License, Version 2.0 (the "License");
%% you may not use this file except in compliance with the License.
%% You may obtain a copy of the License at
%%
%%     http://www.apache.org/licenses/LICENSE-2.0
%%
%% Unless required by applicable law or agreed to in writing, software
%% distributed under the License is distributed on an "AS IS" BASIS,
%% WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
%% See the License for the specific language governing permissions and
%% limitations under the License.

%% File    : lfe_eval.erl
%% Author  : Robert Virding
%% Purpose : Lisp Flavoured Erlang interpreter.

%%% We follow Erlang here in many cases even though it is sometimes a
%%% bit strange. In a fun argument where when matching a binary we
%%% import the size of bitseg as a variable from the environment not
%%% just from earlier segments. No other argument variables are
%%% imported.

-module(lfe_eval).

-export([expr/1,expr/2,literal/1,literal/2,body/1,body/2,
         gexpr/1,gexpr/2,guard/1,guard/2,match/3,match_when/4,
         apply/2,apply/3,
         make_letrec_env/2,add_lexical_func/4,add_dynamic_func/4,
         format_error/1]).

%% Deprecated exports.
-export([eval/1,eval/2,eval_list/2]).

-compile({no_auto_import,[apply/3]}).           %For our apply/3 function
-deprecated([eval/1,eval/2,eval_list/2]).

-include("lfe.hrl").

-define(STACKTRACE,
        element(2, erlang:process_info(self(), current_stacktrace))).

-define(EVAL_ERROR(Error), erlang:raise(error, Error, ?STACKTRACE)).

%% -compile([export_all]).

%% Errors which we generate.
%% Some of thse may also be generated by compiled code in which case
%% they will probably be caught in lfe_lib.

format_error(badarg) -> <<"bad argument">>;
format_error({badmatch,Val}) ->
    lfe_io:format1(<<"no match of value ~w">>, [Val]);
format_error({unbound_symbol,S}) ->
    lfe_io:format1(<<"symbol ~w is unbound">>, [S]);
format_error({undefined_function,{F,A}}) ->
    lfe_io:format1(<<"function ~w/~w undefined">>, [F,A]);
format_error(if_expression) -> <<"non-boolean if test">>;
format_error(function_clause) -> <<"no function clause matching">>;
format_error({case_clause,Val}) ->
    format_value(Val, <<"no case clause matching ">>);
format_error(illegal_guard) -> <<"illegal guard expression">>;
format_error(illegal_bitsize) -> <<"illegal bit size">>;
format_error(illegal_bitseg) -> <<"illegal bit segment">>;
format_error({illegal_pattern,Pat}) ->
    format_value(Pat, <<"illegal pattern ">>);
format_error({illegal_literal,Lit}) ->
    format_value(Lit, <<"illegal literal value ">>);
format_error({illegal_mapkey,Key}) ->
    lfe_io:format1(<<"illegal map key ~w">>, [Key]);
format_error(bad_head_arity) -> <<"function head arity mismatch">>;
format_error({argument_limit,Arity}) ->
    lfe_io:format1(<<"too many arguments ~w">>, [Arity]);
format_error({bad_form,Form}) ->
    lfe_io:format1(<<"bad ~w form">>, [Form]);
%% Try-catches.
format_error({try_clause,V}) ->
    format_value(V, <<"no try clause matching ">>);
format_error({illegal_exception,E}) ->
    lfe_io:format1(<<"illegal exception ~w">>, [E]);
%% Records.
format_error({undefined_record,Name}) ->
    lfe_io:format1(<<"record ~w undefined">>, [Name]);
format_error({undefined_record_field,Name,Field}) ->
    lfe_io:format1(<<"field ~w undefined in record ~w">>, [Field,Name]);
format_error({missing_record_field_value,Field}) ->
    lfe_io:format1(<<"missing value to field ~w in record">>, [Field]);
%% Structs.
format_error({undefined_struct,Name}) ->
    lfe_io:format1(<<"struct ~w undefined">>, [Name]);
format_error({undefined_struct_field,Name,Field}) ->
    lfe_io:format1(<<"field ~w undefined in struct ~w">>, [Field,Name]);
format_error({missing_struct_field_value,Field}) ->
    lfe_io:format1(<<"missing value to field ~w in struct">>, [Field]);
%% Everything we don't recognise or know about.
format_error(Error) ->
    lfe_io:prettyprint1(Error).

format_value(Val, ErrStr) ->
    lfe_io:format1(<<"~s~.P">>, [ErrStr,Val,10]).

%% eval(Sexpr) -> Value.
%% eval(Sexpr, Env) -> Value.

eval(E) -> expr(E).

eval(E, Env) -> expr(E, Env).

%% expr(Sexpr) -> Value.
%% expr(Sexpr, Env) -> Value.
%%  Evaluate the sexpr, first expanding all macros.

expr(E) -> expr(E, lfe_env:new()).

expr(E, Env) ->
    Exp = lfe_macro:expand_expr_all(E, Env),
    %% lfe_io:fwrite("e: ~p\n", [{E,Exp,Env}]),
    eval_expr(Exp, Env).

%% literal(Literal) -> Value.
%% literal(Literal, Env) -> Value.
%% body(Body) -> Value.
%% body(Body, Env) -> Value.
%% gexpr(GuardTest) -> Value.
%% gexpr(GuardTest, Env) -> Value.
%% guard(Guard) -> true | false.
%% guard(Guard, Env) -> true | false.

literal(L) -> literal(L, lfe_env:new()).

literal(L, Env) -> eval_lit(L, Env).

body(B) -> body(B, lfe_env:new()).

body(B, Env) -> eval_body(B, Env).

gexpr(Gt) -> gexpr(Gt, lfe_env:new()).

gexpr(Gt, Env) -> eval_gexpr(Gt, Env).

guard(G) -> guard(G, lfe_env:new()).

guard(G, Env) -> eval_guard(G, Env).

%% apply(Function, Args) -> Expr.
%% apply(Function, Args, Env) -> Expr.
%%  This is applying interpreted Erlang functions, for applying funs
%%  use normal apply. Name scoping stops us from using apply/s
%%  internally. Args should already be evaluated.

apply(F, Args) ->
    apply(F, Args, lfe_env:new()).

apply(F, Args, Env) ->
    eval_apply_expr(F, Args, Env).              %Env at function def

%% eval_expr(Sexpr, Environment) -> Value.
%%  Evaluate a sexpr in the current environment. Try to catch core
%%  forms by just name and check arguments arguments later. Otherwise
%%  users can redefine core forms with different number of arguments.

%% Handle the Core data special forms.
eval_expr(?Q(E), _) -> E;
eval_expr([cons,H,T], Env) ->
    [eval_expr(H, Env)|eval_expr(T, Env)];
eval_expr([car,E], Env) -> hd(eval_expr(E, Env)); %Provide lisp names
eval_expr([cdr,E], Env) -> tl(eval_expr(E, Env));
eval_expr([list|Es], Env) -> eval_list(Es, Env);
eval_expr([tuple|Es], Env) -> list_to_tuple(eval_list(Es, Env));
eval_expr([tref,Tup,I], Env) ->
    element(eval_expr(I, Env), eval_expr(Tup, Env));
eval_expr([tset,Tup,I,V], Env) ->
    setelement(eval_expr(I, Env), eval_expr(Tup, Env), eval_expr(V, Env));
eval_expr([binary|Bs], Env) -> eval_binary(Bs, Env);
eval_expr([map|As], Env) ->
    eval_map(As, Env);
eval_expr(['msiz',Map], Env) ->
    eval_map_size(msiz, Map, Env);
eval_expr(['mref',Map,Key], Env) ->
    eval_map_get(mref, Map, Key, Env);
eval_expr(['mset',Map|As], Env) ->
    eval_map_set(mset, Map, As, Env);
eval_expr(['mupd',Map|As], Env) ->
    eval_map_update(mupd, Map, As, Env);
eval_expr(['mrem',Map|Ks], Env) ->
    eval_map_remove(mrem, Map, Ks, Env);
eval_expr(['map-size',Map], Env) ->
    eval_map_size('map-size', Map, Env);
eval_expr(['map-get',Map,Key], Env) ->
    eval_map_get('map-get', Map, Key, Env);
eval_expr(['map-set',Map|As], Env) ->
    eval_map_set('map-set', Map, As, Env);
eval_expr(['map-update',Map|As], Env) ->
    eval_map_update('map-update', Map, As, Env);
eval_expr(['map-remove',Map|Ks], Env) ->
    eval_map_remove('map-remove', Map, Ks, Env);
%% Record special forms.
eval_expr(['record',Name|Fs], Env) ->
    make_record_tuple(Name, Fs, Env);
%% make-record has been deprecated but we sill accept it for now.
eval_expr(['make-record',Name|As], Env) ->
    eval_expr(['record',Name|As], Env);
eval_expr(['is-record',E,Name], Env) ->
    Ev = eval_expr(E, Env),
    test_is_record(Ev, Name, Env);
eval_expr(['record-index',Name,F], Env) ->
    get_record_index(Name, F, Env);
eval_expr(['record-field',E,Name,F], Env) ->
    Ev = eval_expr(E, Env),
    get_record_field(Ev, Name, F, Env);
eval_expr(['record-update',E,Name|Args], Env) ->
    Ev = eval_expr(E, Env),
    update_record_tuple(Ev, Name, Args, Env);
%% Struct special forms.
eval_expr(['struct',Name|Fs], Env) ->
    make_struct_map(Name, Fs, Env);
eval_expr(['is-struct',E], Env) ->
    Ev = eval_expr(E, Env),
    test_is_struct(Ev);
eval_expr(['is-struct',E,Name], Env) ->
    Ev = eval_expr(E, Env),
    test_is_struct(Ev, Name);
eval_expr(['struct-field',E,Name,F], Env) ->
    Ev = eval_expr(E, Env),
    get_struct_field(Ev, Name, F);
eval_expr(['struct-update',E,Name|Args], Env) ->
    Ev = eval_expr(E, Env),
    update_struct_map(Ev, Name, Args, Env);
%% Function forms.
eval_expr([function,Mod,Name,Arity], _Env) ->
    %% Don't evaluate the arguments here.
    erlang:make_fun(Mod, Name, Arity);
eval_expr([function,Name,Arity], Env) ->
    %% Only works for local functions and BIFs without an erlang:.
    Vs = new_vars(Arity),
    eval_lambda([lambda,Vs,[Name|Vs]], Env);
%% Special known data type operations.
eval_expr(['andalso'|Es], Env) ->
    Fun = fun (E, true) -> eval_expr(E, Env);
              (_, false) -> false;
              (_, _Other) -> badarg_error()
          end,
    lists:foldl(Fun, true, Es);
eval_expr(['orelse'|Es], Env) ->
    Fun = fun (_, true) -> true;
              (E, false) -> eval_expr(E, Env);
              (_, _Other) -> badarg_error()
          end,
    lists:foldl(Fun, false, Es);
%% Handle the Core closure special forms.
eval_expr([lambda|_]=Lambda, Env) ->
    eval_lambda(Lambda, Env);
eval_expr(['match-lambda'|_]=Mlambda, Env) ->
    eval_match_lambda(Mlambda, Env);
eval_expr(['let'|Body], Env) ->
    eval_let(Body, Env);
eval_expr(['let-function'|Body], Env) ->
    eval_let_function(Body, Env);
eval_expr(['letrec-function'|Body], Env) ->
    eval_letrec_function(Body, Env);
%% Handle the Core control special forms.
eval_expr(['progn'|Body], Env) ->
    eval_body(Body, Env);
eval_expr(['if'|Body], Env) ->
    eval_if(Body, Env);
eval_expr(['case'|Body], Env) ->
    eval_case(Body, Env);
eval_expr(['receive'|Body], Env) ->
    eval_receive(Body, Env);
eval_expr(['catch'|Body], Env) ->
    catch eval_body(Body, Env);
eval_expr(['try'|Body], Env) ->
    eval_try(Body, Env);
eval_expr([funcall,F|As], Env) ->
    eval_apply_expr(eval_expr(F, Env), eval_list(As, Env), Env);
eval_expr([call|Body], Env) ->
    eval_call(Body, Env);
%% General functions calls.
eval_expr([Fun|Es], Env) when is_atom(Fun) ->
    %% Note that macros have already been expanded here.
    Ar = length(Es),                            %Arity
    case get_fbinding(Fun, Ar, Env) of
        {yes,M,F} -> erlang:apply(M, F, eval_list(Es, Env));
        {yes,F} -> eval_apply(F, eval_list(Es, Env), Env);
        no -> undefined_function_error(Fun, Ar)
    end;
eval_expr([_|_]=S, _) ->                        %Test if string literal
    case lfe_lib:is_posint_list(S) of
        true -> S;                              %It is an "atomic" type
        false ->                                %It is a bad application form
            bad_form_error(application)
    end;
eval_expr(Symb, Env) when is_atom(Symb) ->
    case lfe_env:get_vbinding(Symb, Env) of
        {yes,Val} -> Val;
        no -> unbound_symbol_error(Symb)
    end;
eval_expr(E, _) -> E.                           %Atomic evaluate to themselves

%% is_valid_record(Value, Name, Fields) -> boolean().
%%  Check if Value is a valid record tuple.

is_valid_record(Value, Name, Fields) ->
    RecSize = length(Fields) + 1,
    is_tuple(Value)
        andalso (tuple_size(Value) =:= RecSize)
        andalso (element(1, Value) =:= Name).

%% make_record_tuple(Name, Args, Env) -> Record.
%%  We have to macro expand and evaluate the default values here as
%%  well. Make sure to build the tuple and evaluate the tuple elements
%%  in the right order.  'undefined' is the default value for
%%  unspecified field values.

make_record_tuple(Name, Args, Env) ->
    case lfe_env:get_record(Name, Env) of
        {yes,Fields} ->
            Es = make_record_elements(Fields, Args, Env),
            %% io:format("make\n    ~p\n    ~p\n    ~p\n", [Fields,Args,Es]),
            eval_expr([tuple,?Q(Name)|Es], Env);
        no -> undefined_record_error(Name)
    end.

make_record_elements(Fields, Args, Env) ->
    %% Mke sure we do it left to right.
    DefDef = default_record_value(Args),
    Mfun = fun ([F,Def|_]) ->
                   UseDef = record_or_field_def(DefDef, Def),
                   make_field_val(F, Args, UseDef, Env);
               ([F]) ->
                   UseDef = record_or_field_def(DefDef, ?Q(undefined)),
                   make_field_val(F, Args, UseDef, Env);
               (F) ->
                   UseDef = record_or_field_def(DefDef, ?Q(undefined)),
                   make_field_val(F, Args, UseDef, Env)
           end,
    lists:map(Mfun, Fields).

%% record_or_field_def(DefDef, Def) -> Def.

record_or_field_def({yes,DefDef}, _Def) -> DefDef;
record_or_field_def(no, Def) -> Def.

%% default_record_value(Args) -> {yes, DefaultValue} | no.

default_record_value(['_',Val|_Args]) -> {yes,Val};
default_record_value([_,_|Args]) ->
    default_record_value(Args);
default_record_value([ArgF]) ->
    eval_error({missing_record_field_value,ArgF});
default_record_value([]) -> no.

%% make_field_val(Field, Args, Default, Env) -> Val

make_field_val(F, [F,Val|_], _Def, _Env) ->
    Val;
make_field_val(F, [_,_|Args], Def, Env) ->
    make_field_val(F, Args, Def, Env);
make_field_val(_F, [ArgF], _Def, _Env) ->
    eval_error({missing_record_field_value,ArgF});
make_field_val(_, [], Def, Env) ->
    %% We must expand all macros in the default value used.
    lfe_macro:expand_expr_all(Def, Env).

%% get_field_index(Name, Fields, Field) -> Index.

get_field_index(Name, Fields, F) ->
    get_field_index(Name, Fields, F, 2).        %First element record name

get_field_index(_Name, [[F|_]|_Fields], F, I) -> I;
get_field_index(_Name, [F|_Fields], F, I) -> I; %Field can be just name
get_field_index(Name, [_|Fields], F, I) ->
    get_field_index(Name, Fields, F, I+1);
get_field_index(Name, [], F, _I) ->
    undefined_record_field_error(Name, F).

%% update_record_tuple(Record, Name, Args, Env) -> Record.
%%  Update the Record with the Args.

update_record_tuple(Rec, Name, Args, Env) ->
    case lfe_env:get_record(Name, Env) of
        {yes,Fields} ->
            case is_valid_record(Rec, Name, Fields) of
                true ->
                    Es0 =  tl(tuple_to_list(Rec)),
                    Es1 = update_record_elements(Fields, Es0, Args, Env),
                    list_to_tuple([Name|Es1]);
                false ->
                    eval_error({badrecord,Name,Rec})
            end;
        no -> undefined_record_error(Name)
    end.

update_record_elements(Fields, Recvs, Args, Env) ->
    Ufun = fun ([F|_], Rv) ->  update_field_val(F, Args, Rv, Env);
               (F, Rv) -> update_field_val(F, Args, Rv, Env)
           end,
    lists:zipwith(Ufun, Fields, Recvs).

update_field_val(F, [F,V|_], _Recv, Env) -> eval_expr(V, Env);
update_field_val(F, [_,_|Args], Recv, Env) ->
    update_field_val(F, Args, Recv, Env);
update_field_val(_, [], Recv, _Env) -> Recv.

%% test_is_record(Record, Name, Env) -> boolean().
%%  Test whether term is a record.

test_is_record(Record, Name, Env) ->
    case lfe_env:get_record(Name, Env) of
        {yes,Fields} ->
            is_valid_record(Record, Name, Fields);
        no -> undefined_record_error(Name)
    end.

%% get_record_index(Name, Field) -> Index.
%%  Get the index of a fiedl in the record.

get_record_index(Name, Field, Env) ->
    case lfe_env:get_record(Name, Env) of
        {yes,Fields} ->
            get_field_index(Name, Fields, Field);
        no -> undefined_record_error(Name)
    end.

%% get_record_field(Record, Name, Field, Env) -> Value.
%%  Get the field from the record Name.

get_record_field(Record, Name, Field, Env) ->
    case lfe_env:get_record(Name, Env) of
        {yes,Fields} ->
            case is_valid_record(Record, Name, Fields) of
                true ->
                    Index = get_field_index(Name, Fields, Field),
                    element(Index, Record);
                false ->
                    eval_error({badrecord,Name,Record})
            end;
        no -> undefined_record_error(Name)
    end.

%% make_struct_map(Name, Fields, Env) -> Struct.
%%  We have to macro expand and evaluate the values in the fields. Use
%%  the __struct__/1 check and build the new struct.

make_struct_map(Name, Fields, Env) ->
    Efs = make_struct_fields(Fields, Env),
    try
        Name:'__struct__'(Efs)
    catch
        _:_ ->
            eval_error({undefined_struct,Name})
    end.

make_struct_fields([Key,Val|Kvs], Env) ->
    [{Key,eval_expr(Val, Env)}|make_struct_fields(Kvs, Env)];
make_struct_fields([Key], _Env) ->
    eval_error({missing_struct_field_value,Key});
make_struct_fields([], _Env) ->  [].

%% test_is_struct(Struct) -> boolean().
%% test_is_struct(Struct, Name) -> boolean().
%%  Test whether term is a struct.

test_is_struct(#{'__struct__' := StrName}) when is_atom(StrName) -> true;
test_is_struct(_Other) -> false.

test_is_struct(#{'__struct__' := StrName}, Name) when is_atom(StrName) ->
    StrName =:= Name;
test_is_struct(_Other, _Name) -> false.

%% get_struct_field(Struct, Name, Field) -> Value.

get_struct_field(Str, Name, Field) ->
    case Str of
        #{'__struct__' := Name, Field := Val} -> Val;
         _ ->
             eval_error({badstruct,Name,Str})
    end.

%% update_struct_map(Struct, Name, Fields) -> Struct.
%%  Update the Record with the Args.

update_struct_map(Str, Name, Fields, Env) ->
    case Str of
        #{'__struct__' := Name} ->
            Assocs = make_struct_fields(Fields, Env),
            lists:foldl(fun maps_update/2, Str, Assocs);
        _ ->
            eval_error({badstruct,Name,Str})
    end.

%% get_fbinding(NAme, Arity, Env) ->
%%     {yes,Module,Fun} | {yes,Binding} | no.
%%  Get the function binding. Locally bound function takes precedence
%%  over auto-imported BIFs.

get_fbinding(Name, Ar, Env) ->
    case lfe_env:get_fbinding(Name, Ar, Env) of
        {yes,_,_}=Yes -> Yes;                   %Imported function
        {yes,_}=Yes -> Yes;                     %Bound function
        no ->
            case lfe_internal:is_lfe_bif(Name, Ar) of
                true -> {yes,lfe,Name};         %Auto-imported LFE BIF
                false ->
                    case lfe_internal:is_erl_bif(Name, Ar) of
                        true ->                 %Auto-imported Erlang BIF
                            {yes,erlang,Name};
                        false -> no
                    end
            end
    end.

eval_list(Es, Env) ->
    lists:map(fun (E) -> eval_expr(E, Env) end, Es).

%% eval_body(Body, Env) -> Value.
%%  Evaluate the list of expressions and return value of the last one.

eval_body([E], Env) -> eval_expr(E, Env);
eval_body([E|Es], Env) ->
    eval_expr(E, Env),
    eval_body(Es, Env);
eval_body([], _) -> [];                         %Empty body
eval_body(_, _) -> ?EVAL_ERROR({bad_form,body}).%Not a list of expressions

%% eval_binary(Bitsegs, Env) -> Binary.
%%  Construct a binary from Bitsegs. Pass in an evaluator function to
%%  be used when evaluating value and size expression.

eval_binary(Segs, Env) ->
    Eval = fun (E) -> eval_expr(E, Env) end,
    lfe_eval_bits:expr_bitsegs(Segs, Eval).

%% eval_map(Args, Env) -> Map.
%% eval_map_size(Form, Map, Env) -> Value.
%% eval_map_get(Form, Map, Key, Env) -> Value.
%% eval_map_set(Form, Map, Args, Env) -> Map.
%% eval_map_update(Form, Map, Args, Env) -> Map.
%% eval_map_remove(Form, Map, Keys, Env) -> Map.

eval_map(Args, Env) ->
    Pairs = eval_map_pairs(map, Args, Env),
    maps:from_list(Pairs).

eval_map_size(_Form, Map, Env) ->
    erlang:map_size(eval_expr(Map, Env)).       %Use the BIF

eval_map_get(_Form, Map, K, Env) ->
    Key = eval_map_key(K, Env),
    erlang:map_get(Key, eval_expr(Map, Env)).   %Use the BIF

eval_map_set(Form, M, Args, Env) ->
    Map = eval_expr(M, Env),
    Pairs = eval_map_pairs(Form, Args, Env),
    lists:foldl(fun maps_put/2, Map, Pairs).

eval_map_update(Form, M, Args, Env) ->
    Map = eval_expr(M, Env),
    Pairs = eval_map_pairs(Form, Args, Env),
    lists:foldl(fun maps_update/2, Map, Pairs).

eval_map_remove(_Form, M, Keys, Env) ->
    Map = eval_expr(M, Env),
    lists:foldl(fun maps_remove/2, Map, eval_list(Keys, Env)).

%% eval_map_pairs(Form, Args, Env) -> [{K,V}].

eval_map_pairs(Form, [K,V|As], Env) ->
    P = {eval_map_key(K, Env),eval_expr(V, Env)},
    [P|eval_map_pairs(Form, As, Env)];
eval_map_pairs(_Form, [], _) -> [];
eval_map_pairs(Form, _, _) -> bad_form_error(Form).

%% eval_map_key(Key, Env) -> Value.
%%  A map key can only be a literal in 17 but can be anything in 18..


-ifdef(HAS_FULL_KEYS).
eval_map_key(Key, Env) ->
    eval_expr(Key, Env).
-else.
eval_map_key(?Q(E), _) -> E;
eval_map_key([_|_]=L, _) ->
    case lfe_lib:is_posint_list(L) of
        true -> L;                              %Literal strings only
        false -> illegal_mapkey_error(L)
    end;
eval_map_key(E, _) when not is_atom(E) -> E;    %Everything else
eval_map_key(E, _) -> illegal_mapkey_error(E).
-endif.

maps_put({K,V}, M) -> maps:put(K, V, M).
maps_update({K,V}, M) -> maps:update(K, V, M).
maps_remove(K, M) -> maps:remove(K, M).

%% new_vars(N) -> Vars.

new_vars(N) when N > 0 ->
    V = list_to_atom(integer_to_list(N)),
    [V|new_vars(N-1)];
new_vars(0) -> [].

%% eval_lambda([lambda|LambdaBody], Env) -> Val.
%%  Evaluate (lambda args ...).
%% eval_match_lambda(['match-lambda'|MatchClauses], Env) -> Val.
%%  Evaluate (match-lambda cls ...).

eval_lambda([lambda,Args|Body], Env) ->
    Apply =  fun (Vals) -> apply_lambda(Args, Body, Vals, Env) end,
    make_lambda(lambda_arity(Args), Apply);
eval_lambda(_, _) ->
    bad_form_error(lambda).

eval_match_lambda(['match-lambda'|Cls], Env) ->
    Apply = fun(Vals) -> apply_match_lambda(Cls, Vals, Env) end,
    make_lambda(match_lambda_arity(Cls), Apply).

make_lambda(Arity, Apply) ->
    %% This is a really ugly hack! But it's the same hack as in erl_eval.
    case Arity of
        0  -> fun () -> Apply([]) end;
        1  -> fun (A) -> Apply([A]) end;
        2  -> fun (A,B) -> Apply([A,B]) end;
        3  -> fun (A,B,C) -> Apply([A,B,C]) end;
        4  -> fun (A,B,C,D) -> Apply([A,B,C,D]) end;
        5  -> fun (A,B,C,D,E) -> Apply([A,B,C,D,E]) end;
        6  -> fun (A,B,C,D,E,F) -> Apply([A,B,C,D,E,F]) end;
        7  -> fun (A,B,C,D,E,F,G) -> Apply([A,B,C,D,E,F,G]) end;
        8  -> fun (A,B,C,D,E,F,G,H) -> Apply([A,B,C,D,E,F,G,H]) end;
        9  -> fun (A,B,C,D,E,F,G,H,I) -> Apply([A,B,C,D,E,F,G,H,I]) end;
        10 -> fun (A,B,C,D,E,F,G,H,I,J) -> Apply([A,B,C,D,E,F,G,H,I,J]) end;
        11 -> fun (A,B,C,D,E,F,G,H,I,J,K) -> Apply([A,B,C,D,E,F,G,H,I,J,K]) end;
        12 -> fun (A,B,C,D,E,F,G,H,I,J,K,L) ->
                      Apply([A,B,C,D,E,F,G,H,I,J,K,L]) end;
        13 -> fun (A,B,C,D,E,F,G,H,I,J,K,L,M) ->
                      Apply([A,B,C,D,E,F,G,H,I,J,K,L,M]) end;
        14 -> fun (A,B,C,D,E,F,G,H,I,J,K,L,M,N) ->
                      Apply([A,B,C,D,E,F,G,H,I,J,K,L,M,N]) end;
        15 -> fun (A,B,C,D,E,F,G,H,I,J,K,L,M,N,O) ->
                      Apply([A,B,C,D,E,F,G,H,I,J,K,L,M,N,O]) end;
        16 -> fun (A,B,C,D,E,F,G,H,I,J,K,L,M,N,O,P) ->
                      Apply([A,B,C,D,E,F,G,H,I,J,K,L,M,N,O,P]) end;
        17 -> fun (A,B,C,D,E,F,G,H,I,J,K,L,M,N,O,P,Q) ->
                      Apply([A,B,C,D,E,F,G,H,I,J,K,L,M,N,O,P,Q]) end;
        18 -> fun (A,B,C,D,E,F,G,H,I,J,K,L,M,N,O,P,Q,R) ->
                      Apply([A,B,C,D,E,F,G,H,I,J,K,L,M,N,O,P,Q,R]) end;
        19 -> fun (A,B,C,D,E,F,G,H,I,J,K,L,M,N,O,P,Q,R,S) ->
                      Apply([A,B,C,D,E,F,G,H,I,J,K,L,M,N,O,P,Q,R,S]) end;
        20 -> fun (A,B,C,D,E,F,G,H,I,J,K,L,M,N,O,P,Q,R,S,T) ->
                      Apply([A,B,C,D,E,F,G,H,I,J,K,L,M,N,O,P,Q,R,S,T]) end;
        _ -> eval_error({argument_limit,Arity})
    end.

lambda_arity(Args) ->
    case lfe_lib:is_symb_list(Args) of
        true -> length(Args);
        false -> bad_form_error(lambda)
    end.

apply_lambda(Args, Body, Vals, Env0) ->
    Env1 = bind_args(Args, Vals, Env0),
    eval_body(Body, Env1).

bind_args(['_'|As], [_|Es], Env) ->             %Ignore don't care variables
    bind_args(As, Es, Env);
bind_args([A|As], [E|Es], Env) when is_atom(A) ->
    bind_args(As, Es, lfe_env:add_vbinding(A, E, Env));
bind_args([], [], Env) -> Env;
bind_args(_As, _Vs, _Env) ->
    eval_error(bad_head_arity).

match_lambda_arity([[Pats|_]|Cls]) ->
    case lfe_lib:is_proper_list(Pats) of
        true -> match_lambda_arity(Cls, length(Pats));
        false -> bad_form_error('match-lambda')
    end.

match_lambda_arity([[Pats|_]|Cls], Ar) ->
    case lfe_lib:is_proper_list(Pats) andalso (length(Pats) =:= Ar) of
        true -> match_lambda_arity(Cls, Ar);
        false -> bad_form_error('match-lambda')
    end;
match_lambda_arity([], Ar) -> Ar;
match_lambda_arity(_, _) -> bad_form_error('match-lambda').

apply_match_lambda([[Pats|B0]|Cls], Vals, Env) ->
    if length(Vals) == length(Pats) ->
            %% Sneaky! m-l args a list of patterns so wrap with list
            %% and pass in as one pattern. Have already checked a
            %% proper list.
            case match_when([list|Pats], Vals, B0, Env) of
                {yes,B1,Vbs} -> eval_body(B1, lfe_env:add_vbindings(Vbs, Env));
                no -> apply_match_lambda(Cls, Vals, Env)
            end;
       true -> eval_error(bad_head_arity)
    end;
apply_match_lambda([], _Vals, _) -> eval_error(function_clause);
apply_match_lambda(_, _, _) -> bad_form_error('match-lambda').

%% eval_let([PatBindings|Body], Env) -> Value.

eval_let([Vbs|Body], Env0) ->
    %% Make sure we use the right environment.
    Fun = fun ([Pat,E], Env) ->
                  Val = eval_expr(E, Env0),
                  case match(Pat, Val, Env0) of
                      {yes,Bs} -> lfe_env:add_vbindings(Bs, Env);
                      no -> eval_error({badmatch,Val})
                  end;
              ([Pat,['when'|_]=G,E], Env) ->
                  Val = eval_expr(E, Env0),
                  case match_when(Pat, Val, [G], Env0) of
                      {yes,[],Bs} -> lfe_env:add_vbindings(Bs, Env);
                      no -> eval_error({badmatch,Val})
                  end;
              (_, _) -> bad_form_error('let')
          end,
    Env1 = lists:foldl(Fun, Env0, Vbs),
    eval_body(Body, Env1).

%% eval_let_function([FuncBindings|Body], Env) -> Value.

eval_let_function([Fbs|Body], Env0) ->
    Add = fun (F, Ar, Def, Lenv, Env) ->
                  add_lexical_func(F, Ar, Def, Lenv, Env)
          end,
    Fun = fun ([V,[lambda,Args|_]=Lambda], E) when is_atom(V) ->
                  Add(V, length(Args), Lambda, Env0, E);
              ([V,['match-lambda',[Pats|_]|_]=Match], E)
                when is_atom(V) ->
                  Add(V, length(Pats), Match, Env0, E);
              (_, _) -> bad_form_error('let-function')
          end,
    Env1 = lists:foldl(Fun, Env0, Fbs),
    %% io:fwrite("elf: ~p\n", [{Body,Env1}]),
    eval_body(Body, Env1).

%% eval_letrec_function([FuncBindings|Body], Env) -> Value.
%%  This is a tricky one. But we dynamically update the environment
%%  each time we are called.

eval_letrec_function([Fbs0|Body], Env0) ->
    %% Check and abstract out function bindings.
    Fun = fun ([V,[lambda,Args|_]=Lambda]) when is_atom(V) ->
                  {V,length(Args),Lambda};
              ([V,['match-lambda',[Pats|_]|_]=Match]) when is_atom(V) ->
                  {V,length(Pats),Match};
              (_) -> bad_form_error('letrec-function')
          end,
    Fbs1 = lists:map(Fun, Fbs0),
    Env1 = make_letrec_env(Fbs1, Env0),
    %% io:fwrite("elrf: ~p\n", [{Env0,Env1}]),
    eval_body(Body, Env1).

%% init_letrec_env(Env) -> {Lete,Env}.
%% make_letrec_env(Fbs, Env) -> Env.
%% make_letrec_env(Lete, Fbs, Env) -> {Lete,Env}.
%% extend_letrec_env(Lete, Fbs, Env) -> {Lete,Env}.
%%  Create local function bindings for a set of mutally recursive
%%  functions, for example from a module or a letrec-function. This is
%%  very similar to "Metacircular Semantics for Common Lisp Special
%%  Forms" by Henry Baker, except he uses macros whereas we directly
%%  fiddle with the environment and he keeps functions in a vector
%%  where we just push them into the environment. His version compiles
%%  much better (which we don't need) but is basically the same
%%  interpreted.

%% init_letrec_env(Env) -> {[],Env}.

make_letrec_env(Fbs0, Env) ->
    Fbs1 = lists:map(fun ({V,Ar,Body}) -> {V,Ar,{letrec,Body,Fbs0,Env}} end,
                     Fbs0),
    lfe_env:add_fbindings(Fbs1, Env).

%% extend_letrec_env(Lete0, Fbs0, Env0) ->
%%     {Lete0,Env0}.

%% add_lexical_func(Name, Arity, Def, FuncEnv, Env) -> Env.
%% add_lexical_func(Name, Arity, Def, Env) -> Env.
%% add_dynamic_func(Name, Arity, Def, Env) -> Env.
%%  Add a function definition in the correct format to the
%%  environment.

add_lexical_func(Name, Ar, Def, Fenv, Env) ->
    lfe_env:add_fbinding(Name, Ar, {lexical_expr,Def,Fenv}, Env).

add_lexical_func(Name, Ar, Def, Env) ->
    lfe_env:add_fbinding(Name, Ar, {lexical_expr,Def,Env}, Env).

add_dynamic_func(Name, Ar, Def, Env) ->
    lfe_env:add_fbinding(Name, Ar, {dynamic_expr,Def}, Env).

%% eval_apply(Function, Args, Env) -> Value.
%%  This is used to evaluate interpreted functions. Macros are
%%  expanded completely in the function definition before it is
%%  applied.

eval_apply({dynamic_expr,Func}, Es, Env) ->
    %% Don't clear variable bindings, even if this gives dynamic scoping.
    eval_apply_expr(Func, Es, Env);
eval_apply({lexical_expr,Func,Env}, Es, _) ->
    eval_apply_expr(Func, Es, Env);
eval_apply({letrec,Body,Fbs,Env}, Es, _) ->
    %% A function created by/for letrec-function.
    Fun = fun ({V,Ar,Lambda}, E) ->
                  lfe_env:add_fbinding(V, Ar, {letrec,Lambda,Fbs,Env}, E)
          end,
    NewEnv = lists:foldl(Fun, Env, Fbs),
    %% io:fwrite("la: ~p\n", [{Body,NewEnv}]),
    eval_apply_expr(Body, Es, NewEnv).

%% eval_apply_expr(Function, Args, Env) -> Value.
%%  Apply the Function definition to the (evaluated) Args in Env.
%%  Macros are expanded first.

eval_apply_expr(Func, Es, Env) ->
    case lfe_macro:expand_expr_all(Func, Env) of
        [lambda|_]=Lambda ->
            Fun = eval_lambda(Lambda, Env),
            erlang:apply(Fun, Es);
        ['match-lambda'|_]=Mlambda ->
            Fun = eval_match_lambda(Mlambda, Env),
            erlang:apply(Fun, Es);
        Fun when erlang:is_function(Fun) ->
            erlang:apply(Fun, Es)
    end.

%% eval_if(IfBody, Env) -> Value.

eval_if([Test,True], Env) ->                    %Add default false value
    eval_if(Test, True, ?Q(false), Env);
eval_if([Test,True,False], Env) ->
    eval_if(Test, True, False, Env).

eval_if(Test, True, False, Env) ->
    case eval_expr(Test, Env) of
        true -> eval_expr(True, Env);
        false -> eval_expr(False, Env);
        _ -> eval_error(if_expression)          %Explicit error here
    end.

%% eval_case(CaseBody, Env) -> Value.

eval_case([E|Cls], Env) ->
    eval_case_clauses(eval_expr(E, Env), Cls, Env).

%% eval_case_clauses(Value, Clauses, Env) -> Value.

eval_case_clauses(V, Cls, Env) ->
    case match_clause(V, Cls, Env) of
        {yes,B,Vbs} -> eval_body(B, lfe_env:add_vbindings(Vbs, Env));
        no -> eval_error({case_clause,V})
    end.

%% match_clause(Value, Clauses, Env) -> {yes,Body,Bindings} | no.

match_clause(V, [[Pat|B0]|Cls], Env) ->
    case match_when(Pat, V, B0, Env) of
        {yes,_,_}=Yes -> Yes;
        no -> match_clause(V, Cls, Env)
    end;
match_clause(_, [], _) -> no.

%% eval_receive(Body, Env) -> Value
%%  (receive (pat . body) ... [(after timeout . body)])

eval_receive(Body, Env) ->
    {Cls,Te,Tb} = split_receive(Body, []),
    case eval_expr(Te, Env) of            %Check timeout
        infinity -> receive_clauses(Cls, Env);
        T -> receive_clauses(T, Tb, Cls, Env)
    end.

split_receive([['after',T|B]], Rcls) ->
    {lists:reverse(Rcls),T,B};
split_receive([Cl|Cls], Rcls) ->
    split_receive(Cls, [Cl|Rcls]);
split_receive([], Rcls) ->
    {lists:reverse(Rcls),?Q(infinity),[]}.    %No timeout, return 'infinity.

%% receive_clauses(Clauses, Env) -> Value.
%%  Recurse down message queue. We are only called with timeout value
%%  of 'infinity'. Always pass over all messages in queue.

receive_clauses(Cls, Env) -> receive_clauses(Cls, Env, []).

receive_clauses(Cls, Env, Ms) ->
    receive
        Msg ->
            case match_clause(Msg, Cls, Env) of
                {yes,B,Vbs} ->
                    merge_queue(Ms),
                    eval_body(B, lfe_env:add_vbindings(Vbs, Env));
                no -> receive_clauses(Cls, Env, [Msg|Ms])
            end
    end.

%% receive_clauses(Timeout, TimeoutBody, Clauses, Env) -> Value.
%%  Recurse down message queue until timeout. We are never called with
%%  timeout value of 'infinity'. Always pass over all messages in
%%  queue.

receive_clauses(T, Tb, Cls, Env) ->
    statistics(runtime),            %Set runtime counter
    receive_clauses(T, Tb, Cls, Env, []).

receive_clauses(T, Tb, Cls, Env, Ms) ->
    receive
        Msg ->
            case match_clause(Msg, Cls, Env) of
                {yes,B,Vbs} ->
                    merge_queue(Ms),
                    eval_body(B, lfe_env:add_vbindings(Vbs, Env));
                no ->
                    %% Check how much time left and recurse correctly.
                    {_,T1} = statistics(runtime),
                    if  T-T1 < 0 ->
                            receive_clauses(0, Tb, Cls, Env, [Msg|Ms]);
                        true ->
                            receive_clauses(T-T1, Tb, Cls, Env, [Msg|Ms])
                    end
            end
    after T ->
            merge_queue(Ms),
            eval_body(Tb, Env)
    end.

merge_queue(Ms) ->
    send_all(recv_all(Ms), self()).

recv_all(Xs) ->
    receive
        X -> recv_all([X|Xs])
    after 0 ->
            lists:reverse(Xs)
    end.

send_all([X|Xs], Self) ->
    Self ! X,
    send_all(Xs, Self);
send_all([], _) -> true.

%% eval_try(TryBody, Env) -> Value.
%%  Complicated by checking legal combinations of options.

eval_try([E,['case'|Case]|Catch], Env) ->
    eval_try_catch(Catch, E, Case, Env);
eval_try([E|Catch], Env) ->
    eval_try_catch(Catch, E, [], Env);
eval_try(_, _) ->
    bad_form_error('try').

eval_try_catch([['catch'|Catch]], E, Case, Env) ->
    eval_try(E, Case, Catch, [], Env);
eval_try_catch([['catch'|Catch],['after'|After]], E, Case, Env) ->
    eval_try(E, Case, Catch, After, Env);
eval_try_catch([['after'|After]], E, Case, Env) ->
    eval_try(E, Case, [], After, Env);
eval_try_catch(_, _, _, _) ->
    bad_form_error('try').

%% We do it all in one, not so efficient but easier.
eval_try(E, Case, Catch, After, Env) ->
    check_exceptions(Catch),                    %Check for legal exceptions
    try
        eval_expr(E, Env)
    of
        Value when Case =:= [] -> Value;
        Value ->
            case match_clause(Value, Case, Env) of
                {yes,Body,Vbs} ->
                    eval_body(Body, lfe_env:add_vbindings(Vbs, Env));
                no ->
                    ?EVAL_ERROR({try_clause,Value})
            end
    catch
        ?CATCH(Class, Error, Stack)
            %% Try returns the stacktrace here so we have to
            %% explicitly get it here just in case.
            case match_clause({Class,Error,Stack}, Catch, Env) of
                {yes,Body,Vbs} ->
                    eval_body(Body, lfe_env:add_vbindings(Vbs, Env));
                no ->
                    erlang:raise(Class, Error, Stack)
            end
    after
        eval_body(After, Env)
    end.

check_exceptions([Cl|Cls]) ->
    case Cl of
        [[tuple,_,_,St]|_] when is_atom(St) -> ok;
        ['_'|_] -> ok;
        [Other|_] -> ?EVAL_ERROR({illegal_exception,Other})
    end,
    check_exceptions(Cls);
check_exceptions([]) -> ok.


%% eval_call([Mod,Func|Args], Env) -> Value.
%%  Evaluate the module, function and args and then apply the function.

eval_call([M0,F0|As0], Env) ->
    M1 = eval_expr(M0, Env),
    F1 = eval_expr(F0, Env),
    As1 = eval_list(As0, Env),
    %% io:fwrite("call: ~p\n    =>~p\n", [[call,M0,F0,As0],{M1,F1,As1}]),
    erlang:apply(M1, F1, As1).

%% match_when(Pattern, Value, Body, Env) -> {yes,RestBody,Bindings} | no.
%%  Try to match pattern and evaluate guard.

match_when(Pat, V, B0, Env) ->
    case match(Pat, V, Env) of
        {yes,Vbs} ->
            case B0 of
                [['when'|G]|B1] ->
                    case eval_guard(G, lfe_env:add_vbindings(Vbs, Env)) of
                        true -> {yes,B1,Vbs};
                        false -> no
                    end;
                B1 -> {yes,B1,Vbs}
            end;
        no -> no
    end.

%% eval_guard(GuardTests, Env) -> true | false.
%% Guards are fault safe, catch all errors in guards here and fail guard.

eval_guard(Gts, Env) ->
    try
        eval_gbody(Gts, Env)
    of
        true -> true;
        _Other -> false                         %Fail guard
    catch
        ?CATCH(error, illegal_guard, Stack)     %Handle illegal guard
            erlang:raise(error, illegal_guard, Stack);
        _:_ -> false                            %Fail guard
    end.

%% eval_gbody(GuardTests, Env) -> true | false.
%% A body is a sequence of tests which must all succeed.

eval_gbody(Gts, Env) ->
    lists:all(fun (Gt) -> eval_gexpr(Gt, Env) end, Gts).

%% eval_gexpr(Sexpr, Environment) -> Value.
%%  Evaluate a guard sexpr in the current environment.

%% Handle the Core data special forms.
eval_gexpr(?Q(E), _) -> E;
eval_gexpr([cons,H,T], Env) ->
    [eval_gexpr(H, Env)|eval_gexpr(T, Env)];
eval_gexpr([car,E], Env) -> hd(eval_gexpr(E, Env)); %Provide lisp names
eval_gexpr([cdr,E], Env) -> tl(eval_gexpr(E, Env));
eval_gexpr([list|Es], Env) -> eval_glist(Es, Env);
eval_gexpr([tuple|Es], Env) -> list_to_tuple(eval_glist(Es, Env));
eval_gexpr([tref,Tup,I], Env) ->
    element(eval_gexpr(I, Env), eval_gexpr(Tup, Env));
eval_gexpr([binary|Bs], Env) -> eval_gbinary(Bs, Env);
%% Check map special forms which translate into legal guard expressions.
eval_gexpr([map|As], Env) ->
    eval_gmap(As, Env);
eval_gexpr([msiz,Map], Env) ->
    eval_gmap_size(msiz, Map, Env);
eval_gexpr([mref,Map,Key], Env) ->
    eval_gmap_get(mref, Map, Key, Env);
eval_gexpr([mset,Map|As], Env) ->
    eval_gmap_set(mset, Map, As, Env);
eval_gexpr([mupd,Map|As], Env) ->
    eval_gmap_update(mupd, Map, As, Env);
eval_gexpr(['map-size',Map], Env) ->
    eval_gmap_size('map-size', Map, Env);
eval_gexpr(['map-get',Map,Key], Env) ->
    eval_gmap_get('map-get', Map, Key, Env);
eval_gexpr(['map-set',Map|As], Env) ->
    eval_gmap_set('map-set', Map, As, Env);
eval_gexpr(['map-update',Map|As], Env) ->
    eval_gmap_update('map-update', Map, As, Env);
%% Record special forms.
eval_gexpr(['is-record',E,Name], Env) ->
    Ev = eval_gexpr(E, Env),
    test_is_record(Ev, Name, Env);
eval_gexpr(['record-index',Name,F], Env) ->
    get_record_index(Name, F, Env);
eval_gexpr(['record-field',E,Name,F], Env) ->
    Ev = eval_gexpr(E, Env),
    get_record_field(Ev, Name, F, Env);
%% Struct special forms.
eval_gexpr(['is-struct',E0], Env) ->
    Ev = eval_gexpr(E0, Env),
    test_is_struct(Ev);
eval_gexpr(['is-struct',E0,Name], Env) ->
    Ev = eval_gexpr(E0, Env),
    test_is_struct(Ev, Name);
eval_gexpr(['struct-field',E,Name,F], Env) ->
    Ev = eval_gexpr(E, Env),
    get_struct_field(Ev, Name, F);
%% Handle the Core closure special forms.
%% Handle the control special forms.
eval_gexpr(['progn'|Body], Env) -> eval_gbody(Body, Env);
eval_gexpr(['if'|Body], Env) -> eval_gif(Body, Env);
eval_gexpr([call,?Q(erlang),?Q(Fun)|As], Env) ->
    Ar = length(As),
    case lfe_internal:is_guard_bif(Fun, Ar) of
        true -> erlang:apply(erlang, Fun, eval_glist(As, Env));
        false -> illegal_guard_error()
    end;
eval_gexpr([Fun|Es], Env) when is_atom(Fun), Fun =/= call ->
    Ar = length(Es),
    case get_gbinding(Fun, Ar, Env) of
        {yes,M,F} -> erlang:apply(M, F, eval_glist(Es, Env));
        no -> illegal_guard_error()
    end;
eval_gexpr([_|_]=S, _) ->                       %Test is literal string
    case lfe_lib:is_posint_list(S) of
        true -> S;                              %It is an "atomic" type
        false -> illegal_guard_error()          %It is a bad application form
    end;
eval_gexpr(Symb, Env) when is_atom(Symb) ->
    case lfe_env:get_vbinding(Symb, Env) of
        {yes,Val} -> Val;
        no -> unbound_symbol_error(Symb)
    end;
eval_gexpr(E, _) -> E.                          %Atoms evaluate to themselves.

%% get_gbinding(NAme, Arity, Env) -> {yes,Module,Fun} | no.
%%  Get the guard function binding. Locally bound function cannot be
%%  called in guard only guard BIF.

get_gbinding(Name, Ar, Env) ->
    case lfe_env:is_fbound(Name, Ar, Env) of
        true -> no;                             %Locally bound function
        false ->
            case lfe_internal:is_guard_bif(Name, Ar) of
                true -> {yes,erlang,Name};
                false -> no
            end
    end.

eval_glist(Es, Env) ->
    lists:map(fun (E) -> eval_gexpr(E, Env) end, Es).

%% eval_gmap(Args, Env) -> Map.
%% eval_gmap_size(Form, Map, Env) -> Value.
%% eval_gmap_get(Form, Map, Key, Env) -> Value.
%% eval_gmap_set(Form, Map, Args, Env) -> Map.
%% eval_gmap_update(Form, Map, Args, Env) -> Map.

eval_gmap(Args, Env) ->
    Pairs = eval_gmap_pairs(map, Args, Env),
    maps:from_list(Pairs).

eval_gmap_size(_Form, Map, Env) ->
    erlang:map_size(eval_gexpr(Map, Env)).      %Use the BIF

eval_gmap_get(_Form, Map, K, Env) ->
    Key = eval_gmap_key(K, Env),
    erlang:map_get(Key, eval_gexpr(Map, Env)).  %Use the BIF

eval_gmap_set(Form, M, Args, Env) ->
    Map = eval_gexpr(M, Env),
    Pairs = eval_gmap_pairs(Form, Args, Env),
    lists:foldl(fun maps_put/2, Map, Pairs).

eval_gmap_update(Form, M, Args, Env) ->
    Map = eval_gexpr(M, Env),
    Pairs = eval_gmap_pairs(Form, Args, Env),
    lists:foldl(fun maps_update/2, Map, Pairs).

%% eval_gmap_pairs(Form, Args, Env) -> [{K,V}].

eval_gmap_pairs(Form, [K,V|As], Env) ->
    P = {eval_gmap_key(K, Env),eval_gexpr(V, Env)},
    [P|eval_gmap_pairs(Form, As, Env)];
eval_gmap_pairs(_Form, [], _) -> [];
eval_gmap_pairs(Form, _, _) -> bad_form_error(Form).

%% eval_map_key(Key, Env) -> Value.
%%  A map key can only be a literal in 17 but can be anything in 18..


-ifdef(HAS_FULL_KEYS).
eval_gmap_key(Key, Env) ->
    eval_gexpr(Key, Env).
-else.
eval_gmap_key(?Q(E), _) -> E;
eval_gmap_key([_|_]=L, _) ->
    case lfe_lib:is_posint_list(L) of
        true -> L;                              %Literal strings only
        false -> illegal_mapkey_error(L)
    end;
eval_gmap_key(E, _) when not is_atom(E) -> E;    %Everything else
eval_gmap_key(E, _) -> illegal_mapkey_error(E).
-endif.

%% eval_gbinary(Bitsegs, Env) -> Binary.
%%  Construct a binary from Bitsegs. This code is taken from eval_bits.erl.

eval_gbinary(Segs, Env) ->
    Eval = fun (E) -> eval_gexpr(E, Env) end,
    lfe_eval_bits:expr_bitsegs(Segs, Eval).

%% eval_gif(IfBody, Env) -> Val.

eval_gif([Test,True], Env) ->
    eval_gif(Test, True, ?Q(false), Env);
eval_gif([Test,True,False], Env) ->
    eval_gif(Test, True, False, Env).

eval_gif(Test, True, False, Env) ->
    case eval_gexpr(Test, Env) of
        true -> eval_gexpr(True, Env);
        false -> eval_gexpr(False, Env)
    end.

%% match(Pattern, Value, Env) -> {yes,PatBindings} | no.
%%  Try to match Pattern against Value within the current environment
%%  returning bindings. Bindings is an orddict.

match(Pat, Val, Env) -> match(Pat, Val, [], Env).

match(?Q(P), Val, Pbs, _) ->
    if P =:= Val -> {yes,Pbs};
       true -> no
    end;
match(['=',P1,P2], Val, Pbs0, Env) ->           %Aliases
    case match(P1, Val, Pbs0, Env) of
        {yes,Pbs1} -> match(P2, Val, Pbs1, Env);
        no -> no
    end;
match([cons,H,T], Val, Pbs, Env) ->             %Explicit cons constructor
    match_cons(H, T, Val, Pbs, Env);
match([list|Ps], Val, Pbs, Env) ->              %Explicit list constructor
    match_list(Ps, Val, Pbs, Env);
match([tuple|Ps], Val, Pbs, Env) ->
    %% io:fwrite("~p ~p\n", [Ps,Val]),
    case is_tuple(Val) of
        true -> match_list(Ps, tuple_to_list(Val), Pbs, Env);
        false -> no
    end;
match([binary|Ss], Val, Pbs, Env) ->
    case is_bitstring(Val) of
        true -> match_binary(Ss, Val, Pbs, Env);
        false -> no
    end;
match([map|Ps], Val, Pbs, Env) ->
    case ?IS_MAP(Val) of
        true -> match_map(Ps, Val, Pbs, Env);
        false -> no
    end;
%% Record patterns.
match(['record',Name|Ps], Val, Pbs, Env) ->
    match_record_tuple(Name, Ps, Val, Pbs, Env);
%% make-record has been deprecated but we sill accept it for now.
match(['make-record',Name|Ps], Val, Pbs, Env) ->
    match(['record',Name|Ps], Val, Pbs, Env);
match(['record-index',Name,F], Val, Pbs, Env) ->
    case lfe_env:get_record(Name, Env) of
        {yes,Fields} ->
            Index = get_field_index(Name, Fields, F),
            match(Index, Val, Pbs, Env);
        no -> undefined_record_error(Name)
    end;
%% Struct patterns.
match(['struct',Name|Fs], Val, Pbs, Env) ->
    match_struct_map(Name, Fs, Val, Pbs, Env);
%% No constructor list forms.
match([_|_]=List, Val, Pbs, _) ->               %No constructor
    case lfe_lib:is_posint_list(List) of        %Accept strings
        true ->
            if List =:= Val -> {yes,Pbs};
               true -> no
            end;
        false -> eval_error({illegal_pattern,List})
    end;
match([], [], Pbs, _) -> {yes,Pbs};
match(Symb, Val, Pbs, Env) when is_atom(Symb) ->
    match_symb(Symb, Val, Pbs, Env);
match(Val, Val, Pbs, _) -> {yes,Pbs};
match(_, _, _, _) -> no.

match_cons(H, T, [V|Vs], Pbs0, Env) ->
    case match(H, V, Pbs0, Env) of
        {yes,Pbs1} -> match(T, Vs, Pbs1, Env);
        no -> no
    end;
match_cons(_, _, _, _, _) -> no.

match_list([P|Ps], [V|Vs], Pbs0, Env) ->
    case match(P, V, Pbs0, Env) of
        {yes,Pbs1} -> match_list(Ps, Vs, Pbs1, Env);
        no -> no
    end;
match_list([], [], Pbs, _) -> {yes,Pbs};
match_list(_, _, _, _) -> no.

match_symb('_', _, Pbs, _) -> {yes,Pbs};        %Don't care variable.
match_symb(S, Val, Pbs, _) ->
    %% Check if Symb already bound.
    case orddict:find(S, Pbs) of
        {ok,Val} -> {yes,Pbs};                  %Bound to the same value
        {ok,_} -> no;                           %Bound to a different value
        error ->
            {yes,orddict:store(S, Val, Pbs)}    %Not yet bound
    end.

 %% match_record_tuple(Name, Val, Pbs, Env) -> {yes,Pbs} | no.
%%  '_' is the default value for unspecified field values.

match_record_tuple(Name, Pats, Val, Pbs, Env) ->
    case lfe_env:get_record(Name, Env) of
        {yes,Fields} ->
            Ps = match_record_patterns(Fields, Pats),
            %% io:format("pat\n   ~p\n   ~p\n   ~p\n", [Val,Fields,Ps]),
            match([tuple,Name|Ps], Val, Pbs, Env);
        no -> undefined_record_error(Name)
    end.

match_record_patterns(Fields, Pats) ->
    DefDef = default_record_value(Pats),
    Mfun = fun ([F|_]) ->
                   UseDef = record_or_field_def(DefDef, '_'),
                   make_field_pat(F, Pats, UseDef);
               (F) ->
                   UseDef = record_or_field_def(DefDef, '_'),
                   make_field_pat(F, Pats, UseDef)
               end,
    lists:map(Mfun, Fields).

%% make_field_pat(Field, Pats, UseDef) -> Pat.

make_field_pat(F, [F,P|_], _Def) -> P;
make_field_pat(F, [_,_|Pats], Def) ->
    make_field_pat(F, Pats, Def);
make_field_pat(_F, [PatF], _Def) ->
    eval_error({missing_record_field_value,PatF});
make_field_pat(_, [], Def) -> Def.

%% match_struct_map(Name, Pats, Val, Pbs, Env) -> {yes,Pbs} | no.

match_struct_map(Name, Pats, Val, Pbs, Env) ->
    Str = [map,?Q('__struct__'),?Q(Name)|match_struct_fields(Pats)],
    match(Str, Val, Pbs, Env).

match_struct_fields([Key,Val|Kvs]) ->
    [?Q(Key),Val|match_struct_fields(Kvs)];
match_struct_fields([Key]) -> eval_error({missing_struct_field_value,Key});
match_struct_fields([]) ->  [].

%% match_binary(Bitsegs, Binary, PatBindings, Env) -> {yes,PatBindings} | no.
%%  Match Bitsegs against Binary. Bad matches result in an error, we
%%  use catch to trap it.

match_binary(Segs, Bin, Pbs0, Env) ->
    lfe_eval_bits:match_bitsegs(Segs, Bin, Pbs0, Env).

%% match_map(Pairs, Map, PatBindings, Env) -> {yes,PatBindings} | no.

match_map([K,V|Ps], Map, Pbs0, Env) ->
    Pat = pat_map_key(K),                       %Evaluate the key
    case maps:is_key(Pat, Map) of
        true ->
            case match(V, maps:get(Pat, Map), Pbs0, Env) of
                {yes,Pbs1} -> match_map(Ps, Map, Pbs1, Env);
                no -> no
            end;
        false -> no
    end;
match_map([], _, Pbs, _) -> {yes,Pbs};
match_map(Ps, _, _, _) -> eval_error({illegal_pattern,Ps}).

pat_map_key(?Q(E)) -> E;
pat_map_key([_|_]=L) ->
    case lfe_lib:is_posint_list(L) of
        true -> L;                              %Literal strings only
        false -> illegal_mapkey_error(L)
    end;
pat_map_key(E) when not is_atom(E) -> E;        %Everything else
pat_map_key(K) -> illegal_mapkey_error(K).

%% eval_lit(Literal, Env) -> Value.
%%  Evaluate a literal expression. Error if invalid.

eval_lit(?Q(K), _) -> K;
eval_lit([cons,H,T], Env) ->
    [eval_lit(H, Env)|eval_lit(T, Env)];
eval_lit([list|Es], Env) ->
    eval_lit_list(Es, Env);
eval_lit([tuple|Es], Env) ->
    list_to_tuple(eval_lit_list(Es, Env));
eval_lit([binary|Bs], Env) ->
    eval_lit_binary(Bs, Env);
eval_lit([map|As], Env) ->
    KVs = eval_lit_map(As, Env),
    maps:from_list(KVs);
eval_lit([_|_]=Lit, _) ->                       %All other lists illegal
    eval_error({illegal_literal,Lit});
eval_lit(Symb, Env) when is_atom(Symb) ->
    case lfe_env:get_vbinding(Symb, Env) of
        {yes,Val} -> Val;
        no -> unbound_symbol_error(Symb)
    end;
eval_lit(Key, _) -> Key.                        %Literal values

eval_lit_list(Es, Env) ->
    [ eval_lit(E, Env) || E <- Es ].

eval_lit_binary(Segs, Env) ->
    Eval = fun (S) -> eval_lit(S, Env) end,
    lfe_eval_bits:expr_bitsegs(Segs, Eval).

eval_lit_map([K,V|As], Env) ->
    [{eval_lit(K, Env),eval_lit(V, Env)}|eval_lit_map(As, Env)];
eval_lit_map([], _) -> [].

%% Error functions.

badarg_error() -> eval_error(badarg).

unbound_symbol_error(Sym) ->
    eval_error({unbound_symbol,Sym}).

undefined_function_error(Func, Ar) ->
    eval_error({undefined_function,{Func,Ar}}).

bad_form_error(Form) ->
    eval_error({bad_form,Form}).

illegal_guard_error() ->
    eval_error(illegal_guard).

illegal_mapkey_error(Key) ->
    eval_error({illegal_mapkey,Key}).

undefined_record_error(Rec) ->
    eval_error({undefined_record,Rec}).

undefined_record_field_error(Rec, F) ->
    eval_error({undefined_record_field,Rec,F}).

eval_error(Error) ->
    erlang:raise(error, Error, ?STACKTRACE).

%%% Helper functions
