diff options
Diffstat (limited to 'lib/stdlib/src/ms_transform.erl')
| -rw-r--r-- | lib/stdlib/src/ms_transform.erl | 992 |
1 files changed, 992 insertions, 0 deletions
diff --git a/lib/stdlib/src/ms_transform.erl b/lib/stdlib/src/ms_transform.erl new file mode 100644 index 0000000000..78b1de6e16 --- /dev/null +++ b/lib/stdlib/src/ms_transform.erl @@ -0,0 +1,992 @@ +%% +%% %CopyrightBegin% +%% +%% Copyright Ericsson AB 2002-2009. All Rights Reserved. +%% +%% The contents of this file are subject to the Erlang Public License, +%% Version 1.1, (the "License"); you may not use this file except in +%% compliance with the License. You should have received a copy of the +%% Erlang Public License along with this software. If not, it can be +%% retrieved online at http://www.erlang.org/. +%% +%% Software distributed under the License is distributed on an "AS IS" +%% basis, WITHOUT WARRANTY OF ANY KIND, either express or implied. See +%% the License for the specific language governing rights and limitations +%% under the License. +%% +%% %CopyrightEnd% +%% +-module(ms_transform). + +-export([format_error/1,transform_from_shell/3,parse_transform/2]). + +%% Error codes. +-define(ERROR_BASE_GUARD,0). +-define(ERROR_BASE_BODY,100). +-define(ERR_NOFUN,1). +-define(ERR_ETS_HEAD,2). +-define(ERR_DBG_HEAD,3). +-define(ERR_HEADMATCH,4). +-define(ERR_SEMI_GUARD,5). +-define(ERR_UNBOUND_VARIABLE,6). +-define(ERR_HEADBADREC,7). +-define(ERR_HEADBADFIELD,8). +-define(ERR_HEADMULTIFIELD,9). +-define(ERR_HEADDOLLARATOM,10). +-define(ERR_HEADBINMATCH,11). +-define(ERR_GENMATCH,16). +-define(ERR_GENLOCALCALL,17). +-define(ERR_GENELEMENT,18). +-define(ERR_GENBADFIELD,19). +-define(ERR_GENBADREC,20). +-define(ERR_GENMULTIFIELD,21). +-define(ERR_GENREMOTECALL,22). +-define(ERR_GENBINCONSTRUCT,23). +-define(ERR_GENDISALLOWEDOP,24). +-define(ERR_GUARDMATCH,?ERR_GENMATCH+?ERROR_BASE_GUARD). +-define(ERR_BODYMATCH,?ERR_GENMATCH+?ERROR_BASE_BODY). +-define(ERR_GUARDLOCALCALL,?ERR_GENLOCALCALL+?ERROR_BASE_GUARD). +-define(ERR_BODYLOCALCALL,?ERR_GENLOCALCALL+?ERROR_BASE_BODY). +-define(ERR_GUARDELEMENT,?ERR_GENELEMENT+?ERROR_BASE_GUARD). +-define(ERR_BODYELEMENT,?ERR_GENELEMENT+?ERROR_BASE_BODY). +-define(ERR_GUARDBADFIELD,?ERR_GENBADFIELD+?ERROR_BASE_GUARD). +-define(ERR_BODYBADFIELD,?ERR_GENBADFIELD+?ERROR_BASE_BODY). +-define(ERR_GUARDBADREC,?ERR_GENBADREC+?ERROR_BASE_GUARD). +-define(ERR_BODYBADREC,?ERR_GENBADREC+?ERROR_BASE_BODY). +-define(ERR_GUARDMULTIFIELD,?ERR_GENMULTIFIELD+?ERROR_BASE_GUARD). +-define(ERR_BODYMULTIFIELD,?ERR_GENMULTIFIELD+?ERROR_BASE_BODY). +-define(ERR_GUARDREMOTECALL,?ERR_GENREMOTECALL+?ERROR_BASE_GUARD). +-define(ERR_BODYREMOTECALL,?ERR_GENREMOTECALL+?ERROR_BASE_BODY). +-define(ERR_GUARDBINCONSTRUCT,?ERR_GENBINCONSTRUCT+?ERROR_BASE_GUARD). +-define(ERR_BODYBINCONSTRUCT,?ERR_GENBINCONSTRUCT+?ERROR_BASE_BODY). +-define(ERR_GUARDDISALLOWEDOP,?ERR_GENDISALLOWEDOP+?ERROR_BASE_GUARD). +-define(ERR_BODYDISALLOWEDOP,?ERR_GENDISALLOWEDOP+?ERROR_BASE_BODY). + +%% +%% Called by compiler or ets/dbg:fun2ms when errors occur +%% +format_error(?ERR_NOFUN) -> + "Parameter of ets/dbg:fun2ms/1 is not a literal fun"; +format_error(?ERR_ETS_HEAD) -> + "ets:fun2ms requires fun with single variable or tuple parameter"; +format_error(?ERR_DBG_HEAD) -> + "dbg:fun2ms requires fun with single variable or list parameter"; +format_error(?ERR_HEADMATCH) -> + "in fun head, only matching (=) on toplevel can be translated into match_spec"; +format_error(?ERR_SEMI_GUARD) -> + "fun with semicolon (;) in guard cannot be translated into match_spec"; +format_error(?ERR_GUARDMATCH) -> + "fun with guard matching ('=' in guard) is illegal as match_spec as well"; +format_error({?ERR_GUARDLOCALCALL, Name, Arithy}) -> + lists:flatten(io_lib:format("fun containing the local function call " + "'~w/~w' (called in guard) " + "cannot be translated into match_spec", + [Name, Arithy])); +format_error({?ERR_GUARDREMOTECALL, Module, Name, Arithy}) -> + lists:flatten(io_lib:format("fun containing the remote function call " + "'~w:~w/~w' (called in guard) " + "cannot be translated into match_spec", + [Module,Name,Arithy])); +format_error({?ERR_GUARDELEMENT, Str}) -> + lists:flatten( + io_lib:format("the language element ~s (in guard) cannot be translated " + "into match_spec", [Str])); +format_error({?ERR_GUARDBINCONSTRUCT, Var}) -> + lists:flatten( + io_lib:format("bit syntax construction with variable ~w (in guard) " + "cannot be translated " + "into match_spec", [Var])); +format_error({?ERR_GUARDDISALLOWEDOP, Operator}) -> + %% There is presently no operators that are allowed in bodies but + %% not in guards. + lists:flatten( + io_lib:format("the operator ~w is not allowed in guards", [Operator])); +format_error(?ERR_BODYMATCH) -> + "fun with body matching ('=' in body) is illegal as match_spec"; +format_error({?ERR_BODYLOCALCALL, Name, Arithy}) -> + lists:flatten(io_lib:format("fun containing the local function " + "call '~w/~w' (called in body) " + "cannot be translated into match_spec", + [Name,Arithy])); +format_error({?ERR_BODYREMOTECALL, Module, Name, Arithy}) -> + lists:flatten(io_lib:format("fun containing the remote function call " + "'~w:~w/~w' (called in body) " + "cannot be translated into match_spec", + [Module,Name,Arithy])); +format_error({?ERR_BODYELEMENT, Str}) -> + lists:flatten( + io_lib:format("the language element ~s (in body) cannot be translated " + "into match_spec", [Str])); +format_error({?ERR_BODYBINCONSTRUCT, Var}) -> + lists:flatten( + io_lib:format("bit syntax construction with variable ~w (in body) " + "cannot be translated " + "into match_spec", [Var])); +format_error({?ERR_BODYDISALLOWEDOP, Operator}) -> + %% This will probably never happen, Are there op's that are allowed in + %% guards but not in bodies? Not at time of writing anyway... + lists:flatten( + io_lib:format("the operator ~w is not allowed in function bodies", + [Operator])); + +format_error({?ERR_UNBOUND_VARIABLE, Str}) -> + lists:flatten( + io_lib:format("the variable ~s is unbound, cannot translate " + "into match_spec", [Str])); +format_error({?ERR_HEADBADREC,Name}) -> + lists:flatten( + io_lib:format("fun head contains unknown record type ~w",[Name])); +format_error({?ERR_HEADBADFIELD,RName,FName}) -> + lists:flatten( + io_lib:format("fun head contains reference to unknown field ~w in " + "record type ~w",[FName, RName])); +format_error({?ERR_HEADMULTIFIELD,RName,FName}) -> + lists:flatten( + io_lib:format("fun head contains already defined field ~w in " + "record type ~w",[FName, RName])); +format_error({?ERR_HEADDOLLARATOM,Atom}) -> + lists:flatten( + io_lib:format("fun head contains atom ~w, which conflics with reserved " + "atoms in match_spec heads",[Atom])); +format_error({?ERR_HEADBINMATCH,Atom}) -> + lists:flatten( + io_lib:format("fun head contains bit syntax matching of variable ~w, " + "which cannot be translated into match_spec", [Atom])); +format_error({?ERR_GUARDBADREC,Name}) -> + lists:flatten( + io_lib:format("fun guard contains unknown record type ~w",[Name])); +format_error({?ERR_GUARDBADFIELD,RName,FName}) -> + lists:flatten( + io_lib:format("fun guard contains reference to unknown field ~w in " + "record type ~w",[FName, RName])); +format_error({?ERR_GUARDMULTIFIELD,RName,FName}) -> + lists:flatten( + io_lib:format("fun guard contains already defined field ~w in " + "record type ~w",[FName, RName])); +format_error({?ERR_BODYBADREC,Name}) -> + lists:flatten( + io_lib:format("fun body contains unknown record type ~w",[Name])); +format_error({?ERR_BODYBADFIELD,RName,FName}) -> + lists:flatten( + io_lib:format("fun body contains reference to unknown field ~w in " + "record type ~w",[FName, RName])); +format_error({?ERR_BODYMULTIFIELD,RName,FName}) -> + lists:flatten( + io_lib:format("fun body contains already defined field ~w in " + "record type ~w",[FName, RName])); +format_error(Else) -> + lists:flatten(io_lib:format("Unknown error code ~w",[Else])). + +%% +%% Called when translating in shell +%% +transform_from_shell(Dialect, Clauses, BoundEnvironment) -> + SaveFilename = setup_filename(), + case catch ms_clause_list(1,Clauses,Dialect) of + {'EXIT',Reason} -> + cleanup_filename(SaveFilename), + exit(Reason); + {error,Line,R} -> + {error, [{cleanup_filename(SaveFilename), + [{Line, ?MODULE, R}]}], []}; + Else -> + case (catch fixup_environment(Else,BoundEnvironment)) of + {error,Line1,R1} -> + {error, [{cleanup_filename(SaveFilename), + [{Line1, ?MODULE, R1}]}], []}; + Else1 -> + Ret = normalise(Else1), + cleanup_filename(SaveFilename), + Ret + end + end. + + +%% +%% Called when translating during compiling +%% +parse_transform(Forms, _Options) -> + SaveFilename = setup_filename(), + case catch forms(Forms) of + {'EXIT',Reason} -> + cleanup_filename(SaveFilename), + exit(Reason); + {error,Line,R} -> + {error, [{cleanup_filename(SaveFilename), + [{Line, ?MODULE, R}]}], []}; + Else -> + cleanup_filename(SaveFilename), + Else + end. + +setup_filename() -> + {erase(filename),erase(records)}. + +put_filename(Name) -> + put(filename,Name). + +put_records(R) -> + put(records,R), + ok. +get_records() -> + case get(records) of + undefined -> + []; + Else -> + Else + end. +cleanup_filename({Old,OldRec}) -> + Ret = case erase(filename) of + undefined -> + "TOP_LEVEL"; + X -> + X + end, + case OldRec of + undefined -> + erase(records); + Rec -> + put(records,Rec) + end, + case Old of + undefined -> + Ret; + Y -> + put(filename,Y), + Ret + end. + +add_record_definition({Name,FieldList}) -> + {KeyList,_} = lists:foldl( + fun({record_field,_,{atom,Line0,FieldName}},{L,C}) -> + {[{FieldName,C,{atom,Line0,undefined}}|L],C+1}; + ({record_field,_,{atom,_,FieldName},Def},{L,C}) -> + {[{FieldName,C,Def}|L],C+1} + end, + {[],2}, + FieldList), + put_records([{Name,KeyList}|get_records()]). + +forms([F0|Fs0]) -> + F1 = form(F0), + Fs1 = forms(Fs0), + [F1|Fs1]; +forms([]) -> []. + +form({attribute,_,file,{Filename,_}}=Form) -> + put_filename(Filename), + Form; +form({attribute,_,record,Definition}=Form) -> + add_record_definition(Definition), + Form; +form({function,Line,Name0,Arity0,Clauses0}) -> + {Name,Arity,Clauses} = function(Name0, Arity0, Clauses0), + {function,Line,Name,Arity,Clauses}; +form(AnyOther) -> + AnyOther. +function(Name, Arity, Clauses0) -> + Clauses1 = clauses(Clauses0), + {Name,Arity,Clauses1}. +clauses([C0|Cs]) -> + C1 = clause(C0), + [C1|clauses(Cs)]; +clauses([]) -> []. +clause({clause,Line,H0,G0,B0}) -> + B1 = copy(B0), + {clause,Line,H0,G0,B1}. + +copy({call,Line,{remote,_Line2,{atom,_Line3,ets},{atom,_Line4,fun2ms}}, + As0}) -> + transform_call(ets,Line,As0); +copy({call,Line,{remote,_Line2,{record_field,_Line3, + {atom,_Line4,''},{atom,_Line5,ets}}, + {atom,_Line6,fun2ms}}, As0}) -> + %% Packages... + transform_call(ets,Line,As0); +copy({call,Line,{remote,_Line2,{atom,_Line3,dbg},{atom,_Line4,fun2ms}}, + As0}) -> + transform_call(dbg,Line,As0); +copy(T) when is_tuple(T) -> + list_to_tuple(copy_list(tuple_to_list(T))); +copy(L) when is_list(L) -> + copy_list(L); +copy(AnyOther) -> + AnyOther. + +copy_list([H|T]) -> + [copy(H)|copy_list(T)]; +copy_list([]) -> + []. + +transform_call(Type,_Line,[{'fun',Line2,{clauses, ClauseList}}]) -> + ms_clause_list(Line2, ClauseList,Type); +transform_call(_Type,Line,_NoAbstractFun) -> + throw({error,Line,?ERR_NOFUN}). + +% Fixup semicolons in guards +ms_clause_expand({clause, Line, Parameters, Guard = [_,_|_], Body}) -> + [ {clause, Line, Parameters, [X], Body} || X <- Guard ]; +ms_clause_expand(_Other) -> + false. + +ms_clause_list(Line,[H|T],Type) -> + case ms_clause_expand(H) of + NewHead when is_list(NewHead) -> + ms_clause_list(Line,NewHead ++ T, Type); + false -> + {cons, Line, ms_clause(H,Type), ms_clause_list(Line, T,Type)} + end; +ms_clause_list(Line,[],_) -> + {nil,Line}. +ms_clause({clause, Line, Parameters, Guards, Body},Type) -> + check_type(Line,Parameters,Type), + {MSHead,Bindings} = transform_head(Parameters), + MSGuards = transform_guards(Line, Guards, Bindings), + MSBody = transform_body(Line,Body,Bindings), + {tuple, Line, [MSHead,MSGuards,MSBody]}. + + +check_type(_,[{var,_,_}],_) -> + ok; +check_type(_,[{tuple,_,_}],ets) -> + ok; +check_type(_,[{record,_,_,_}],ets) -> + ok; +check_type(_,[{cons,_,_,_}],dbg) -> + ok; +check_type(Line0,[{match,_,{var,_,_},X}],Any) -> + check_type(Line0,[X],Any); +check_type(Line0,[{match,_,X,{var,_,_}}],Any) -> + check_type(Line0,[X],Any); +check_type(Line,_Type,ets) -> + throw({error,Line,?ERR_ETS_HEAD}); +check_type(Line,_,dbg) -> + throw({error,Line,?ERR_DBG_HEAD}). + +-record(tgd,{ b, %Bindings + p, %Part of spec + eb %Error code base, 0 for guards, 100 for bodies + }). + +transform_guards(Line,[],_Bindings) -> + {nil,Line}; +transform_guards(Line,[G],Bindings) -> + B = #tgd{b = Bindings, p = guard, eb = ?ERROR_BASE_GUARD}, + tg0(Line,G,B); +transform_guards(Line,_,_) -> + throw({error,Line,?ERR_SEMI_GUARD}). + +transform_body(Line,Body,Bindings) -> + B = #tgd{b = Bindings, p = body, eb = ?ERROR_BASE_BODY}, + tg0(Line,Body,B). + + +guard_top_trans({call,Line0,{atom,Line1,OldTest},Params}) -> + case old_bool_test(OldTest,length(Params)) of + undefined -> + {call,Line0,{atom,Line1,OldTest},Params}; + Trans -> + {call,Line0,{atom,Line1,Trans},Params} + end; +guard_top_trans(Else) -> + Else. + +tg0(Line,[],_) -> + {nil,Line}; +tg0(Line,[H0|T],B) when B#tgd.p =:= guard -> + H = guard_top_trans(H0), + {cons,Line, tg(H,B), tg0(Line,T,B)}; +tg0(Line,[H|T],B) -> + {cons,Line, tg(H,B), tg0(Line,T,B)}. + + +tg({match,Line,_,_},B) -> + throw({error,Line,?ERR_GENMATCH+B#tgd.eb}); +tg({op, Line, Operator, O1, O2}, B) -> + {tuple, Line, [{atom, Line, Operator}, tg(O1,B), tg(O2,B)]}; +tg({op, Line, Operator, O1}, B) -> + {tuple, Line, [{atom, Line, Operator}, tg(O1,B)]}; +tg({call, _Line, {atom, Line2, bindings},[]},_B) -> + {atom, Line2, '$*'}; +tg({call, _Line, {atom, Line2, object},[]},_B) -> + {atom, Line2, '$_'}; +tg({call, Line, {atom, _, is_record}=Call,[Object, {atom,Line3,RName}=R]},B) -> + MSObject = tg(Object,B), + RDefs = get_records(), + case lists:keysearch(RName,1,RDefs) of + {value, {RName, FieldList}} -> + RSize = length(FieldList)+1, + {tuple, Line, [Call, MSObject, R, {integer, Line3, RSize}]}; + _ -> + throw({error,Line3,{?ERR_GENBADREC+B#tgd.eb,RName}}) + end; +tg({call, Line, {atom, Line2, FunName},ParaList},B) -> + case is_ms_function(FunName,length(ParaList), B#tgd.p) of + true -> + {tuple, Line, [{atom, Line2, FunName} | + lists:map(fun(X) -> tg(X,B) end, ParaList)]}; + _ -> + throw({error,Line,{?ERR_GENLOCALCALL+B#tgd.eb, + FunName,length(ParaList)}}) + end; +tg({call, Line, {remote,_,{atom,_,erlang},{atom, Line2, FunName}},ParaList}, + B) -> + L = length(ParaList), + case is_imported_from_erlang(FunName,L,B#tgd.p) of + true -> + case is_operator(FunName,L,B#tgd.p) of + false -> + tg({call, Line, {atom, Line2, FunName},ParaList},B); + true -> + tg(list_to_tuple([op,Line2,FunName | ParaList]),B) + end; + _ -> + throw({error,Line,{?ERR_GENREMOTECALL+B#tgd.eb,erlang, + FunName,length(ParaList)}}) + end; +tg({call, Line, {remote,_,{atom,_,ModuleName}, + {atom, _, FunName}},_ParaList},B) -> + throw({error,Line,{?ERR_GENREMOTECALL+B#tgd.eb,ModuleName,FunName}}); +tg({cons,Line, H, T},B) -> + {cons, Line, tg(H,B), tg(T,B)}; +tg({nil, Line},_B) -> + {nil, Line}; +tg({tuple,Line,L},B) -> + {tuple,Line,[{tuple,Line,lists:map(fun(X) -> tg(X,B) end, L)}]}; +tg({integer,Line,I},_) -> + {integer,Line,I}; +tg({char,Line,C},_) -> + {char,Line,C}; +tg({float, Line,F},_) -> + {float,Line,F}; +tg({atom,Line,A},_) -> + case atom_to_list(A) of + [$$|_] -> + {tuple, Line,[{atom, Line, 'const'},{atom,Line,A}]}; + _ -> + {atom,Line,A} + end; +tg({string,Line,S},_) -> + {string,Line,S}; +tg({var,Line,VarName},B) -> + case lkup_bind(VarName, B#tgd.b) of + undefined -> + {tuple, Line,[{atom, Line, 'const'},{var,Line,VarName}]}; + AtomName -> + {atom, Line, AtomName} + end; +tg({record_field,Line,Object,RName,{atom,_Line1,KeyName}},B) -> + RDefs = get_records(), + case lists:keysearch(RName,1,RDefs) of + {value, {RName, FieldList}} -> + case lists:keysearch(KeyName,1, FieldList) of + {value, {KeyName,Position,_}} -> + NewObject = tg(Object,B), + {tuple, Line, [{atom, Line, 'element'}, + {integer, Line, Position}, NewObject]}; + _ -> + throw({error,Line,{?ERR_GENBADFIELD+B#tgd.eb, RName, + KeyName}}) + end; + _ -> + throw({error,Line,{?ERR_GENBADREC+B#tgd.eb,RName}}) + end; + +tg({record,Line,RName,RFields},B) -> + RDefs = get_records(), + KeyList0 = lists:foldl(fun({record_field,_,{atom,_,Key},Value}, + L) -> + NV = tg(Value,B), + [{Key,NV}|L]; + ({record_field,_,{var,_,'_'},Value}, + L) -> + NV = tg(Value,B), + [{{default},NV}|L]; + (_,_) -> + throw({error,Line, + {?ERR_GENBADREC+B#tgd.eb, + RName}}) + end, + [], + RFields), + DefValue = case lists:keysearch({default},1,KeyList0) of + {value,{{default},OverriddenDefValue}} -> + {true,OverriddenDefValue}; + _ -> + false + end, + KeyList = lists:keydelete({default},1,KeyList0), + case lists:keysearch({default},1,KeyList) of + {value,{{default},_}} -> + throw({error,Line,{?ERR_GENMULTIFIELD+B#tgd.eb,RName,'_'}}); + _ -> + ok + end, + case lists:keysearch(RName,1,RDefs) of + {value, {RName, FieldList0}} -> + FieldList1 = lists:foldl( + fun({FN,_,Def},Acc) -> + El = case lists:keysearch(FN,1,KeyList) of + {value, {FN, X0}} -> + X0; + _ -> + case DefValue of + {true,Overridden} -> + Overridden; + false -> + Def + end + end, + [El | Acc] + end, + [], + FieldList0), + check_multi_field(RName,Line,KeyList, + ?ERR_GENMULTIFIELD+B#tgd.eb), + check_undef_field(RName,Line,KeyList,FieldList0, + ?ERR_GENBADFIELD+B#tgd.eb), + {tuple,Line,[{tuple,Line,[{atom,Line,RName}|FieldList1]}]}; + _ -> + throw({error,Line,{?ERR_GENBADREC+B#tgd.eb,RName}}) + end; + +tg({record_index,Line,RName,{atom,Line2,KeyName}},B) -> + RDefs = get_records(), + case lists:keysearch(RName,1,RDefs) of + {value, {RName, FieldList}} -> + case lists:keysearch(KeyName,1, FieldList) of + {value, {KeyName,Position,_}} -> + {integer, Line2, Position}; + _ -> + throw({error,Line2,{?ERR_GENBADFIELD+B#tgd.eb, RName, + KeyName}}) + end; + _ -> + throw({error,Line,{?ERR_GENBADREC+B#tgd.eb,RName}}) + end; + +tg({record,Line,{var,Line2,_VName}=AVName, RName,RFields},B) -> + RDefs = get_records(), + MSVName = tg(AVName,B), + KeyList = lists:foldl(fun({record_field,_,{atom,_,Key},Value}, + L) -> + NV = tg(Value,B), + [{Key,NV}|L]; + (_,_) -> + throw({error,Line,?ERR_HEADBADREC}) + end, + [], + RFields), + case lists:keysearch(RName,1,RDefs) of + {value, {RName, FieldList0}} -> + FieldList1 = lists:foldl( + fun({FN,Pos,_},Acc) -> + El = case lists:keysearch(FN,1,KeyList) of + {value, {FN, X0}} -> + X0; + _ -> + {tuple, Line2, + [{atom, Line2, element}, + {integer, Line2, Pos}, + MSVName]} + end, + [El | Acc] + end, + [], + FieldList0), + check_multi_field(RName,Line,KeyList, + ?ERR_GENMULTIFIELD+B#tgd.eb), + check_undef_field(RName,Line,KeyList,FieldList0, + ?ERR_GENBADFIELD+B#tgd.eb), + {tuple,Line,[{tuple,Line,[{atom,Line,RName}|FieldList1]}]}; + _ -> + throw({error,Line,{?ERR_GENBADREC+B#tgd.eb,RName}}) + end; + +tg({bin_element,_Line0,{var, Line, A},_,_} = Whole,B) -> + case lkup_bind(A, B#tgd.b) of + undefined -> + Whole; % exists in environment hopefully + _AtomName -> + throw({error,Line,{?ERR_GENBINCONSTRUCT+B#tgd.eb,A}}) + end; +tg(default,_B) -> + default; +tg({bin_element,Line,X,Y,Z},B) -> + {bin_element, Line, tg(X,B), tg(Y,B), Z}; + +tg({bin,Line,List},B) -> + {bin,Line,[tg(X,B) || X <- List]}; + +tg(T,B) when is_tuple(T), tuple_size(T) >= 2 -> + Element = element(1,T), + Line = element(2,T), + throw({error,Line,{?ERR_GENELEMENT+B#tgd.eb, + translate_language_element(Element)}}); +tg(Other,B) -> + Element = io_lib:format("unknown element ~w", [Other]), + throw({error,unknown,{?ERR_GENELEMENT+B#tgd.eb,Element}}). + +transform_head([V]) -> + Bind = cre_bind(), + {NewV,NewBind} = toplevel_head_match(V,Bind), + th(NewV,NewBind). + + +toplevel_head_match({match,_,{var,_,VName},Expr},B) -> + {Expr,new_bind({VName,'$_'},B)}; +toplevel_head_match({match,_,Expr,{var,_,VName}},B) -> + {Expr,new_bind({VName,'$_'},B)}; +toplevel_head_match(Other,B) -> + {Other,B}. + +th({record,Line,RName,RFields},B) -> + % youch... + RDefs = get_records(), + {KeyList0,NewB} = lists:foldl(fun({record_field,_,{atom,_,Key},Value}, + {L,B0}) -> + {NV,B1} = th(Value,B0), + {[{Key,NV}|L],B1}; + ({record_field,_,{var,_,'_'},Value}, + {L,B0}) -> + {NV,B1} = th(Value,B0), + {[{{default},NV}|L],B1}; + (_,_) -> + throw({error,Line,{?ERR_HEADBADREC, + RName}}) + end, + {[],B}, + RFields), + DefValue = case lists:keysearch({default},1,KeyList0) of + {value,{{default},OverriddenDefValue}} -> + OverriddenDefValue; + _ -> + {atom,Line,'_'} + end, + KeyList = lists:keydelete({default},1,KeyList0), + case lists:keysearch({default},1,KeyList) of + {value,{{default},_}} -> + throw({error,Line,{?ERR_HEADMULTIFIELD,RName,'_'}}); + _ -> + ok + end, + case lists:keysearch(RName,1,RDefs) of + {value, {RName, FieldList0}} -> + FieldList1 = lists:foldl( + fun({FN,_,_},Acc) -> + El = case lists:keysearch(FN,1,KeyList) of + {value, {FN, X0}} -> + X0; + _ -> + DefValue + end, + [El | Acc] + end, + [], + FieldList0), + check_multi_field(RName,Line,KeyList, + ?ERR_HEADMULTIFIELD), + check_undef_field(RName,Line,KeyList,FieldList0, + ?ERR_HEADBADFIELD), + {{tuple,Line,[{atom,Line,RName}|FieldList1]},NewB}; + _ -> + throw({error,Line,{?ERR_HEADBADREC,RName}}) + end; +th({match,Line,_,_},_) -> + throw({error,Line,?ERR_HEADMATCH}); +th({atom,Line,A},B) -> + case atom_to_list(A) of + [$$|NL] -> + case (catch list_to_integer(NL)) of + N when is_integer(N) -> + throw({error,Line,{?ERR_HEADDOLLARATOM,A}}); + _ -> + {{atom,Line,A},B} + end; + _ -> + {{atom,Line,A},B} + end; +th({bin_element,_Line0,{var, Line, A},_,_},_) -> + throw({error,Line,{?ERR_HEADBINMATCH,A}}); + +th({var,Line,Name},B) -> + case lkup_bind(Name,B) of + undefined -> + NewB = new_bind(Name,B), + {{atom,Line,lkup_bind(Name,NewB)},NewB}; + Trans -> + {{atom,Line,Trans},B} + end; +th([H|T],B) -> + {NH,NB} = th(H,B), + {NT,NNB} = th(T,NB), + {[NH|NT],NNB}; +th(T,B) when is_tuple(T) -> + {L,NB} = th(tuple_to_list(T),B), + {list_to_tuple(L),NB}; +th(Nonstruct,B) -> + {Nonstruct,B}. + +%% Could be more efficient... +check_multi_field(_, _, [], _) -> + ok; +check_multi_field(RName, Line, [{Key,_}|T], ErrCode) -> + case lists:keymember(Key,1,T) of + true -> + throw({error,Line,{ErrCode,RName,Key}}); + false -> + check_multi_field(RName, Line, T, ErrCode) + end. +check_undef_field(_, _, [], _, _) -> + ok; +check_undef_field(RName, Line, [{Key,_}|T], FieldList, ErrCode) -> + case lists:keymember(Key, 1, FieldList) of + true -> + check_undef_field(RName, Line, T, FieldList, ErrCode); + false -> + throw({error,Line,{ErrCode,RName,Key}}) + end. + +cre_bind() -> + {1,[{'_','_'}]}. + +lkup_bind(Name,{_,List}) -> + case lists:keysearch(Name,1,List) of + {value, {Name, Trans}} -> + Trans; + _ -> + undefined + end. + +new_bind({Name,Trans},{Next,L}) -> + {Next,[{Name,Trans}|L]}; +new_bind(Name,{Next,L}) -> + Trans = list_to_atom([$$|integer_to_list(Next)]), + {Next+1,[{Name,Trans}|L]}. + +translate_language_element(Atom) -> + Transtab = [ + {lc,"list comprehension"}, + {bc,"binary comprehension"}, + {block, "begin/end block"}, + {'if', "if"}, + {'case', "case"}, + {'receive', "receive"}, + {'try', "try"}, + {'catch', "catch"}, + {'match', "match (=)"}, + {remote, "external function call"} + ], + case lists:keysearch(Atom,1,Transtab) of + {value,{Atom, String}} -> + String; + _ -> + atom_to_list(Atom) + end. + +old_bool_test(atom,1) -> is_atom; +old_bool_test(constant,1) -> is_constant; +old_bool_test(float,1) -> is_float; +old_bool_test(integer,1) -> is_integer; +old_bool_test(list,1) -> is_list; +old_bool_test(number,1) -> is_number; +old_bool_test(pid,1) -> is_pid; +old_bool_test(port,1) -> is_port; +old_bool_test(reference,1) -> is_reference; +old_bool_test(tuple,1) -> is_tuple; +old_bool_test(binary,1) -> is_binary; +old_bool_test(function,1) -> is_function; +old_bool_test(record,2) -> is_record; +old_bool_test(_,_) -> undefined. + +bool_test(is_atom,1) -> true; +bool_test(is_constant,1) -> true; +bool_test(is_float,1) -> true; +bool_test(is_integer,1) -> true; +bool_test(is_list,1) -> true; +bool_test(is_number,1) -> true; +bool_test(is_pid,1) -> true; +bool_test(is_port,1) -> true; +bool_test(is_reference,1) -> true; +bool_test(is_tuple,1) -> true; +bool_test(is_binary,1) -> true; +bool_test(is_function,1) -> true; +bool_test(is_record,2) -> true; +bool_test(is_seq_trace,0) -> true; +bool_test(_,_) -> false. + +real_guard_function(abs,1) -> true; +real_guard_function(element,2) -> true; +real_guard_function(hd,1) -> true; +real_guard_function(length,1) -> true; +real_guard_function(node,0) -> true; +real_guard_function(node,1) -> true; +real_guard_function(round,1) -> true; +real_guard_function(size,1) -> true; +real_guard_function(tl,1) -> true; +real_guard_function(trunc,1) -> true; +real_guard_function(self,0) -> true; +real_guard_function(float,1) -> true; +real_guard_function(_,_) -> false. + +pseudo_guard_function(get_tcw,0) -> true; +pseudo_guard_function(_,_) -> false. + +guard_function(X,A) -> + real_guard_function(X,A) or pseudo_guard_function(X,A). + +action_function(set_seq_token,2) -> true; +action_function(get_seq_token,0) -> true; +action_function(message,1) -> true; +action_function(return_trace,0) -> true; +action_function(exception_trace,0) -> true; +action_function(process_dump,0) -> true; +action_function(enable_trace,1) -> true; +action_function(enable_trace,2) -> true; +action_function(disable_trace,1) -> true; +action_function(disable_trace,2) -> true; +action_function(display,1) -> true; +action_function(caller,0) -> true; +action_function(set_tcw,1) -> true; +action_function(silent,1) -> true; +action_function(trace,2) -> true; +action_function(trace,3) -> true; +action_function(_,_) -> false. + +bool_operator('and',2) -> + true; +bool_operator('or',2) -> + true; +bool_operator('xor',2) -> + true; +bool_operator('not',1) -> + true; +bool_operator('andalso',2) -> + true; +bool_operator('orelse',2) -> + true; +bool_operator(_,_) -> + false. + +arith_operator('+',1) -> + true; +arith_operator('+',2) -> + true; +arith_operator('-',1) -> + true; +arith_operator('-',2) -> + true; +arith_operator('*',2) -> + true; +arith_operator('/',2) -> + true; +arith_operator('div',2) -> + true; +arith_operator('rem',2) -> + true; +arith_operator('band',2) -> + true; +arith_operator('bor',2) -> + true; +arith_operator('bxor',2) -> + true; +arith_operator('bnot',1) -> + true; +arith_operator('bsl',2) -> + true; +arith_operator('bsr',2) -> + true; +arith_operator(_,_) -> + false. + +cmp_operator('>',2) -> + true; +cmp_operator('>=',2) -> + true; +cmp_operator('<',2) -> + true; +cmp_operator('=<',2) -> + true; +cmp_operator('==',2) -> + true; +cmp_operator('=:=',2) -> + true; +cmp_operator('/=',2) -> + true; +cmp_operator('=/=',2) -> + true; +cmp_operator(_,_) -> + false. + +is_operator(X,A,_) -> + bool_operator(X,A) or arith_operator(X,A) or cmp_operator(X,A). + +is_imported_from_erlang(X,A,_) -> + real_guard_function(X,A) or bool_test(X,A) or bool_operator(X,A) or + arith_operator(X,A) or cmp_operator(X,A). + +is_ms_function(X,A,body) -> + action_function(X,A) or guard_function(X,A) or bool_test(X,A); + +is_ms_function(X,A,guard) -> + guard_function(X,A) or bool_test(X,A). + +fixup_environment(L,B) when is_list(L) -> + lists:map(fun(X) -> + fixup_environment(X,B) + end, + L); +fixup_environment({var,Line,Name},B) -> + case lists:keysearch(Name,1,B) of + {value,{Name,Value}} -> + freeze(Line,Value); + _ -> + throw({error,Line,{?ERR_UNBOUND_VARIABLE,atom_to_list(Name)}}) + end; +fixup_environment(T,B) when is_tuple(T) -> + list_to_tuple( + lists:map(fun(X) -> + fixup_environment(X,B) + end, + tuple_to_list(T))); +fixup_environment(Other,_B) -> + Other. + +freeze(Line,Term) -> + {frozen,Line,Term}. + +%% Most of this is bluntly stolen from erl_parse. + +normalise({frozen,_,Term}) -> + Term; +normalise({char,_,C}) -> C; +normalise({integer,_,I}) -> I; +normalise({float,_,F}) -> F; +normalise({atom,_,A}) -> A; +normalise({string,_,S}) -> S; +normalise({nil,_}) -> []; +normalise({bin,_,Fs}) -> + {value, B, _} = + eval_bits:expr_grp(Fs, [], + fun(E, _) -> + {value, normalise(E), []} + end, [], true), + B; +normalise({cons,_,Head,Tail}) -> + [normalise(Head)|normalise(Tail)]; +normalise({tuple,_,Args}) -> + list_to_tuple(normalise_list(Args)); +%% Special case for unary +/-. +normalise({op,_,'+',{char,_,I}}) -> I; +normalise({op,_,'+',{integer,_,I}}) -> I; +normalise({op,_,'+',{float,_,F}}) -> F; +normalise({op,_,'-',{char,_,I}}) -> -I; % Weird, but compatible! +normalise({op,_,'-',{integer,_,I}}) -> -I; +normalise({op,_,'-',{float,_,F}}) -> -F. + +normalise_list([H|T]) -> + [normalise(H)|normalise_list(T)]; +normalise_list([]) -> + []. + + |