erl_eval.erl

来自「OTP是开放电信平台的简称」· ERL 代码 · 共 1,167 行 · 第 1/3 页

	    reverse(Xs)
    end.

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


%% match_clause -> {Body, Bindings} or nomatch

match_clause(Cs, Vs, Bs, Lf) ->
    match_clause(Cs, Vs, Bs, Lf, none).

match_clause([{clause,_,H,G,B}|Cs], Vals, Bs, Lf, Ef) ->
    case match_list(H, Vals, Bs) of
	{match, Bs1} ->
	    case guard(G, Bs1, Lf, Ef) of
		true -> {B, Bs1};
		false -> match_clause(Cs, Vals, Bs, Lf, Ef)
	    end;
	nomatch -> match_clause(Cs, Vals, Bs, Lf, Ef)
    end;
match_clause([], _Vals, _Bs, _Lf, _Ef) ->
    nomatch.

%% guard(GuardTests, Bindings, LocalFuncHandler, ExtFuncHandler) -> bool()
%%  Evaluate a guard.  We test if the guard is a true guard.

guard(L=[G|_], Bs0, Lf, Ef) when is_list(G) ->
    guard1(L, Bs0, Lf, Ef);
guard(L, Bs0, Lf, Ef) ->
    guard0(L, Bs0, Lf, Ef).

%% disjunction of guard conjunctions
guard1([G|Gs], Bs0, Lf, Ef) when is_list(G) ->
    case guard0(G, Bs0, Lf, Ef) of
	true ->
	    true;
	false ->
	    guard1(Gs, Bs0, Lf, Ef)
    end;
guard1([], _Bs, _Lf, _Ef) -> false.

%% guard conjunction
guard0([G|Gs], Bs0, Lf, Ef) ->
    case erl_lint:is_guard_test(G) of
	true ->
	    case guard_test(G, Bs0, Lf, Ef) of
                {value,true,Bs} -> guard0(Gs, Bs, Lf, Ef);
                {value,false,_} -> false
	    end;
	false ->
	    erlang:raise(error, guard_expr, stacktrace())
    end;
guard0([], _Bs, _Lf, _Ef) -> true.

%% guard_test(GuardTest, Bindings, LocalFuncHandler, ExtFuncHandler) ->
%%	{value,bool(),NewBindings}.
%%  Evaluate one guard test. Never fails, returns bool().

guard_test({call,_,{atom,_,Name},As0}, Bs0, Lf, Ef) ->
    try 
        {As1,Bs1} = expr_list(As0, Bs0, Lf, Ef),
        {value,true,_} = type_test(Name, As1, Bs1, Ef)
    catch error:_ -> {value,false,Bs0} end;
guard_test({op,_,Op,A0}, Bs0, Lf, Ef) ->
    try
        {[A],Bs1} = expr_list([A0], Bs0, Lf, Ef),
        {value,true,_} = eval_op(Op, A, Bs1, Ef, none)
    catch error:_ -> {value,false,Bs0} end;
guard_test({op,_,'andalso',_Lhs0,_Rhs0}=G, Bs0, Lf, Ef) ->
    try {value,true,_} = expr(G, Bs0, Lf, Ef, none)
    catch error:_ -> {value,false,Bs0} end;
guard_test({op,_,'orelse',_Lhs0,_Rhs0}=G, Bs0, Lf, Ef) ->
    try {value,true,_} = expr(G, Bs0, Lf, Ef, none)
    catch error:_ -> {value,false,Bs0} end;
guard_test({op,_,Op,Lhs0,Rhs0}, Bs0, Lf, Ef) ->
    try
        {[Lhs,Rhs],Bs1} = expr_list([Lhs0,Rhs0], Bs0, Lf, Ef),
        {value,true,_} = eval_op(Op, Lhs, Rhs, Bs1, Ef, none)
    catch error:_ -> {value,false,Bs0} end;   
guard_test({atom,_,true}, Bs, _Lf, _Ef) -> {value,true,Bs};
guard_test({atom,_,false}, Bs, _Lf, _Ef) -> {value,false,Bs};
guard_test({var,_,V}, Bs, _Lf, _Ef) ->
    {value,Val} = binding(V, Bs),
    {value,Val =:= true,Bs};
guard_test({call,_L,{remote,_Lr,{atom,_Lm,erlang},{atom,_Lf,F}},As0}, 
          Bs0, Lf, Ef) ->
    try
        {As1,Bs1} = expr_list(As0, Bs0, Lf, Ef),
        {value,true,_} = type_test(F, As1, Bs1, Ef)
    catch error:_ -> {value,false,Bs0} end;
guard_test({call,L,{tuple,L1,[{atom,Lm,erlang},{atom,L2,F}]},As}, 
         Bs0, Lf, Ef) ->
    guard_test({call,L,{remote,L1,{atom,Lm,erlang},{atom,L2,F}},As}, 
               Bs0, Lf, Ef);
guard_test(_Other, Bs, _Lf, _Ef) -> {value,false,Bs}.

type_test(Test, As, Bs, Ef) ->
    do_apply({erlang,type_test(Test)}, As, Bs, Ef, none).

type_test(integer) -> is_integer;
type_test(float) -> is_float;
type_test(number) -> is_number;
type_test(atom) -> is_atom;
type_test(constant) -> is_constant;
type_test(list) -> is_list;
type_test(tuple) -> is_tuple;
type_test(pid) -> is_pid;
type_test(reference) -> is_reference;
type_test(port) -> is_port;
type_test(function) -> is_function;
type_test(binary) -> is_binary;
type_test(record) -> is_record;
type_test(Test) -> Test.


%% match(Pattern, Term, Bindings) ->
%%	{match,NewBindings} | nomatch
%%      or erlang:error({illegal_pattern, Pattern}).
%%  Try to match Pattern against Term with the current bindings.

match(Pat, Term, Bs) ->
    match(Pat, Term, Bs, Bs).

%% Bs are the bindings that are augmented with new bindings. BBs are
%% the bindings used for "binsize" variables (in <<X:Y>>, Y is a
%% binsize variable).

match(Pat, Term, Bs, BBs) ->
    case catch match1(Pat, Term, Bs, BBs) of
	invalid ->
	    erlang:raise(error, {illegal_pattern,Pat}, stacktrace());
	Other ->
	    Other
    end.

string_to_conses([], _, Tail) -> Tail;
string_to_conses([E|Rest], Line, Tail) ->
    {cons, Line, {integer, Line, E}, string_to_conses(Rest, Line, Tail)}.

match1({atom,_,A0}, A, Bs, _BBs) ->
    case A of
	A0 -> {match,Bs};
	_ -> throw(nomatch)
    end;
match1({integer,_,I0}, I, Bs, _BBs) ->
    case I of
	I0 -> {match,Bs};
	_ -> throw(nomatch)
    end;
match1({float,_,F0}, F, Bs, _BBs) ->
    case F of
	F0 -> {match,Bs};
	_ -> throw(nomatch)
    end;
match1({char,_,C0}, C, Bs, _BBs) ->
    case C of
	C0 -> {match,Bs};
	_ -> throw(nomatch)
    end;
match1({var,_,'_'}, _, Bs, _BBs) ->		%Anonymous variable matches
    {match,Bs};					% everything, no new bindings
match1({var,_,Name}, Term, Bs, _BBs) ->
    case binding(Name, Bs) of
	{value,Term} ->
	    {match,Bs};
	{value,_} ->
	    throw(nomatch);
	unbound ->
	    {match,add_binding(Name, Term, Bs)}
    end;
match1({match,_,Pat1,Pat2}, Term, Bs0, BBs) ->
    {match, Bs1} = match1(Pat1, Term, Bs0, BBs),
    match1(Pat2, Term, Bs1, BBs);
match1({string,_,S0}, S, Bs, _BBs) ->
    case S of
	S0 -> {match,Bs};
	_ -> throw(nomatch)
    end;
match1({nil,_}, Nil, Bs, _BBs) ->
    case Nil of
	[] -> {match,Bs};
	_ -> throw(nomatch)
    end;
match1({cons,_,H,T}, [H1|T1], Bs0, BBs) ->
    {match,Bs} = match1(H, H1, Bs0, BBs),
    match1(T, T1, Bs, BBs);
match1({cons,_,_,_}, _, _Bs, _BBs) ->
    throw(nomatch);
match1({tuple,_,Elts}, Tuple, Bs, BBs) when is_tuple(Tuple),
					    length(Elts) =:= size(Tuple) ->
    match_tuple(Elts, Tuple, 1, Bs, BBs);
match1({tuple,_,_}, _, _Bs, _BBs) ->
    throw(nomatch);
match1({bin, _, Fs}, <<_/bitstr>>=B, Bs0, BBs) ->
    eval_bits:match_bits(Fs, B, Bs0, BBs,
			 fun(L, R, Bs) -> match1(L, R, Bs, BBs) end,
			 fun(E, Bs) -> expr(E, Bs, none, none, none) end);
match1({bin,_,_}, _, _Bs, _BBs) ->
    throw(nomatch);
match1({op,_,'++',{nil,_},R}, Term, Bs, BBs) ->
    match1(R, Term, Bs, BBs);
match1({op,_,'++',{cons,Li,{integer,L2,I},T},R}, Term, Bs, BBs) ->
    match1({cons,Li,{integer,L2,I},{op,Li,'++',T,R}}, Term, Bs, BBs);
match1({op,_,'++',{string,Li,L},R}, Term, Bs, BBs) ->
    match1(string_to_conses(L, Li, R), Term, Bs, BBs);
match1({op,Line,Op,A}, Term, Bs, BBs) ->
    case partial_eval({op,Line,Op,A}) of
	{op,Line,Op,A} ->
	    throw(invalid);
	X ->
	    match1(X, Term, Bs, BBs)
    end;
match1({op,Line,Op,L,R}, Term, Bs, BBs) ->
    case partial_eval({op,Line,Op,L,R}) of
	{op,Line,Op,L,R} ->
	    throw(invalid);
	X ->
	    match1(X, Term, Bs, BBs)
    end;
match1(_, _, _Bs, _BBs) ->
    throw(invalid).

match_tuple([E|Es], Tuple, I, Bs0, BBs) ->
    {match,Bs} = match1(E, element(I, Tuple), Bs0, BBs),
    match_tuple(Es, Tuple, I+1, Bs, BBs);
match_tuple([], _, _, Bs, _BBs) ->
    {match,Bs}.

%% match_list(PatternList, TermList, Bindings) ->
%%	{match,NewBindings} | nomatch
%%  Try to match a list of patterns against a list of terms with the
%%  current bindings.

match_list(Ps, Ts, Bs) ->
    match_list(Ps, Ts, Bs, Bs).

match_list([P|Ps], [T|Ts], Bs0, BBs) ->
    case match(P, T, Bs0, BBs) of
	{match,Bs1} -> match_list(Ps, Ts, Bs1, BBs);
	nomatch -> nomatch
    end;
match_list([], [], Bs, _BBs) ->
    {match,Bs};
match_list(_, _, _Bs, _BBs) ->
    nomatch.

%% new_bindings()
%% bindings(Bindings)
%% binding(Name, Bindings)
%% add_binding(Name, Value, Bindings)
%% del_binding(Name, Bindings)

new_bindings() -> orddict:new().

bindings(Bs) -> orddict:to_list(Bs).

binding(Name, Bs) ->
    case orddict:find(Name, Bs) of
	{ok,Val} -> {value,Val};
	error -> unbound
    end.

add_binding(Name, Val, Bs) -> orddict:store(Name, Val, Bs).

del_binding(Name, Bs) -> orddict:erase(Name, Bs).

add_bindings(Bs1, Bs2) ->
    foldl(fun ({Name,Val}, Bs) -> orddict:store(Name, Val, Bs) end,
	  Bs2, orddict:to_list(Bs1)).

merge_bindings(Bs1, Bs2) ->
    foldl(fun ({Name,Val}, Bs) ->
		  case orddict:find(Name, Bs) of
		      {ok,Val} -> Bs;		%Already with SAME value
		      {ok,V1} -> 
			  erlang:raise(error, {badmatch,V1}, stacktrace());
		      error -> orddict:store(Name, Val, Bs)
		  end end,
	  Bs2, orddict:to_list(Bs1)).

%% del_bindings(Bs1, Bs2) -> % del all in Bs1 from Bs2
%%     orddict:fold(
%%       fun (Name, Val, Bs) ->
%% 	      case orddict:find(Name, Bs) of
%% 		  {ok,Val} -> orddict:erase(Name, Bs);
%% 		  {ok,V1} -> erlang:raise(error,{badmatch,V1},stacktrace());
%% 		  error -> Bs
%% 	      end
%%       end, Bs2, Bs1).
%%----------------------------------------------------------------------------
%%
%% Evaluate expressions:
%% constants and 
%% op A
%% L op R
%% Things that evaluate to constants are accepted
%% and guard_bifs are allowed in constant expressions
%%----------------------------------------------------------------------------

is_constant_expr(Expr) ->
    case eval_expr(Expr) of
        {ok, X} when is_number(X) -> true;
        _ -> false
    end.

eval_expr(Expr) ->
    case catch ev_expr(Expr) of
        X when is_integer(X) -> {ok, X};
        X when is_float(X) -> {ok, X};
        X when is_atom(X) -> {ok,X};
        {'EXIT',Reason} -> {error, Reason};
        _ -> {error, badarg}
    end.

partial_eval(Expr) ->
    Line = line(Expr),
    case catch ev_expr(Expr) of
	X when is_integer(X) -> ret_expr(Expr,{integer,Line,X});
	X when is_float(X) -> ret_expr(Expr,{float,Line,X});
	X when is_atom(X) -> ret_expr(Expr,{atom,Line,X});
	_ ->
	    Expr
    end.

ev_expr({op,_,Op,L,R}) -> erlang:Op(ev_expr(L), ev_expr(R));
ev_expr({op,_,Op,A}) -> erlang:Op(ev_expr(A));
ev_expr({integer,_,X}) -> X;
ev_expr({float,_,X})   -> X;
ev_expr({atom,_,X})    -> X;
ev_expr({tuple,_,Es}) ->
    list_to_tuple([ev_expr(X) || X <- Es]);
ev_expr({nil,_}) -> [];
ev_expr({cons,_,H,T}) -> [ev_expr(H) | ev_expr(T)].
%%ev_expr({call,Line,{atom,_,F},As}) ->
%%    true = erl_internal:guard_bif(F, length(As)),
%%    apply(erlang, F, [ev_expr(X) || X <- As]);
%%ev_expr({call,Line,{remote,_,{atom,_,erlang},{atom,_,F}},As}) ->
%%    true = erl_internal:guard_bif(F, length(As)),
%%    apply(erlang, F, [ev_expr(X) || X <- As]);

ret_expr(_Old, New) ->
    %%    io:format("~w: reduced ~s => ~s~n",
    %%	      [line(Old), erl_pp:expr(Old), erl_pp:expr(New)]),
    New.

line(Expr) -> element(2, Expr).

%% In syntax trees, module/package names are atoms or lists of atoms.

expand_module_name({atom,L,A} = M, Bs) ->
    case binding({module,A}, Bs) of
	{value, A1} ->
	    {atom,L,A1};
	unbound ->
	    case packages:is_segmented(A) of
		true ->
		    M;
		false ->
%%% 		    P = case binding({module,'$package'}, Bs) of
%%% 			    {value, P1} -> P1;
%%% 			    unbound -> ""
%%% 			end,
%%% 		    A1 = list_to_atom(packages:concat(P, A)),
%%% 		    {atom,L,list_to_atom(A1)}
		    {atom,L,A}
	    end
    end;
expand_module_name(M, _) ->
    case erl_parse:package_segments(M) of
	error ->
	    M;
	M1 ->
	    L = element(2,M),
	    Mod = packages:concat(M1),
	    case packages:is_valid(Mod) of
		true ->
		    {atom,L,list_to_atom(Mod)};
		false ->
		    erlang:raise(error, {bad_module_name, Mod}, stacktrace())
	    end
    end.

%% {?MODULE,expr,3} is still the stacktrace, despite the
%% fact that expr() now takes two, three or four arguments...
stacktrace() -> [{?MODULE,expr,3}].