1%% 2%% %CopyrightBegin% 3%% 4%% Copyright Ericsson AB 2002-2020. 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,{atom,_Line3,dbg},{atom,_Line4,fun2ms}}, 360 As0},Bound) -> 361 {transform_call(dbg,Line,As0,Bound),Bound}; 362copy({match,Line,A,B},Bound) -> 363 {B1,Bound1} = copy(B,Bound), 364 {A1,Bound2} = copy(A,Bound), 365 {{match,Line,A1,B1},gb_sets:union(Bound1,Bound2)}; 366copy({var,_Line,'_'} = VarDef,Bound) -> 367 {VarDef,Bound}; 368copy({var,_Line,Name} = VarDef,Bound) -> 369 Bound1 = gb_sets:add(Name,Bound), 370 {VarDef,Bound1}; 371copy({'fun',Line,{clauses,Clauses}},Bound) -> % Dont export bindings from funs 372 {NewClauses,_IgnoredBindings} = copy_list(Clauses,Bound), 373 {{'fun',Line,{clauses,NewClauses}},Bound}; 374copy({named_fun,Line,Name,Clauses},Bound) -> % Dont export bindings from funs 375 Bound1 = case Name of 376 '_' -> Bound; 377 Name -> gb_sets:add(Name,Bound) 378 end, 379 {NewClauses,_IgnoredBindings} = copy_list(Clauses,Bound1), 380 {{named_fun,Line,Name,NewClauses},Bound}; 381copy({'case',Line,Of,ClausesList},Bound) -> % Dont export bindings from funs 382 {NewOf,NewBind0} = copy(Of,Bound), 383 {NewClausesList,NewBindings} = copy_case_clauses(ClausesList,NewBind0,[]), 384 {{'case',Line,NewOf,NewClausesList},NewBindings}; 385copy(T,Bound) when is_tuple(T) -> 386 {L,Bound1} = copy_list(tuple_to_list(T),Bound), 387 {list_to_tuple(L),Bound1}; 388copy(L,Bound) when is_list(L) -> 389 copy_list(L,Bound); 390copy(AnyOther,Bound) -> 391 {AnyOther,Bound}. 392 393copy_case_clauses([],Bound,AddSets) -> 394 ReallyAdded = gb_sets:intersection(AddSets), 395 {[],gb_sets:union(Bound,ReallyAdded)}; 396copy_case_clauses([{clause,Line,Match,Guard,Clauses}|T],Bound,AddSets) -> 397 {NewMatch,MatchBinds} = copy(Match,Bound), 398 {NewGuard,GuardBinds} = copy(Guard,MatchBinds), %% Really no new binds 399 {NewClauses,AllBinds} = copy(Clauses,GuardBinds), 400 %% To limit the setsizes, I subtract what I had before the case clause 401 %% and add it in the end 402 AddedBinds = gb_sets:subtract(AllBinds,Bound), 403 {NewTail,ExportedBindings} = 404 copy_case_clauses(T,Bound,[AddedBinds | AddSets]), 405 {[{clause,Line,NewMatch,NewGuard,NewClauses}|NewTail],ExportedBindings}. 406 407copy_list([H|T],Bound) -> 408 {C1,Bound1} = copy(H,Bound), 409 {C2,Bound2} = copy_list(T,Bound1), 410 {[C1|C2],Bound2}; 411copy_list([],Bound) -> 412 {[],Bound}. 413 414transform_call(Type,_Line,[{'fun',Line2,{clauses, ClauseList}}],Bound) -> 415 ms_clause_list(Line2, ClauseList,Type,Bound); 416transform_call(_Type,Line,_NoAbstractFun,_) -> 417 throw({error,Line,?ERR_NOFUN}). 418 419% Fixup semicolons in guards 420ms_clause_expand({clause, Line, Parameters, Guard = [_,_|_], Body}) -> 421 [ {clause, Line, Parameters, [X], Body} || X <- Guard ]; 422ms_clause_expand(_Other) -> 423 false. 424 425ms_clause_list(Line,[H|T],Type,Bound) -> 426 case ms_clause_expand(H) of 427 NewHead when is_list(NewHead) -> 428 ms_clause_list(Line,NewHead ++ T, Type, Bound); 429 false -> 430 {cons, Line, ms_clause(H, Type, Bound), 431 ms_clause_list(Line, T, Type, Bound)} 432 end; 433ms_clause_list(Line,[],_,_) -> 434 {nil,Line}. 435ms_clause({clause, Line, Parameters, Guards, Body},Type,Bound) -> 436 check_type(Line,Parameters,Type), 437 {MSHead,Bindings} = transform_head(Parameters,Bound), 438 MSGuards = transform_guards(Line, Guards, Bindings), 439 MSBody = transform_body(Line,Body,Bindings), 440 {tuple, Line, [MSHead,MSGuards,MSBody]}. 441 442 443check_type(_,[{var,_,_}],_) -> 444 ok; 445check_type(_,[{tuple,_,_}],ets) -> 446 ok; 447check_type(_,[{record,_,_,_}],ets) -> 448 ok; 449check_type(_,[{cons,_,_,_}],dbg) -> 450 ok; 451check_type(_,[{nil,_}],dbg) -> 452 ok; 453check_type(Line0,[{match,_,{var,_,_},X}],Any) -> 454 check_type(Line0,[X],Any); 455check_type(Line0,[{match,_,X,{var,_,_}}],Any) -> 456 check_type(Line0,[X],Any); 457check_type(Line,_Type,ets) -> 458 throw({error,Line,?ERR_ETS_HEAD}); 459check_type(Line,_,dbg) -> 460 throw({error,Line,?ERR_DBG_HEAD}). 461 462-record(tgd,{ b, %Bindings 463 p, %Part of spec 464 eb %Error code base, 0 for guards, 100 for bodies 465 }). 466 467transform_guards(Line,[],_Bindings) -> 468 {nil,Line}; 469transform_guards(Line,[G],Bindings) -> 470 B = #tgd{b = Bindings, p = guard, eb = ?ERROR_BASE_GUARD}, 471 tg0(Line,G,B); 472transform_guards(Line,_,_) -> 473 throw({error,Line,?ERR_SEMI_GUARD}). 474 475transform_body(Line,Body,Bindings) -> 476 B = #tgd{b = Bindings, p = body, eb = ?ERROR_BASE_BODY}, 477 tg0(Line,Body,B). 478 479 480guard_top_trans({call,Line0,{atom,Line1,OldTest},Params}) -> 481 case old_bool_test(OldTest,length(Params)) of 482 undefined -> 483 {call,Line0,{atom,Line1,OldTest},Params}; 484 Trans -> 485 {call,Line0,{atom,Line1,Trans},Params} 486 end; 487guard_top_trans(Else) -> 488 Else. 489 490tg0(Line,[],_) -> 491 {nil,Line}; 492tg0(Line,[H0|T],B) when B#tgd.p =:= guard -> 493 H = guard_top_trans(H0), 494 {cons,Line, tg(H,B), tg0(Line,T,B)}; 495tg0(Line,[H|T],B) -> 496 {cons,Line, tg(H,B), tg0(Line,T,B)}. 497 498 499tg({match,Line,_,_},B) -> 500 throw({error,Line,?ERR_GENMATCH+B#tgd.eb}); 501tg({op, Line, Operator, O1, O2}=Expr, B) -> 502 case erl_eval:partial_eval(Expr) of 503 Expr -> 504 {tuple, Line, [{atom, Line, Operator}, tg(O1, B), tg(O2, B)]}; 505 Value -> 506 Value 507 end; 508tg({op, Line, Operator, O1}=Expr, B) -> 509 case erl_eval:partial_eval(Expr) of 510 Expr -> 511 {tuple, Line, [{atom, Line, Operator}, tg(O1, B)]}; 512 Value -> 513 Value 514 end; 515tg({call, _Line, {atom, Line2, bindings},[]},_B) -> 516 {atom, Line2, '$*'}; 517tg({call, _Line, {atom, Line2, object},[]},_B) -> 518 {atom, Line2, '$_'}; 519tg({call, Line, {atom, _, is_record}=Call,[Object, {atom,Line3,RName}=R]},B) -> 520 MSObject = tg(Object,B), 521 RDefs = get_records(), 522 case lists:keysearch(RName,1,RDefs) of 523 {value, {RName, FieldList}} -> 524 RSize = length(FieldList)+1, 525 {tuple, Line, [Call, MSObject, R, {integer, Line3, RSize}]}; 526 _ -> 527 throw({error,Line3,{?ERR_GENBADREC+B#tgd.eb,RName}}) 528 end; 529tg({call, Line, {atom, Line2, FunName},ParaList},B) -> 530 case is_ms_function(FunName,length(ParaList), B#tgd.p) of 531 true -> 532 {tuple, Line, [{atom, Line2, FunName} | 533 lists:map(fun(X) -> tg(X,B) end, ParaList)]}; 534 _ -> 535 throw({error,Line,{?ERR_GENLOCALCALL+B#tgd.eb, 536 FunName,length(ParaList)}}) 537 end; 538tg({call, Line, {remote,_,{atom,_,erlang},{atom, Line2, FunName}},ParaList}, 539 B) -> 540 L = length(ParaList), 541 case is_imported_from_erlang(FunName,L,B#tgd.p) of 542 true -> 543 case is_operator(FunName,L,B#tgd.p) of 544 false -> 545 tg({call, Line, {atom, Line2, FunName},ParaList},B); 546 true -> 547 tg(list_to_tuple([op,Line2,FunName | ParaList]),B) 548 end; 549 _ -> 550 throw({error,Line,{?ERR_GENREMOTECALL+B#tgd.eb,erlang, 551 FunName,length(ParaList)}}) 552 end; 553tg({call, Line, {remote,_,{atom,_,ModuleName}, 554 {atom, _, FunName}},ParaList},B) -> 555 throw({error,Line,{?ERR_GENREMOTECALL+B#tgd.eb,ModuleName,FunName,length(ParaList)}}); 556tg({cons,Line, H, T},B) -> 557 {cons, Line, tg(H,B), tg(T,B)}; 558tg({nil, Line},_B) -> 559 {nil, Line}; 560tg({tuple,Line,L},B) -> 561 {tuple,Line,[{tuple,Line,lists:map(fun(X) -> tg(X,B) end, L)}]}; 562tg({integer,Line,I},_) -> 563 {integer,Line,I}; 564tg({char,Line,C},_) -> 565 {char,Line,C}; 566tg({float, Line,F},_) -> 567 {float,Line,F}; 568tg({atom,Line,A},_) -> 569 case atom_to_list(A) of 570 [$$|_] -> 571 {tuple, Line,[{atom, Line, 'const'},{atom,Line,A}]}; 572 _ -> 573 {atom,Line,A} 574 end; 575tg({string,Line,S},_) -> 576 {string,Line,S}; 577tg({var,Line,VarName},B) -> 578 case lkup_bind(VarName, B#tgd.b) of 579 undefined -> 580 {tuple, Line,[{atom, Line, 'const'},{var,Line,VarName}]}; 581 AtomName -> 582 {atom, Line, AtomName} 583 end; 584tg({record_field,Line,Object,RName,{atom,_Line1,KeyName}},B) -> 585 RDefs = get_records(), 586 case lists:keysearch(RName,1,RDefs) of 587 {value, {RName, FieldList}} -> 588 case lists:keysearch(KeyName,1, FieldList) of 589 {value, {KeyName,Position,_}} -> 590 NewObject = tg(Object,B), 591 {tuple, Line, [{atom, Line, 'element'}, 592 {integer, Line, Position}, NewObject]}; 593 _ -> 594 throw({error,Line,{?ERR_GENBADFIELD+B#tgd.eb, RName, 595 KeyName}}) 596 end; 597 _ -> 598 throw({error,Line,{?ERR_GENBADREC+B#tgd.eb,RName}}) 599 end; 600 601tg({record,Line,RName,RFields},B) -> 602 RDefs = get_records(), 603 KeyList0 = lists:foldl(fun({record_field,_,{atom,_,Key},Value}, 604 L) -> 605 NV = tg(Value,B), 606 [{Key,NV}|L]; 607 ({record_field,_,{var,_,'_'},Value}, 608 L) -> 609 NV = tg(Value,B), 610 [{{default},NV}|L]; 611 (_,_) -> 612 throw({error,Line, 613 {?ERR_GENBADREC+B#tgd.eb, 614 RName}}) 615 end, 616 [], 617 RFields), 618 DefValue = case lists:keysearch({default},1,KeyList0) of 619 {value,{{default},OverriddenDefValue}} -> 620 {true,OverriddenDefValue}; 621 _ -> 622 false 623 end, 624 KeyList = lists:keydelete({default},1,KeyList0), 625 case lists:keysearch({default},1,KeyList) of 626 {value,{{default},_}} -> 627 throw({error,Line,{?ERR_GENMULTIFIELD+B#tgd.eb,RName,'_'}}); 628 _ -> 629 ok 630 end, 631 case lists:keysearch(RName,1,RDefs) of 632 {value, {RName, FieldList0}} -> 633 FieldList1 = lists:foldl( 634 fun({FN,_,Def},Acc) -> 635 El = case lists:keysearch(FN,1,KeyList) of 636 {value, {FN, X0}} -> 637 X0; 638 _ -> 639 case DefValue of 640 {true,Overridden} -> 641 Overridden; 642 false -> 643 Def 644 end 645 end, 646 [El | Acc] 647 end, 648 [], 649 FieldList0), 650 check_multi_field(RName,Line,KeyList, 651 ?ERR_GENMULTIFIELD+B#tgd.eb), 652 check_undef_field(RName,Line,KeyList,FieldList0, 653 ?ERR_GENBADFIELD+B#tgd.eb), 654 {tuple,Line,[{tuple,Line,[{atom,Line,RName}|FieldList1]}]}; 655 _ -> 656 throw({error,Line,{?ERR_GENBADREC+B#tgd.eb,RName}}) 657 end; 658 659tg({record_index,Line,RName,{atom,Line2,KeyName}},B) -> 660 RDefs = get_records(), 661 case lists:keysearch(RName,1,RDefs) of 662 {value, {RName, FieldList}} -> 663 case lists:keysearch(KeyName,1, FieldList) of 664 {value, {KeyName,Position,_}} -> 665 {integer, Line2, Position}; 666 _ -> 667 throw({error,Line2,{?ERR_GENBADFIELD+B#tgd.eb, RName, 668 KeyName}}) 669 end; 670 _ -> 671 throw({error,Line,{?ERR_GENBADREC+B#tgd.eb,RName}}) 672 end; 673 674tg({record,Line,{var,Line2,_VName}=AVName, RName,RFields},B) -> 675 RDefs = get_records(), 676 MSVName = tg(AVName,B), 677 KeyList = lists:foldl(fun({record_field,_,{atom,_,Key},Value}, 678 L) -> 679 NV = tg(Value,B), 680 [{Key,NV}|L]; 681 (_,_) -> 682 throw({error,Line,?ERR_HEADBADREC}) 683 end, 684 [], 685 RFields), 686 case lists:keysearch(RName,1,RDefs) of 687 {value, {RName, FieldList0}} -> 688 FieldList1 = lists:foldl( 689 fun({FN,Pos,_},Acc) -> 690 El = case lists:keysearch(FN,1,KeyList) of 691 {value, {FN, X0}} -> 692 X0; 693 _ -> 694 {tuple, Line2, 695 [{atom, Line2, element}, 696 {integer, Line2, Pos}, 697 MSVName]} 698 end, 699 [El | Acc] 700 end, 701 [], 702 FieldList0), 703 check_multi_field(RName,Line,KeyList, 704 ?ERR_GENMULTIFIELD+B#tgd.eb), 705 check_undef_field(RName,Line,KeyList,FieldList0, 706 ?ERR_GENBADFIELD+B#tgd.eb), 707 {tuple,Line,[{tuple,Line,[{atom,Line,RName}|FieldList1]}]}; 708 _ -> 709 throw({error,Line,{?ERR_GENBADREC+B#tgd.eb,RName}}) 710 end; 711 712tg({bin_element,_Line0,{var, Line, A},_,_} = Whole,B) -> 713 case lkup_bind(A, B#tgd.b) of 714 undefined -> 715 Whole; % exists in environment hopefully 716 _AtomName -> 717 throw({error,Line,{?ERR_GENBINCONSTRUCT+B#tgd.eb,A}}) 718 end; 719tg(default,_B) -> 720 default; 721tg({bin_element,Line,X,Y,Z},B) -> 722 {bin_element, Line, tg(X,B), tg(Y,B), Z}; 723 724tg({bin,Line,List},B) -> 725 {bin,Line,[tg(X,B) || X <- List]}; 726 727tg(T,B) when is_tuple(T), tuple_size(T) >= 2 -> 728 Element = element(1,T), 729 Line = element(2,T), 730 throw({error,Line,{?ERR_GENELEMENT+B#tgd.eb, 731 translate_language_element(Element)}}); 732tg(Other,B) -> 733 Element = io_lib:format("unknown element ~tw", [Other]), 734 throw({error,unknown,{?ERR_GENELEMENT+B#tgd.eb,Element}}). 735 736transform_head([V],OuterBound) -> 737 Bind = cre_bind(), 738 {NewV,NewBind} = toplevel_head_match(V,Bind,OuterBound), 739 th(NewV,NewBind,OuterBound). 740 741 742toplevel_head_match({match,_,{var,Line,VName},Expr},B,OB) -> 743 warn_var_clash(Line,VName,OB), 744 {Expr,new_bind({VName,'$_'},B)}; 745toplevel_head_match({match,_,Expr,{var,Line,VName}},B,OB) -> 746 warn_var_clash(Line,VName,OB), 747 {Expr,new_bind({VName,'$_'},B)}; 748toplevel_head_match(Other,B,_OB) -> 749 {Other,B}. 750 751th({record,Line,RName,RFields},B,OB) -> 752 % youch... 753 RDefs = get_records(), 754 {KeyList0,NewB} = lists:foldl(fun({record_field,_,{atom,_,Key},Value}, 755 {L,B0}) -> 756 {NV,B1} = th(Value,B0,OB), 757 {[{Key,NV}|L],B1}; 758 ({record_field,_,{var,_,'_'},Value}, 759 {L,B0}) -> 760 {NV,B1} = th(Value,B0,OB), 761 {[{{default},NV}|L],B1}; 762 (_,_) -> 763 throw({error,Line,{?ERR_HEADBADREC, 764 RName}}) 765 end, 766 {[],B}, 767 RFields), 768 DefValue = case lists:keysearch({default},1,KeyList0) of 769 {value,{{default},OverriddenDefValue}} -> 770 OverriddenDefValue; 771 _ -> 772 {atom,Line,'_'} 773 end, 774 KeyList = lists:keydelete({default},1,KeyList0), 775 case lists:keysearch({default},1,KeyList) of 776 {value,{{default},_}} -> 777 throw({error,Line,{?ERR_HEADMULTIFIELD,RName,'_'}}); 778 _ -> 779 ok 780 end, 781 case lists:keysearch(RName,1,RDefs) of 782 {value, {RName, FieldList0}} -> 783 FieldList1 = lists:foldl( 784 fun({FN,_,_},Acc) -> 785 El = case lists:keysearch(FN,1,KeyList) of 786 {value, {FN, X0}} -> 787 X0; 788 _ -> 789 DefValue 790 end, 791 [El | Acc] 792 end, 793 [], 794 FieldList0), 795 check_multi_field(RName,Line,KeyList, 796 ?ERR_HEADMULTIFIELD), 797 check_undef_field(RName,Line,KeyList,FieldList0, 798 ?ERR_HEADBADFIELD), 799 {{tuple,Line,[{atom,Line,RName}|FieldList1]},NewB}; 800 _ -> 801 throw({error,Line,{?ERR_HEADBADREC,RName}}) 802 end; 803th({match,Line,_,_},_,_) -> 804 throw({error,Line,?ERR_HEADMATCH}); 805th({atom,Line,A},B,_OB) -> 806 case atom_to_list(A) of 807 [$$|NL] -> 808 case (catch list_to_integer(NL)) of 809 N when is_integer(N) -> 810 throw({error,Line,{?ERR_HEADDOLLARATOM,A}}); 811 _ -> 812 {{atom,Line,A},B} 813 end; 814 _ -> 815 {{atom,Line,A},B} 816 end; 817th({bin_element,_Line0,{var, Line, A},_,_},_,_) -> 818 throw({error,Line,{?ERR_HEADBINMATCH,A}}); 819 820th({var,Line,Name},B,OB) -> 821 warn_var_clash(Line,Name,OB), 822 case lkup_bind(Name,B) of 823 undefined -> 824 NewB = new_bind(Name,B), 825 {{atom,Line,lkup_bind(Name,NewB)},NewB}; 826 Trans -> 827 {{atom,Line,Trans},B} 828 end; 829th([H|T],B,OB) -> 830 {NH,NB} = th(H,B,OB), 831 {NT,NNB} = th(T,NB,OB), 832 {[NH|NT],NNB}; 833th(T,B,OB) when is_tuple(T) -> 834 {L,NB} = th(tuple_to_list(T),B,OB), 835 {list_to_tuple(L),NB}; 836th(Nonstruct,B,_OB) -> 837 {Nonstruct,B}. 838 839warn_var_clash(Anno,Name,OuterBound) -> 840 case gb_sets:is_member(Name,OuterBound) of 841 true -> 842 Line = erl_anno:line(Anno), 843 add_warning(Line,{?WARN_SHADOW_VAR,Name}); 844 _ -> 845 ok 846 end. 847 848%% Could be more efficient... 849check_multi_field(_, _, [], _) -> 850 ok; 851check_multi_field(RName, Line, [{Key,_}|T], ErrCode) -> 852 case lists:keymember(Key,1,T) of 853 true -> 854 throw({error,Line,{ErrCode,RName,Key}}); 855 false -> 856 check_multi_field(RName, Line, T, ErrCode) 857 end. 858check_undef_field(_, _, [], _, _) -> 859 ok; 860check_undef_field(RName, Line, [{Key,_}|T], FieldList, ErrCode) -> 861 case lists:keymember(Key, 1, FieldList) of 862 true -> 863 check_undef_field(RName, Line, T, FieldList, ErrCode); 864 false -> 865 throw({error,Line,{ErrCode,RName,Key}}) 866 end. 867 868cre_bind() -> 869 {1,[{'_','_'}]}. 870 871lkup_bind(Name,{_,List}) -> 872 case lists:keysearch(Name,1,List) of 873 {value, {Name, Trans}} -> 874 Trans; 875 _ -> 876 undefined 877 end. 878 879new_bind({Name,Trans},{Next,L}) -> 880 {Next,[{Name,Trans}|L]}; 881new_bind(Name,{Next,L}) -> 882 Trans = list_to_atom([$$|integer_to_list(Next)]), 883 {Next+1,[{Name,Trans}|L]}. 884 885translate_language_element(Atom) -> 886 Transtab = [ 887 {lc,"list comprehension"}, 888 {bc,"binary comprehension"}, 889 {block, "begin/end block"}, 890 {'if', "if"}, 891 {'case', "case"}, 892 {'receive', "receive"}, 893 {'try', "try"}, 894 {'catch', "catch"}, 895 {'match', "match (=)"}, 896 {remote, "external function call"} 897 ], 898 case lists:keysearch(Atom,1,Transtab) of 899 {value,{Atom, String}} -> 900 String; 901 _ -> 902 atom_to_list(Atom) 903 end. 904 905old_bool_test(atom,1) -> is_atom; 906old_bool_test(float,1) -> is_float; 907old_bool_test(integer,1) -> is_integer; 908old_bool_test(list,1) -> is_list; 909old_bool_test(number,1) -> is_number; 910old_bool_test(pid,1) -> is_pid; 911old_bool_test(port,1) -> is_port; 912old_bool_test(reference,1) -> is_reference; 913old_bool_test(tuple,1) -> is_tuple; 914old_bool_test(binary,1) -> is_binary; 915old_bool_test(function,1) -> is_function; 916old_bool_test(record,2) -> is_record; 917old_bool_test(_,_) -> undefined. 918 919bool_test(is_atom,1) -> true; 920bool_test(is_float,1) -> true; 921bool_test(is_integer,1) -> true; 922bool_test(is_list,1) -> true; 923bool_test(is_number,1) -> true; 924bool_test(is_pid,1) -> true; 925bool_test(is_port,1) -> true; 926bool_test(is_reference,1) -> true; 927bool_test(is_tuple,1) -> true; 928bool_test(is_map,1) -> true; 929bool_test(is_map_key, 2) -> true; 930bool_test(is_binary,1) -> true; 931bool_test(is_function,1) -> true; 932bool_test(is_record,2) -> true; 933bool_test(is_seq_trace,0) -> true; 934bool_test(_,_) -> false. 935 936real_guard_function(abs,1) -> true; 937real_guard_function(element,2) -> true; 938real_guard_function(hd,1) -> true; 939real_guard_function(length,1) -> true; 940real_guard_function(node,0) -> true; 941real_guard_function(node,1) -> true; 942real_guard_function(round,1) -> true; 943real_guard_function(size,1) -> true; 944real_guard_function(bit_size,1) -> true; 945real_guard_function(map_size,1) -> true; 946real_guard_function(map_get,2) -> true; 947real_guard_function(tl,1) -> true; 948real_guard_function(trunc,1) -> true; 949real_guard_function(self,0) -> true; 950real_guard_function(float,1) -> true; 951real_guard_function(_,_) -> false. 952 953pseudo_guard_function(get_tcw,0) -> true; 954pseudo_guard_function(_,_) -> false. 955 956guard_function(X,A) -> 957 real_guard_function(X,A) or pseudo_guard_function(X,A). 958 959action_function(set_seq_token,2) -> true; 960action_function(get_seq_token,0) -> true; 961action_function(message,1) -> true; 962action_function(return_trace,0) -> true; 963action_function(exception_trace,0) -> true; 964action_function(process_dump,0) -> true; 965action_function(enable_trace,1) -> true; 966action_function(enable_trace,2) -> true; 967action_function(disable_trace,1) -> true; 968action_function(disable_trace,2) -> true; 969action_function(display,1) -> true; 970action_function(caller,0) -> true; 971action_function(set_tcw,1) -> true; 972action_function(silent,1) -> true; 973action_function(trace,2) -> true; 974action_function(trace,3) -> true; 975action_function(_,_) -> false. 976 977bool_operator('and',2) -> 978 true; 979bool_operator('or',2) -> 980 true; 981bool_operator('xor',2) -> 982 true; 983bool_operator('not',1) -> 984 true; 985bool_operator('andalso',2) -> 986 true; 987bool_operator('orelse',2) -> 988 true; 989bool_operator(_,_) -> 990 false. 991 992arith_operator('+',1) -> 993 true; 994arith_operator('+',2) -> 995 true; 996arith_operator('-',1) -> 997 true; 998arith_operator('-',2) -> 999 true; 1000arith_operator('*',2) -> 1001 true; 1002arith_operator('/',2) -> 1003 true; 1004arith_operator('div',2) -> 1005 true; 1006arith_operator('rem',2) -> 1007 true; 1008arith_operator('band',2) -> 1009 true; 1010arith_operator('bor',2) -> 1011 true; 1012arith_operator('bxor',2) -> 1013 true; 1014arith_operator('bnot',1) -> 1015 true; 1016arith_operator('bsl',2) -> 1017 true; 1018arith_operator('bsr',2) -> 1019 true; 1020arith_operator(_,_) -> 1021 false. 1022 1023cmp_operator('>',2) -> 1024 true; 1025cmp_operator('>=',2) -> 1026 true; 1027cmp_operator('<',2) -> 1028 true; 1029cmp_operator('=<',2) -> 1030 true; 1031cmp_operator('==',2) -> 1032 true; 1033cmp_operator('=:=',2) -> 1034 true; 1035cmp_operator('/=',2) -> 1036 true; 1037cmp_operator('=/=',2) -> 1038 true; 1039cmp_operator(_,_) -> 1040 false. 1041 1042is_operator(X,A,_) -> 1043 bool_operator(X,A) or arith_operator(X,A) or cmp_operator(X,A). 1044 1045is_imported_from_erlang(X,A,_) -> 1046 real_guard_function(X,A) or bool_test(X,A) or bool_operator(X,A) or 1047 arith_operator(X,A) or cmp_operator(X,A). 1048 1049is_ms_function(X,A,body) -> 1050 action_function(X,A) or guard_function(X,A) or bool_test(X,A); 1051 1052is_ms_function(X,A,guard) -> 1053 guard_function(X,A) or bool_test(X,A). 1054 1055fixup_environment(L,B) when is_list(L) -> 1056 lists:map(fun(X) -> 1057 fixup_environment(X,B) 1058 end, 1059 L); 1060fixup_environment({var,Line,Name},B) -> 1061 case lists:keysearch(Name,1,B) of 1062 {value,{Name,Value}} -> 1063 freeze(Line,Value); 1064 _ -> 1065 throw({error,Line,{?ERR_UNBOUND_VARIABLE,atom_to_list(Name)}}) 1066 end; 1067fixup_environment(T,B) when is_tuple(T) -> 1068 list_to_tuple( 1069 lists:map(fun(X) -> 1070 fixup_environment(X,B) 1071 end, 1072 tuple_to_list(T))); 1073fixup_environment(Other,_B) -> 1074 Other. 1075 1076freeze(Line,Term) -> 1077 {frozen,Line,Term}. 1078 1079%% Most of this is bluntly stolen from erl_parse. 1080 1081normalise({frozen,_,Term}) -> 1082 Term; 1083normalise({char,_,C}) -> C; 1084normalise({integer,_,I}) -> I; 1085normalise({float,_,F}) -> F; 1086normalise({atom,_,A}) -> A; 1087normalise({string,_,S}) -> S; 1088normalise({nil,_}) -> []; 1089normalise({bin,_,Fs}) -> 1090 {value, B, _} = 1091 eval_bits:expr_grp(Fs, [], 1092 fun(E, _) -> 1093 {value, normalise(E), []} 1094 end, [], true), 1095 B; 1096normalise({cons,_,Head,Tail}) -> 1097 [normalise(Head)|normalise(Tail)]; 1098normalise({op,_,'++',A,B}) -> 1099 normalise(A) ++ normalise(B); 1100normalise({tuple,_,Args}) -> 1101 list_to_tuple(normalise_list(Args)); 1102normalise({map,_,Pairs0}) -> 1103 Pairs1 = lists:map(fun ({map_field_exact,_,K,V}) -> 1104 {normalise(K),normalise(V)} 1105 end, 1106 Pairs0), 1107 maps:from_list(Pairs1); 1108%% Special case for unary +/-. 1109normalise({op,_,'+',{char,_,I}}) -> I; 1110normalise({op,_,'+',{integer,_,I}}) -> I; 1111normalise({op,_,'+',{float,_,F}}) -> F; 1112normalise({op,_,'-',{char,_,I}}) -> -I; % Weird, but compatible! 1113normalise({op,_,'-',{integer,_,I}}) -> -I; 1114normalise({op,_,'-',{float,_,F}}) -> -F. 1115 1116normalise_list([H|T]) -> 1117 [normalise(H)|normalise_list(T)]; 1118normalise_list([]) -> 1119 []. 1120