1%% 2%% %CopyrightBegin% 3%% 4%% Copyright Ericsson AB 2002-2018. All Rights Reserved. 5%% 6%% Licensed under the Apache License, Version 2.0 (the "License"); 7%% you may not use this file except in compliance with the License. 8%% You may obtain a copy of the License at 9%% 10%% http://www.apache.org/licenses/LICENSE-2.0 11%% 12%% Unless required by applicable law or agreed to in writing, software 13%% distributed under the License is distributed on an "AS IS" BASIS, 14%% WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 15%% See the License for the specific language governing permissions and 16%% limitations under the License. 17%% 18%% %CopyrightEnd% 19%% 20-module(ms_transform). 21 22-export([format_error/1,transform_from_shell/3,parse_transform/2]). 23 24%% Error codes. 25-define(ERROR_BASE_GUARD,0). 26-define(ERROR_BASE_BODY,100). 27-define(ERR_NOFUN,1). 28-define(ERR_ETS_HEAD,2). 29-define(ERR_DBG_HEAD,3). 30-define(ERR_HEADMATCH,4). 31-define(ERR_SEMI_GUARD,5). 32-define(ERR_UNBOUND_VARIABLE,6). 33-define(ERR_HEADBADREC,7). 34-define(ERR_HEADBADFIELD,8). 35-define(ERR_HEADMULTIFIELD,9). 36-define(ERR_HEADDOLLARATOM,10). 37-define(ERR_HEADBINMATCH,11). 38-define(ERR_GENMATCH,16). 39-define(ERR_GENLOCALCALL,17). 40-define(ERR_GENELEMENT,18). 41-define(ERR_GENBADFIELD,19). 42-define(ERR_GENBADREC,20). 43-define(ERR_GENMULTIFIELD,21). 44-define(ERR_GENREMOTECALL,22). 45-define(ERR_GENBINCONSTRUCT,23). 46-define(ERR_GENDISALLOWEDOP,24). 47-define(WARN_SHADOW_VAR,50). 48-define(ERR_GUARDMATCH,?ERR_GENMATCH+?ERROR_BASE_GUARD). 49-define(ERR_BODYMATCH,?ERR_GENMATCH+?ERROR_BASE_BODY). 50-define(ERR_GUARDLOCALCALL,?ERR_GENLOCALCALL+?ERROR_BASE_GUARD). 51-define(ERR_BODYLOCALCALL,?ERR_GENLOCALCALL+?ERROR_BASE_BODY). 52-define(ERR_GUARDELEMENT,?ERR_GENELEMENT+?ERROR_BASE_GUARD). 53-define(ERR_BODYELEMENT,?ERR_GENELEMENT+?ERROR_BASE_BODY). 54-define(ERR_GUARDBADFIELD,?ERR_GENBADFIELD+?ERROR_BASE_GUARD). 55-define(ERR_BODYBADFIELD,?ERR_GENBADFIELD+?ERROR_BASE_BODY). 56-define(ERR_GUARDBADREC,?ERR_GENBADREC+?ERROR_BASE_GUARD). 57-define(ERR_BODYBADREC,?ERR_GENBADREC+?ERROR_BASE_BODY). 58-define(ERR_GUARDMULTIFIELD,?ERR_GENMULTIFIELD+?ERROR_BASE_GUARD). 59-define(ERR_BODYMULTIFIELD,?ERR_GENMULTIFIELD+?ERROR_BASE_BODY). 60-define(ERR_GUARDREMOTECALL,?ERR_GENREMOTECALL+?ERROR_BASE_GUARD). 61-define(ERR_BODYREMOTECALL,?ERR_GENREMOTECALL+?ERROR_BASE_BODY). 62-define(ERR_GUARDBINCONSTRUCT,?ERR_GENBINCONSTRUCT+?ERROR_BASE_GUARD). 63-define(ERR_BODYBINCONSTRUCT,?ERR_GENBINCONSTRUCT+?ERROR_BASE_BODY). 64-define(ERR_GUARDDISALLOWEDOP,?ERR_GENDISALLOWEDOP+?ERROR_BASE_GUARD). 65-define(ERR_BODYDISALLOWEDOP,?ERR_GENDISALLOWEDOP+?ERROR_BASE_BODY). 66 67%% 68%% Called by compiler or ets/dbg:fun2ms when errors/warnings occur 69%% 70 71-spec(format_error(Error) -> Chars when 72 Error :: {error, module(), term()}, 73 Chars :: io_lib:chars()). 74 75format_error({?WARN_SHADOW_VAR,Name}) -> 76 lists:flatten( 77 io_lib:format("variable ~p shadowed in ms_transform fun head", 78 [Name])); 79 80format_error(?ERR_NOFUN) -> 81 "Parameter of ets/dbg:fun2ms/1 is not a literal fun"; 82format_error(?ERR_ETS_HEAD) -> 83 "ets:fun2ms requires fun with single variable or tuple parameter"; 84format_error(?ERR_DBG_HEAD) -> 85 "dbg:fun2ms requires fun with single variable or list parameter"; 86format_error(?ERR_HEADMATCH) -> 87 "in fun head, only matching (=) on toplevel can be translated into match_spec"; 88format_error(?ERR_SEMI_GUARD) -> 89 "fun with semicolon (;) in guard cannot be translated into match_spec"; 90format_error(?ERR_GUARDMATCH) -> 91 "fun with guard matching ('=' in guard) is illegal as match_spec as well"; 92format_error({?ERR_GUARDLOCALCALL, Name, Arithy}) -> 93 lists:flatten(io_lib:format("fun containing the local function call " 94 "'~tw/~w' (called in guard) " 95 "cannot be translated into match_spec", 96 [Name, Arithy])); 97format_error({?ERR_GUARDREMOTECALL, Module, Name, Arithy}) -> 98 lists:flatten(io_lib:format("fun containing the remote function call " 99 "'~w:~tw/~w' (called in guard) " 100 "cannot be translated into match_spec", 101 [Module,Name,Arithy])); 102format_error({?ERR_GUARDELEMENT, Str}) -> 103 lists:flatten( 104 io_lib:format("the language element ~ts (in guard) cannot be translated " 105 "into match_spec", [Str])); 106format_error({?ERR_GUARDBINCONSTRUCT, Var}) -> 107 lists:flatten( 108 io_lib:format("bit syntax construction with variable ~w (in guard) " 109 "cannot be translated " 110 "into match_spec", [Var])); 111format_error({?ERR_GUARDDISALLOWEDOP, Operator}) -> 112 %% There is presently no operators that are allowed in bodies but 113 %% not in guards. 114 lists:flatten( 115 io_lib:format("the operator ~w is not allowed in guards", [Operator])); 116format_error(?ERR_BODYMATCH) -> 117 "fun with body matching ('=' in body) is illegal as match_spec"; 118format_error({?ERR_BODYLOCALCALL, Name, Arithy}) -> 119 lists:flatten(io_lib:format("fun containing the local function " 120 "call '~tw/~w' (called in body) " 121 "cannot be translated into match_spec", 122 [Name,Arithy])); 123format_error({?ERR_BODYREMOTECALL, Module, Name, Arithy}) -> 124 lists:flatten(io_lib:format("fun containing the remote function call " 125 "'~w:~tw/~w' (called in body) " 126 "cannot be translated into match_spec", 127 [Module,Name,Arithy])); 128format_error({?ERR_BODYELEMENT, Str}) -> 129 lists:flatten( 130 io_lib:format("the language element ~ts (in body) cannot be translated " 131 "into match_spec", [Str])); 132format_error({?ERR_BODYBINCONSTRUCT, Var}) -> 133 lists:flatten( 134 io_lib:format("bit syntax construction with variable ~w (in body) " 135 "cannot be translated " 136 "into match_spec", [Var])); 137format_error({?ERR_BODYDISALLOWEDOP, Operator}) -> 138 %% This will probably never happen, Are there op's that are allowed in 139 %% guards but not in bodies? Not at time of writing anyway... 140 lists:flatten( 141 io_lib:format("the operator ~w is not allowed in function bodies", 142 [Operator])); 143 144format_error({?ERR_UNBOUND_VARIABLE, Str}) -> 145 lists:flatten( 146 io_lib:format("the variable ~s is unbound, cannot translate " 147 "into match_spec", [Str])); 148format_error({?ERR_HEADBADREC,Name}) -> 149 lists:flatten( 150 io_lib:format("fun head contains unknown record type ~tw",[Name])); 151format_error({?ERR_HEADBADFIELD,RName,FName}) -> 152 lists:flatten( 153 io_lib:format("fun head contains reference to unknown field ~tw in " 154 "record type ~tw",[FName, RName])); 155format_error({?ERR_HEADMULTIFIELD,RName,FName}) -> 156 lists:flatten( 157 io_lib:format("fun head contains already defined field ~tw in " 158 "record type ~tw",[FName, RName])); 159format_error({?ERR_HEADDOLLARATOM,Atom}) -> 160 lists:flatten( 161 io_lib:format("fun head contains atom ~w, which conflics with reserved " 162 "atoms in match_spec heads",[Atom])); 163format_error({?ERR_HEADBINMATCH,Atom}) -> 164 lists:flatten( 165 io_lib:format("fun head contains bit syntax matching of variable ~w, " 166 "which cannot be translated into match_spec", [Atom])); 167format_error({?ERR_GUARDBADREC,Name}) -> 168 lists:flatten( 169 io_lib:format("fun guard contains unknown record type ~tw",[Name])); 170format_error({?ERR_GUARDBADFIELD,RName,FName}) -> 171 lists:flatten( 172 io_lib:format("fun guard contains reference to unknown field ~tw in " 173 "record type ~tw",[FName, RName])); 174format_error({?ERR_GUARDMULTIFIELD,RName,FName}) -> 175 lists:flatten( 176 io_lib:format("fun guard contains already defined field ~tw in " 177 "record type ~tw",[FName, RName])); 178format_error({?ERR_BODYBADREC,Name}) -> 179 lists:flatten( 180 io_lib:format("fun body contains unknown record type ~tw",[Name])); 181format_error({?ERR_BODYBADFIELD,RName,FName}) -> 182 lists:flatten( 183 io_lib:format("fun body contains reference to unknown field ~tw in " 184 "record type ~tw",[FName, RName])); 185format_error({?ERR_BODYMULTIFIELD,RName,FName}) -> 186 lists:flatten( 187 io_lib:format("fun body contains already defined field ~tw in " 188 "record type ~tw",[FName, RName])); 189format_error(Else) -> 190 lists:flatten(io_lib:format("Unknown error code ~tw",[Else])). 191 192%% 193%% Called when translating in shell 194%% 195 196-spec transform_from_shell(Dialect, Clauses, BoundEnvironment) -> term() when 197 Dialect :: ets | dbg, 198 Clauses :: [erl_parse:abstract_clause()], 199 BoundEnvironment :: erl_eval:binding_struct(). 200 201transform_from_shell(Dialect, Clauses, BoundEnvironment) -> 202 SaveFilename = setup_filename(), 203 case catch ms_clause_list(1,Clauses,Dialect,gb_sets:new()) of 204 {'EXIT',Reason} -> 205 cleanup_filename(SaveFilename), 206 exit(Reason); 207 {error,Line,R} -> 208 {error, [{cleanup_filename(SaveFilename), 209 [{Line, ?MODULE, R}]}], []}; 210 Else -> 211 case (catch fixup_environment(Else,BoundEnvironment)) of 212 {error,Line1,R1} -> 213 {error, [{cleanup_filename(SaveFilename), 214 [{Line1, ?MODULE, R1}]}], []}; 215 Else1 -> 216 Ret = normalise(Else1), 217 cleanup_filename(SaveFilename), 218 Ret 219 end 220 end. 221 222 223%% 224%% Called when translating during compiling 225%% 226 227-spec parse_transform(Forms, Options) -> Forms2 | Errors | Warnings when 228 Forms :: [erl_parse:abstract_form() | erl_parse:form_info()], 229 Forms2 :: [erl_parse:abstract_form() | erl_parse:form_info()], 230 Options :: term(), 231 Errors :: {error, ErrInfo :: [tuple()], WarnInfo :: []}, 232 Warnings :: {warning, Forms2, WarnInfo :: [tuple()]}. 233 234parse_transform(Forms, _Options) -> 235 SaveFilename = setup_filename(), 236 %io:format("Forms: ~p~n",[Forms]), 237 case catch forms(Forms) of 238 {'EXIT',Reason} -> 239 cleanup_filename(SaveFilename), 240 exit(Reason); 241 {error,Line,R} -> 242 {error, [{cleanup_filename(SaveFilename), 243 [{Line, ?MODULE, R}]}], []}; 244 Else -> 245 %io:format("Transformed into: ~p~n",[Else]), 246 case get_warnings() of 247 [] -> 248 cleanup_filename(SaveFilename), 249 Else; 250 WL -> 251 FName = cleanup_filename(SaveFilename) , 252 WList = [ {FName, [{L, ?MODULE, R}]} || {L,R} <- WL ], 253 {warning, Else, WList} 254 end 255 end. 256 257get_warnings() -> 258 case get(warnings) of 259 undefined -> 260 []; 261 Else -> 262 Else 263 end. 264 265add_warning(Line,R) -> 266 put(warnings,[{Line,R}| get_warnings()]). 267 268setup_filename() -> 269 {erase(filename),erase(records),erase(warnings)}. 270 271put_filename(Name) -> 272 put(filename,Name). 273 274put_records(R) -> 275 put(records,R), 276 ok. 277get_records() -> 278 case get(records) of 279 undefined -> 280 []; 281 Else -> 282 Else 283 end. 284cleanup_filename({Old,OldRec,OldWarnings}) -> 285 Ret = case erase(filename) of 286 undefined -> 287 "TOP_LEVEL"; 288 X -> 289 X 290 end, 291 case OldRec of 292 undefined -> 293 erase(records); 294 Rec -> 295 put(records,Rec) 296 end, 297 case OldWarnings of 298 undefined -> 299 erase(warnings); 300 Warn -> 301 put(warnings,Warn) 302 end, 303 case Old of 304 undefined -> 305 Ret; 306 Y -> 307 put(filename,Y), 308 Ret 309 end. 310 311add_record_definition({Name,FieldList}) -> 312 {KeyList,_} = lists:foldl( 313 fun(F, {L,C}) -> {[record_field(F, C)|L],C+1} end, 314 {[],2}, 315 FieldList), 316 put_records([{Name,KeyList}|get_records()]). 317 318record_field({record_field,_,{atom,Line0,FieldName}}, C) -> 319 {FieldName,C,{atom,Line0,undefined}}; 320record_field({record_field,_,{atom,_,FieldName},Def}, C) -> 321 {FieldName,C,Def}; 322record_field({typed_record_field,Field,_Type}, C) -> 323 record_field(Field, C). 324 325forms([F0|Fs0]) -> 326 F1 = form(F0), 327 Fs1 = forms(Fs0), 328 [F1|Fs1]; 329forms([]) -> []. 330 331form({attribute,_,file,{Filename,_}}=Form) -> 332 put_filename(Filename), 333 Form; 334form({attribute,_,record,Definition}=Form) -> 335 add_record_definition(Definition), 336 Form; 337form({function,Line,Name0,Arity0,Clauses0}) -> 338 {Name,Arity,Clauses} = function(Name0, Arity0, Clauses0), 339 {function,Line,Name,Arity,Clauses}; 340form(AnyOther) -> 341 AnyOther. 342function(Name, Arity, Clauses0) -> 343 Clauses1 = clauses(Clauses0), 344 {Name,Arity,Clauses1}. 345clauses([C0|Cs]) -> 346 C1 = clause(C0,gb_sets:new()), 347 C2 = clauses(Cs), 348 [C1|C2]; 349clauses([]) -> []. 350 351clause({clause,Line,H0,G0,B0},Bound) -> 352 {H1,Bound1} = copy(H0,Bound), 353 {B1,_Bound2} = copy(B0,Bound1), 354 {clause,Line,H1,G0,B1}. 355 356copy({call,Line,{remote,_Line2,{atom,_Line3,ets},{atom,_Line4,fun2ms}}, 357 As0},Bound) -> 358 {transform_call(ets,Line,As0,Bound),Bound}; 359copy({call,Line,{remote,_Line2,{record_field,_Line3, 360 {atom,_Line4,''},{atom,_Line5,ets}}, 361 {atom,_Line6,fun2ms}}, As0},Bound) -> 362 %% Packages... 363 {transform_call(ets,Line,As0,Bound),Bound}; 364copy({call,Line,{remote,_Line2,{atom,_Line3,dbg},{atom,_Line4,fun2ms}}, 365 As0},Bound) -> 366 {transform_call(dbg,Line,As0,Bound),Bound}; 367copy({match,Line,A,B},Bound) -> 368 {B1,Bound1} = copy(B,Bound), 369 {A1,Bound2} = copy(A,Bound), 370 {{match,Line,A1,B1},gb_sets:union(Bound1,Bound2)}; 371copy({var,_Line,'_'} = VarDef,Bound) -> 372 {VarDef,Bound}; 373copy({var,_Line,Name} = VarDef,Bound) -> 374 Bound1 = gb_sets:add(Name,Bound), 375 {VarDef,Bound1}; 376copy({'fun',Line,{clauses,Clauses}},Bound) -> % Dont export bindings from funs 377 {NewClauses,_IgnoredBindings} = copy_list(Clauses,Bound), 378 {{'fun',Line,{clauses,NewClauses}},Bound}; 379copy({named_fun,Line,Name,Clauses},Bound) -> % Dont export bindings from funs 380 Bound1 = case Name of 381 '_' -> Bound; 382 Name -> gb_sets:add(Name,Bound) 383 end, 384 {NewClauses,_IgnoredBindings} = copy_list(Clauses,Bound1), 385 {{named_fun,Line,Name,NewClauses},Bound}; 386copy({'case',Line,Of,ClausesList},Bound) -> % Dont export bindings from funs 387 {NewOf,NewBind0} = copy(Of,Bound), 388 {NewClausesList,NewBindings} = copy_case_clauses(ClausesList,NewBind0,[]), 389 {{'case',Line,NewOf,NewClausesList},NewBindings}; 390copy(T,Bound) when is_tuple(T) -> 391 {L,Bound1} = copy_list(tuple_to_list(T),Bound), 392 {list_to_tuple(L),Bound1}; 393copy(L,Bound) when is_list(L) -> 394 copy_list(L,Bound); 395copy(AnyOther,Bound) -> 396 {AnyOther,Bound}. 397 398copy_case_clauses([],Bound,AddSets) -> 399 ReallyAdded = gb_sets:intersection(AddSets), 400 {[],gb_sets:union(Bound,ReallyAdded)}; 401copy_case_clauses([{clause,Line,Match,Guard,Clauses}|T],Bound,AddSets) -> 402 {NewMatch,MatchBinds} = copy(Match,Bound), 403 {NewGuard,GuardBinds} = copy(Guard,MatchBinds), %% Really no new binds 404 {NewClauses,AllBinds} = copy(Clauses,GuardBinds), 405 %% To limit the setsizes, I subtract what I had before the case clause 406 %% and add it in the end 407 AddedBinds = gb_sets:subtract(AllBinds,Bound), 408 {NewTail,ExportedBindings} = 409 copy_case_clauses(T,Bound,[AddedBinds | AddSets]), 410 {[{clause,Line,NewMatch,NewGuard,NewClauses}|NewTail],ExportedBindings}. 411 412copy_list([H|T],Bound) -> 413 {C1,Bound1} = copy(H,Bound), 414 {C2,Bound2} = copy_list(T,Bound1), 415 {[C1|C2],Bound2}; 416copy_list([],Bound) -> 417 {[],Bound}. 418 419transform_call(Type,_Line,[{'fun',Line2,{clauses, ClauseList}}],Bound) -> 420 ms_clause_list(Line2, ClauseList,Type,Bound); 421transform_call(_Type,Line,_NoAbstractFun,_) -> 422 throw({error,Line,?ERR_NOFUN}). 423 424% Fixup semicolons in guards 425ms_clause_expand({clause, Line, Parameters, Guard = [_,_|_], Body}) -> 426 [ {clause, Line, Parameters, [X], Body} || X <- Guard ]; 427ms_clause_expand(_Other) -> 428 false. 429 430ms_clause_list(Line,[H|T],Type,Bound) -> 431 case ms_clause_expand(H) of 432 NewHead when is_list(NewHead) -> 433 ms_clause_list(Line,NewHead ++ T, Type, Bound); 434 false -> 435 {cons, Line, ms_clause(H, Type, Bound), 436 ms_clause_list(Line, T, Type, Bound)} 437 end; 438ms_clause_list(Line,[],_,_) -> 439 {nil,Line}. 440ms_clause({clause, Line, Parameters, Guards, Body},Type,Bound) -> 441 check_type(Line,Parameters,Type), 442 {MSHead,Bindings} = transform_head(Parameters,Bound), 443 MSGuards = transform_guards(Line, Guards, Bindings), 444 MSBody = transform_body(Line,Body,Bindings), 445 {tuple, Line, [MSHead,MSGuards,MSBody]}. 446 447 448check_type(_,[{var,_,_}],_) -> 449 ok; 450check_type(_,[{tuple,_,_}],ets) -> 451 ok; 452check_type(_,[{record,_,_,_}],ets) -> 453 ok; 454check_type(_,[{cons,_,_,_}],dbg) -> 455 ok; 456check_type(_,[{nil,_}],dbg) -> 457 ok; 458check_type(Line0,[{match,_,{var,_,_},X}],Any) -> 459 check_type(Line0,[X],Any); 460check_type(Line0,[{match,_,X,{var,_,_}}],Any) -> 461 check_type(Line0,[X],Any); 462check_type(Line,_Type,ets) -> 463 throw({error,Line,?ERR_ETS_HEAD}); 464check_type(Line,_,dbg) -> 465 throw({error,Line,?ERR_DBG_HEAD}). 466 467-record(tgd,{ b, %Bindings 468 p, %Part of spec 469 eb %Error code base, 0 for guards, 100 for bodies 470 }). 471 472transform_guards(Line,[],_Bindings) -> 473 {nil,Line}; 474transform_guards(Line,[G],Bindings) -> 475 B = #tgd{b = Bindings, p = guard, eb = ?ERROR_BASE_GUARD}, 476 tg0(Line,G,B); 477transform_guards(Line,_,_) -> 478 throw({error,Line,?ERR_SEMI_GUARD}). 479 480transform_body(Line,Body,Bindings) -> 481 B = #tgd{b = Bindings, p = body, eb = ?ERROR_BASE_BODY}, 482 tg0(Line,Body,B). 483 484 485guard_top_trans({call,Line0,{atom,Line1,OldTest},Params}) -> 486 case old_bool_test(OldTest,length(Params)) of 487 undefined -> 488 {call,Line0,{atom,Line1,OldTest},Params}; 489 Trans -> 490 {call,Line0,{atom,Line1,Trans},Params} 491 end; 492guard_top_trans(Else) -> 493 Else. 494 495tg0(Line,[],_) -> 496 {nil,Line}; 497tg0(Line,[H0|T],B) when B#tgd.p =:= guard -> 498 H = guard_top_trans(H0), 499 {cons,Line, tg(H,B), tg0(Line,T,B)}; 500tg0(Line,[H|T],B) -> 501 {cons,Line, tg(H,B), tg0(Line,T,B)}. 502 503 504tg({match,Line,_,_},B) -> 505 throw({error,Line,?ERR_GENMATCH+B#tgd.eb}); 506tg({op, Line, Operator, O1, O2}=Expr, B) -> 507 case erl_eval:partial_eval(Expr) of 508 Expr -> 509 {tuple, Line, [{atom, Line, Operator}, tg(O1, B), tg(O2, B)]}; 510 Value -> 511 Value 512 end; 513tg({op, Line, Operator, O1}=Expr, B) -> 514 case erl_eval:partial_eval(Expr) of 515 Expr -> 516 {tuple, Line, [{atom, Line, Operator}, tg(O1, B)]}; 517 Value -> 518 Value 519 end; 520tg({call, _Line, {atom, Line2, bindings},[]},_B) -> 521 {atom, Line2, '$*'}; 522tg({call, _Line, {atom, Line2, object},[]},_B) -> 523 {atom, Line2, '$_'}; 524tg({call, Line, {atom, _, is_record}=Call,[Object, {atom,Line3,RName}=R]},B) -> 525 MSObject = tg(Object,B), 526 RDefs = get_records(), 527 case lists:keysearch(RName,1,RDefs) of 528 {value, {RName, FieldList}} -> 529 RSize = length(FieldList)+1, 530 {tuple, Line, [Call, MSObject, R, {integer, Line3, RSize}]}; 531 _ -> 532 throw({error,Line3,{?ERR_GENBADREC+B#tgd.eb,RName}}) 533 end; 534tg({call, Line, {atom, Line2, FunName},ParaList},B) -> 535 case is_ms_function(FunName,length(ParaList), B#tgd.p) of 536 true -> 537 {tuple, Line, [{atom, Line2, FunName} | 538 lists:map(fun(X) -> tg(X,B) end, ParaList)]}; 539 _ -> 540 throw({error,Line,{?ERR_GENLOCALCALL+B#tgd.eb, 541 FunName,length(ParaList)}}) 542 end; 543tg({call, Line, {remote,_,{atom,_,erlang},{atom, Line2, FunName}},ParaList}, 544 B) -> 545 L = length(ParaList), 546 case is_imported_from_erlang(FunName,L,B#tgd.p) of 547 true -> 548 case is_operator(FunName,L,B#tgd.p) of 549 false -> 550 tg({call, Line, {atom, Line2, FunName},ParaList},B); 551 true -> 552 tg(list_to_tuple([op,Line2,FunName | ParaList]),B) 553 end; 554 _ -> 555 throw({error,Line,{?ERR_GENREMOTECALL+B#tgd.eb,erlang, 556 FunName,length(ParaList)}}) 557 end; 558tg({call, Line, {remote,_,{atom,_,ModuleName}, 559 {atom, _, FunName}},ParaList},B) -> 560 throw({error,Line,{?ERR_GENREMOTECALL+B#tgd.eb,ModuleName,FunName,length(ParaList)}}); 561tg({cons,Line, H, T},B) -> 562 {cons, Line, tg(H,B), tg(T,B)}; 563tg({nil, Line},_B) -> 564 {nil, Line}; 565tg({tuple,Line,L},B) -> 566 {tuple,Line,[{tuple,Line,lists:map(fun(X) -> tg(X,B) end, L)}]}; 567tg({integer,Line,I},_) -> 568 {integer,Line,I}; 569tg({char,Line,C},_) -> 570 {char,Line,C}; 571tg({float, Line,F},_) -> 572 {float,Line,F}; 573tg({atom,Line,A},_) -> 574 case atom_to_list(A) of 575 [$$|_] -> 576 {tuple, Line,[{atom, Line, 'const'},{atom,Line,A}]}; 577 _ -> 578 {atom,Line,A} 579 end; 580tg({string,Line,S},_) -> 581 {string,Line,S}; 582tg({var,Line,VarName},B) -> 583 case lkup_bind(VarName, B#tgd.b) of 584 undefined -> 585 {tuple, Line,[{atom, Line, 'const'},{var,Line,VarName}]}; 586 AtomName -> 587 {atom, Line, AtomName} 588 end; 589tg({record_field,Line,Object,RName,{atom,_Line1,KeyName}},B) -> 590 RDefs = get_records(), 591 case lists:keysearch(RName,1,RDefs) of 592 {value, {RName, FieldList}} -> 593 case lists:keysearch(KeyName,1, FieldList) of 594 {value, {KeyName,Position,_}} -> 595 NewObject = tg(Object,B), 596 {tuple, Line, [{atom, Line, 'element'}, 597 {integer, Line, Position}, NewObject]}; 598 _ -> 599 throw({error,Line,{?ERR_GENBADFIELD+B#tgd.eb, RName, 600 KeyName}}) 601 end; 602 _ -> 603 throw({error,Line,{?ERR_GENBADREC+B#tgd.eb,RName}}) 604 end; 605 606tg({record,Line,RName,RFields},B) -> 607 RDefs = get_records(), 608 KeyList0 = lists:foldl(fun({record_field,_,{atom,_,Key},Value}, 609 L) -> 610 NV = tg(Value,B), 611 [{Key,NV}|L]; 612 ({record_field,_,{var,_,'_'},Value}, 613 L) -> 614 NV = tg(Value,B), 615 [{{default},NV}|L]; 616 (_,_) -> 617 throw({error,Line, 618 {?ERR_GENBADREC+B#tgd.eb, 619 RName}}) 620 end, 621 [], 622 RFields), 623 DefValue = case lists:keysearch({default},1,KeyList0) of 624 {value,{{default},OverriddenDefValue}} -> 625 {true,OverriddenDefValue}; 626 _ -> 627 false 628 end, 629 KeyList = lists:keydelete({default},1,KeyList0), 630 case lists:keysearch({default},1,KeyList) of 631 {value,{{default},_}} -> 632 throw({error,Line,{?ERR_GENMULTIFIELD+B#tgd.eb,RName,'_'}}); 633 _ -> 634 ok 635 end, 636 case lists:keysearch(RName,1,RDefs) of 637 {value, {RName, FieldList0}} -> 638 FieldList1 = lists:foldl( 639 fun({FN,_,Def},Acc) -> 640 El = case lists:keysearch(FN,1,KeyList) of 641 {value, {FN, X0}} -> 642 X0; 643 _ -> 644 case DefValue of 645 {true,Overridden} -> 646 Overridden; 647 false -> 648 Def 649 end 650 end, 651 [El | Acc] 652 end, 653 [], 654 FieldList0), 655 check_multi_field(RName,Line,KeyList, 656 ?ERR_GENMULTIFIELD+B#tgd.eb), 657 check_undef_field(RName,Line,KeyList,FieldList0, 658 ?ERR_GENBADFIELD+B#tgd.eb), 659 {tuple,Line,[{tuple,Line,[{atom,Line,RName}|FieldList1]}]}; 660 _ -> 661 throw({error,Line,{?ERR_GENBADREC+B#tgd.eb,RName}}) 662 end; 663 664tg({record_index,Line,RName,{atom,Line2,KeyName}},B) -> 665 RDefs = get_records(), 666 case lists:keysearch(RName,1,RDefs) of 667 {value, {RName, FieldList}} -> 668 case lists:keysearch(KeyName,1, FieldList) of 669 {value, {KeyName,Position,_}} -> 670 {integer, Line2, Position}; 671 _ -> 672 throw({error,Line2,{?ERR_GENBADFIELD+B#tgd.eb, RName, 673 KeyName}}) 674 end; 675 _ -> 676 throw({error,Line,{?ERR_GENBADREC+B#tgd.eb,RName}}) 677 end; 678 679tg({record,Line,{var,Line2,_VName}=AVName, RName,RFields},B) -> 680 RDefs = get_records(), 681 MSVName = tg(AVName,B), 682 KeyList = lists:foldl(fun({record_field,_,{atom,_,Key},Value}, 683 L) -> 684 NV = tg(Value,B), 685 [{Key,NV}|L]; 686 (_,_) -> 687 throw({error,Line,?ERR_HEADBADREC}) 688 end, 689 [], 690 RFields), 691 case lists:keysearch(RName,1,RDefs) of 692 {value, {RName, FieldList0}} -> 693 FieldList1 = lists:foldl( 694 fun({FN,Pos,_},Acc) -> 695 El = case lists:keysearch(FN,1,KeyList) of 696 {value, {FN, X0}} -> 697 X0; 698 _ -> 699 {tuple, Line2, 700 [{atom, Line2, element}, 701 {integer, Line2, Pos}, 702 MSVName]} 703 end, 704 [El | Acc] 705 end, 706 [], 707 FieldList0), 708 check_multi_field(RName,Line,KeyList, 709 ?ERR_GENMULTIFIELD+B#tgd.eb), 710 check_undef_field(RName,Line,KeyList,FieldList0, 711 ?ERR_GENBADFIELD+B#tgd.eb), 712 {tuple,Line,[{tuple,Line,[{atom,Line,RName}|FieldList1]}]}; 713 _ -> 714 throw({error,Line,{?ERR_GENBADREC+B#tgd.eb,RName}}) 715 end; 716 717tg({bin_element,_Line0,{var, Line, A},_,_} = Whole,B) -> 718 case lkup_bind(A, B#tgd.b) of 719 undefined -> 720 Whole; % exists in environment hopefully 721 _AtomName -> 722 throw({error,Line,{?ERR_GENBINCONSTRUCT+B#tgd.eb,A}}) 723 end; 724tg(default,_B) -> 725 default; 726tg({bin_element,Line,X,Y,Z},B) -> 727 {bin_element, Line, tg(X,B), tg(Y,B), Z}; 728 729tg({bin,Line,List},B) -> 730 {bin,Line,[tg(X,B) || X <- List]}; 731 732tg(T,B) when is_tuple(T), tuple_size(T) >= 2 -> 733 Element = element(1,T), 734 Line = element(2,T), 735 throw({error,Line,{?ERR_GENELEMENT+B#tgd.eb, 736 translate_language_element(Element)}}); 737tg(Other,B) -> 738 Element = io_lib:format("unknown element ~tw", [Other]), 739 throw({error,unknown,{?ERR_GENELEMENT+B#tgd.eb,Element}}). 740 741transform_head([V],OuterBound) -> 742 Bind = cre_bind(), 743 {NewV,NewBind} = toplevel_head_match(V,Bind,OuterBound), 744 th(NewV,NewBind,OuterBound). 745 746 747toplevel_head_match({match,_,{var,Line,VName},Expr},B,OB) -> 748 warn_var_clash(Line,VName,OB), 749 {Expr,new_bind({VName,'$_'},B)}; 750toplevel_head_match({match,_,Expr,{var,Line,VName}},B,OB) -> 751 warn_var_clash(Line,VName,OB), 752 {Expr,new_bind({VName,'$_'},B)}; 753toplevel_head_match(Other,B,_OB) -> 754 {Other,B}. 755 756th({record,Line,RName,RFields},B,OB) -> 757 % youch... 758 RDefs = get_records(), 759 {KeyList0,NewB} = lists:foldl(fun({record_field,_,{atom,_,Key},Value}, 760 {L,B0}) -> 761 {NV,B1} = th(Value,B0,OB), 762 {[{Key,NV}|L],B1}; 763 ({record_field,_,{var,_,'_'},Value}, 764 {L,B0}) -> 765 {NV,B1} = th(Value,B0,OB), 766 {[{{default},NV}|L],B1}; 767 (_,_) -> 768 throw({error,Line,{?ERR_HEADBADREC, 769 RName}}) 770 end, 771 {[],B}, 772 RFields), 773 DefValue = case lists:keysearch({default},1,KeyList0) of 774 {value,{{default},OverriddenDefValue}} -> 775 OverriddenDefValue; 776 _ -> 777 {atom,Line,'_'} 778 end, 779 KeyList = lists:keydelete({default},1,KeyList0), 780 case lists:keysearch({default},1,KeyList) of 781 {value,{{default},_}} -> 782 throw({error,Line,{?ERR_HEADMULTIFIELD,RName,'_'}}); 783 _ -> 784 ok 785 end, 786 case lists:keysearch(RName,1,RDefs) of 787 {value, {RName, FieldList0}} -> 788 FieldList1 = lists:foldl( 789 fun({FN,_,_},Acc) -> 790 El = case lists:keysearch(FN,1,KeyList) of 791 {value, {FN, X0}} -> 792 X0; 793 _ -> 794 DefValue 795 end, 796 [El | Acc] 797 end, 798 [], 799 FieldList0), 800 check_multi_field(RName,Line,KeyList, 801 ?ERR_HEADMULTIFIELD), 802 check_undef_field(RName,Line,KeyList,FieldList0, 803 ?ERR_HEADBADFIELD), 804 {{tuple,Line,[{atom,Line,RName}|FieldList1]},NewB}; 805 _ -> 806 throw({error,Line,{?ERR_HEADBADREC,RName}}) 807 end; 808th({match,Line,_,_},_,_) -> 809 throw({error,Line,?ERR_HEADMATCH}); 810th({atom,Line,A},B,_OB) -> 811 case atom_to_list(A) of 812 [$$|NL] -> 813 case (catch list_to_integer(NL)) of 814 N when is_integer(N) -> 815 throw({error,Line,{?ERR_HEADDOLLARATOM,A}}); 816 _ -> 817 {{atom,Line,A},B} 818 end; 819 _ -> 820 {{atom,Line,A},B} 821 end; 822th({bin_element,_Line0,{var, Line, A},_,_},_,_) -> 823 throw({error,Line,{?ERR_HEADBINMATCH,A}}); 824 825th({var,Line,Name},B,OB) -> 826 warn_var_clash(Line,Name,OB), 827 case lkup_bind(Name,B) of 828 undefined -> 829 NewB = new_bind(Name,B), 830 {{atom,Line,lkup_bind(Name,NewB)},NewB}; 831 Trans -> 832 {{atom,Line,Trans},B} 833 end; 834th([H|T],B,OB) -> 835 {NH,NB} = th(H,B,OB), 836 {NT,NNB} = th(T,NB,OB), 837 {[NH|NT],NNB}; 838th(T,B,OB) when is_tuple(T) -> 839 {L,NB} = th(tuple_to_list(T),B,OB), 840 {list_to_tuple(L),NB}; 841th(Nonstruct,B,_OB) -> 842 {Nonstruct,B}. 843 844warn_var_clash(Anno,Name,OuterBound) -> 845 case gb_sets:is_member(Name,OuterBound) of 846 true -> 847 Line = erl_anno:line(Anno), 848 add_warning(Line,{?WARN_SHADOW_VAR,Name}); 849 _ -> 850 ok 851 end. 852 853%% Could be more efficient... 854check_multi_field(_, _, [], _) -> 855 ok; 856check_multi_field(RName, Line, [{Key,_}|T], ErrCode) -> 857 case lists:keymember(Key,1,T) of 858 true -> 859 throw({error,Line,{ErrCode,RName,Key}}); 860 false -> 861 check_multi_field(RName, Line, T, ErrCode) 862 end. 863check_undef_field(_, _, [], _, _) -> 864 ok; 865check_undef_field(RName, Line, [{Key,_}|T], FieldList, ErrCode) -> 866 case lists:keymember(Key, 1, FieldList) of 867 true -> 868 check_undef_field(RName, Line, T, FieldList, ErrCode); 869 false -> 870 throw({error,Line,{ErrCode,RName,Key}}) 871 end. 872 873cre_bind() -> 874 {1,[{'_','_'}]}. 875 876lkup_bind(Name,{_,List}) -> 877 case lists:keysearch(Name,1,List) of 878 {value, {Name, Trans}} -> 879 Trans; 880 _ -> 881 undefined 882 end. 883 884new_bind({Name,Trans},{Next,L}) -> 885 {Next,[{Name,Trans}|L]}; 886new_bind(Name,{Next,L}) -> 887 Trans = list_to_atom([$$|integer_to_list(Next)]), 888 {Next+1,[{Name,Trans}|L]}. 889 890translate_language_element(Atom) -> 891 Transtab = [ 892 {lc,"list comprehension"}, 893 {bc,"binary comprehension"}, 894 {block, "begin/end block"}, 895 {'if', "if"}, 896 {'case', "case"}, 897 {'receive', "receive"}, 898 {'try', "try"}, 899 {'catch', "catch"}, 900 {'match', "match (=)"}, 901 {remote, "external function call"} 902 ], 903 case lists:keysearch(Atom,1,Transtab) of 904 {value,{Atom, String}} -> 905 String; 906 _ -> 907 atom_to_list(Atom) 908 end. 909 910old_bool_test(atom,1) -> is_atom; 911old_bool_test(float,1) -> is_float; 912old_bool_test(integer,1) -> is_integer; 913old_bool_test(list,1) -> is_list; 914old_bool_test(number,1) -> is_number; 915old_bool_test(pid,1) -> is_pid; 916old_bool_test(port,1) -> is_port; 917old_bool_test(reference,1) -> is_reference; 918old_bool_test(tuple,1) -> is_tuple; 919old_bool_test(binary,1) -> is_binary; 920old_bool_test(function,1) -> is_function; 921old_bool_test(record,2) -> is_record; 922old_bool_test(_,_) -> undefined. 923 924bool_test(is_atom,1) -> true; 925bool_test(is_float,1) -> true; 926bool_test(is_integer,1) -> true; 927bool_test(is_list,1) -> true; 928bool_test(is_number,1) -> true; 929bool_test(is_pid,1) -> true; 930bool_test(is_port,1) -> true; 931bool_test(is_reference,1) -> true; 932bool_test(is_tuple,1) -> true; 933bool_test(is_map,1) -> true; 934bool_test(is_map_key, 2) -> true; 935bool_test(is_binary,1) -> true; 936bool_test(is_function,1) -> true; 937bool_test(is_record,2) -> true; 938bool_test(is_seq_trace,0) -> true; 939bool_test(_,_) -> false. 940 941real_guard_function(abs,1) -> true; 942real_guard_function(element,2) -> true; 943real_guard_function(hd,1) -> true; 944real_guard_function(length,1) -> true; 945real_guard_function(node,0) -> true; 946real_guard_function(node,1) -> true; 947real_guard_function(round,1) -> true; 948real_guard_function(size,1) -> true; 949real_guard_function(bit_size,1) -> true; 950real_guard_function(map_size,1) -> true; 951real_guard_function(map_get,2) -> true; 952real_guard_function(tl,1) -> true; 953real_guard_function(trunc,1) -> true; 954real_guard_function(self,0) -> true; 955real_guard_function(float,1) -> true; 956real_guard_function(_,_) -> false. 957 958pseudo_guard_function(get_tcw,0) -> true; 959pseudo_guard_function(_,_) -> false. 960 961guard_function(X,A) -> 962 real_guard_function(X,A) or pseudo_guard_function(X,A). 963 964action_function(set_seq_token,2) -> true; 965action_function(get_seq_token,0) -> true; 966action_function(message,1) -> true; 967action_function(return_trace,0) -> true; 968action_function(exception_trace,0) -> true; 969action_function(process_dump,0) -> true; 970action_function(enable_trace,1) -> true; 971action_function(enable_trace,2) -> true; 972action_function(disable_trace,1) -> true; 973action_function(disable_trace,2) -> true; 974action_function(display,1) -> true; 975action_function(caller,0) -> true; 976action_function(set_tcw,1) -> true; 977action_function(silent,1) -> true; 978action_function(trace,2) -> true; 979action_function(trace,3) -> true; 980action_function(_,_) -> false. 981 982bool_operator('and',2) -> 983 true; 984bool_operator('or',2) -> 985 true; 986bool_operator('xor',2) -> 987 true; 988bool_operator('not',1) -> 989 true; 990bool_operator('andalso',2) -> 991 true; 992bool_operator('orelse',2) -> 993 true; 994bool_operator(_,_) -> 995 false. 996 997arith_operator('+',1) -> 998 true; 999arith_operator('+',2) -> 1000 true; 1001arith_operator('-',1) -> 1002 true; 1003arith_operator('-',2) -> 1004 true; 1005arith_operator('*',2) -> 1006 true; 1007arith_operator('/',2) -> 1008 true; 1009arith_operator('div',2) -> 1010 true; 1011arith_operator('rem',2) -> 1012 true; 1013arith_operator('band',2) -> 1014 true; 1015arith_operator('bor',2) -> 1016 true; 1017arith_operator('bxor',2) -> 1018 true; 1019arith_operator('bnot',1) -> 1020 true; 1021arith_operator('bsl',2) -> 1022 true; 1023arith_operator('bsr',2) -> 1024 true; 1025arith_operator(_,_) -> 1026 false. 1027 1028cmp_operator('>',2) -> 1029 true; 1030cmp_operator('>=',2) -> 1031 true; 1032cmp_operator('<',2) -> 1033 true; 1034cmp_operator('=<',2) -> 1035 true; 1036cmp_operator('==',2) -> 1037 true; 1038cmp_operator('=:=',2) -> 1039 true; 1040cmp_operator('/=',2) -> 1041 true; 1042cmp_operator('=/=',2) -> 1043 true; 1044cmp_operator(_,_) -> 1045 false. 1046 1047is_operator(X,A,_) -> 1048 bool_operator(X,A) or arith_operator(X,A) or cmp_operator(X,A). 1049 1050is_imported_from_erlang(X,A,_) -> 1051 real_guard_function(X,A) or bool_test(X,A) or bool_operator(X,A) or 1052 arith_operator(X,A) or cmp_operator(X,A). 1053 1054is_ms_function(X,A,body) -> 1055 action_function(X,A) or guard_function(X,A) or bool_test(X,A); 1056 1057is_ms_function(X,A,guard) -> 1058 guard_function(X,A) or bool_test(X,A). 1059 1060fixup_environment(L,B) when is_list(L) -> 1061 lists:map(fun(X) -> 1062 fixup_environment(X,B) 1063 end, 1064 L); 1065fixup_environment({var,Line,Name},B) -> 1066 case lists:keysearch(Name,1,B) of 1067 {value,{Name,Value}} -> 1068 freeze(Line,Value); 1069 _ -> 1070 throw({error,Line,{?ERR_UNBOUND_VARIABLE,atom_to_list(Name)}}) 1071 end; 1072fixup_environment(T,B) when is_tuple(T) -> 1073 list_to_tuple( 1074 lists:map(fun(X) -> 1075 fixup_environment(X,B) 1076 end, 1077 tuple_to_list(T))); 1078fixup_environment(Other,_B) -> 1079 Other. 1080 1081freeze(Line,Term) -> 1082 {frozen,Line,Term}. 1083 1084%% Most of this is bluntly stolen from erl_parse. 1085 1086normalise({frozen,_,Term}) -> 1087 Term; 1088normalise({char,_,C}) -> C; 1089normalise({integer,_,I}) -> I; 1090normalise({float,_,F}) -> F; 1091normalise({atom,_,A}) -> A; 1092normalise({string,_,S}) -> S; 1093normalise({nil,_}) -> []; 1094normalise({bin,_,Fs}) -> 1095 {value, B, _} = 1096 eval_bits:expr_grp(Fs, [], 1097 fun(E, _) -> 1098 {value, normalise(E), []} 1099 end, [], true), 1100 B; 1101normalise({cons,_,Head,Tail}) -> 1102 [normalise(Head)|normalise(Tail)]; 1103normalise({tuple,_,Args}) -> 1104 list_to_tuple(normalise_list(Args)); 1105normalise({map,_,Pairs0}) -> 1106 Pairs1 = lists:map(fun ({map_field_exact,_,K,V}) -> 1107 {normalise(K),normalise(V)} 1108 end, 1109 Pairs0), 1110 maps:from_list(Pairs1); 1111%% Special case for unary +/-. 1112normalise({op,_,'+',{char,_,I}}) -> I; 1113normalise({op,_,'+',{integer,_,I}}) -> I; 1114normalise({op,_,'+',{float,_,F}}) -> F; 1115normalise({op,_,'-',{char,_,I}}) -> -I; % Weird, but compatible! 1116normalise({op,_,'-',{integer,_,I}}) -> -I; 1117normalise({op,_,'-',{float,_,F}}) -> -F. 1118 1119normalise_list([H|T]) -> 1120 [normalise(H)|normalise_list(T)]; 1121normalise_list([]) -> 1122 []. 1123