%% 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