1%% Copyright (c) 2008-2016 Robert Virding 2%% 3%% Licensed under the Apache License, Version 2.0 (the "License"); 4%% you may not use this file except in compliance with the License. 5%% You may obtain a copy of the License at 6%% 7%% http://www.apache.org/licenses/LICENSE-2.0 8%% 9%% Unless required by applicable law or agreed to in writing, software 10%% distributed under the License is distributed on an "AS IS" BASIS, 11%% WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. 12%% See the License for the specific language governing permissions and 13%% limitations under the License. 14 15%% File : lfe_macro.erl 16%% Author : Robert Virding 17%% Purpose : Lisp Flavoured Erlang macro expander. 18 19%% Expand macros and record definitions (into macros), also handles 20%% quasiquote/backquote in an R6RS compatible way. 21 22-module(lfe_macro). 23 24%% -compile(export_all). 25 26%% These work on individual expressions. 27-export([expand_expr/2,expand_expr_1/2,expand_expr_all/2]). 28 29%% These work on list of forms in "file format". 30-export([expand_forms/4]). 31-export([expand_form_init/2,expand_form_init/3, 32 expand_form/4,expand_fileform/3]). 33 34%% For creating the macro expansion state. 35-export([default_state/2,default_state/3]). 36 37-export([format_error/1]). 38 39-export([mbe_syntax_rules_proc/4,mbe_syntax_rules_proc/5, 40 mbe_match_pat/3,mbe_get_bindings/3,mbe_expand_pattern/3]). 41 42%% -compile([export_all]). 43 44-import(lfe_env, [new/0,add_vbinding/3,is_vbound/2, 45 add_fbinding/4,is_fbound/3, 46 add_mbinding/3,is_mbound/2,get_mbinding/2]). 47 48-import(lists, [any/2,all/2,map/2,foldl/3,foldr/3,mapfoldl/3, 49 reverse/1,reverse/2,member/2,concat/1]). 50 51-include("lfe_comp.hrl"). 52-include("lfe_macro.hrl"). 53 54%% Define IS_MAP/1 macro for is_map/1 bif. 55-ifdef(HAS_MAPS). 56-define(IS_MAP(T), is_map(T)). 57-else. 58-define(IS_MAP(T), false). 59-endif. 60 61%% Errors 62format_error({bad_form,Type}) -> 63 lfe_io:format1("bad form: ~w", [Type]); 64format_error({bad_env_form,Type}) -> 65 lfe_io:format1("bad environment form: ~w", [Type]); 66format_error({expand_macro,Call,Error}) -> 67 %% Can be very big so only print limited depth. 68 lfe_io:format1("error expanding ~P: ~P", [Call,10,Error,10]). 69 70%% expand_expr(Form, Env) -> {yes,Exp} | no. 71%% expand_expr_1(Form, Env) -> {yes,Exp} | no. 72%% User functions for testing macro expansions, either one expansion 73%% or as far as it can go. 74 75expand_expr_1([Name|_]=Call, Env) when is_atom(Name) -> 76 St = default_state(false, false), 77 case exp_macro(Call, Env, St) of 78 {yes,Exp,_} -> {yes,Exp}; 79 no -> no 80 end; 81expand_expr_1(_, _) -> no. 82 83expand_expr([Name|_]=Call, Env) when is_atom(Name) -> 84 St0 = default_state(false, false), 85 case exp_macro(Call, Env, St0) of 86 {yes,Exp0,St1} -> 87 {Exp1,_} = expand_expr_loop(Exp0, Env, St1), 88 {yes,Exp1}; 89 no -> no 90 end; 91expand_expr(_, _) -> no. 92 93expand_expr_loop([Name|_]=Call, Env, St0) when is_atom(Name) -> 94 case exp_macro(Call, Env, St0) of 95 {yes,Exp,St1} -> expand_expr_loop(Exp, Env, St1); 96 no -> {Call,St0} 97 end; 98expand_expr_loop(E, _, St) -> {E,St}. 99 100%% expand_expr_all(From, Env) -> Exp. 101%% Expand all the macros in an expression. 102 103expand_expr_all(F, Env) -> 104 {Ef,_} = exp_form(F, Env, default_state(true, false)), 105 Ef. 106 107%% expand_forms(FileForms, Env, Deep, Keep) -> 108%% {ok,FileForms,Env,Warnings} | {error,Errors,Warnings}. 109%% Collect macro definitions in file forms, completely expand all 110%% macros and only keep all functions. 111 112expand_forms(Fs, Env, Deep, Keep) -> 113 St = default_state(Deep, Keep), 114 do_forms(Fs, Env, St). 115 116do_forms(Fs0, Env0, St0) -> 117 {Fs1,Env1,St1} = pass_fileforms(Fs0, Env0, St0), 118 case St1#mac.errors of 119 [] -> {ok,Fs1,Env1,St1#mac.warnings}; %No errors 120 Es -> {error,Es,St1#mac.warnings} 121 end. 122 123default_state(Deep, Keep) -> 124 #mac{deep=Deep,keep=Keep,line=1,file="-no-file-",opts=[],ipath=["."]}. 125 126default_state(#cinfo{file=File,opts=Os,ipath=Is}, Deep, Keep) -> 127 #mac{deep=Deep,keep=Keep,line=1,file=File,opts=Os,ipath=Is}. 128 129%% expand_form_init(Deep, Keep) -> State. 130%% expand_form_init(CompInfo, Deep, Keep) -> State. 131%% expand_form(Form, Line, Env, State) -> {Form,Env,State}. 132%% expand_fileform(Form, Env, State) -> {Form,Env,State}. 133%% Collect macro definitions in a (file)form, completely expand all 134%% macros and only keep all functions. 135 136expand_form_init(Deep, Keep) -> 137 default_state(Deep, Keep). 138 139expand_form_init(Ci, Deep, Keep) -> 140 default_state(Ci, Deep, Keep). 141 142expand_form(F0, L, E0, St0) -> 143 {F1,E1,St1} = pass_form(F0, E0, St0#mac{line=L}), 144 return_status(F1, E1, St1). 145 146expand_fileform({F0,L}, E0, St0) -> 147 {F1,E1,St1} = pass_form(F0, E0, St0#mac{line=L}), 148 return_status({F1,L}, E1, St1). 149 150return_status(Ret, Env, #mac{errors=[]}=St) -> 151 {ok,Ret,Env,St}; 152return_status(_, _, #mac{errors=Es,warnings=Ws}=St) -> 153 {error,Es,Ws,St}. 154 155%% pass_fileforms(FileForms, Env, State) -> {FileForms,Env,State}. 156%% pass_forms(Forms, Env, State) -> {Forms,Env,State}. 157%% Pass over a list of fileforms/forms collecting and removing all macro 158%% defintions. All forms must be expanded at top-level to check form, 159%% but all can be expanded to full depth. Nesting of forms by progn 160%% is preserved. 161 162pass_fileforms(Ffs, Env, St) -> 163 mapfoldl2(fun ({F0,L}, E0, S0) -> 164 {F1,E1,S1} = pass_form(F0, E0, S0#mac{line=L}), 165 {{F1,L},E1,S1} 166 end, Env, St, Ffs). 167 168pass_forms(Fs, Env, St) -> 169 mapfoldl2(fun (F0, E0, S0) -> pass_form(F0, E0, S0) end, Env, St, Fs). 170 171%% pass_form(Form, Env, State) -> {Form,Env,State}. 172%% Do a form collecting and removing all macro defintions. The form 173%% must be expanded at top-level to check it, but it can be expanded 174%% to full depth. Nesting of forms by progn is preserved. 175 176pass_form(['progn'|Pfs0], Env0, St0) -> 177 {Pfs1,Env1,St1} = pass_forms(Pfs0, Env0, St0), 178 {['progn'|Pfs1],Env1,St1}; 179pass_form(['eval-when-compile'|Efs0], Env0, St0) -> 180 {Efs1,Env1,St1} = pass_ewc(Efs0, Env0, St0), 181 {['eval-when-compile'|Efs1],Env1,St1}; 182pass_form(['define-macro'|Def]=M, Env0, St0) -> 183 case pass_define_macro(Def, Env0, St0) of 184 {yes,Env1,St1} -> 185 Ret = ?IF(St1#mac.keep, M, [progn]), 186 {Ret,Env1,St1}; %Must return a valid form 187 no -> 188 St1 = add_error({bad_form,macro}, St0), 189 {['progn'],Env0,St1} %Must return a valid form 190 end; 191pass_form(F, Env, St0) -> 192 %% First expand enough to test top form, if so process again. 193 case pass_expand_expr(F, Env, St0, St0#mac.deep) of 194 {yes,Exp,St1} -> %Top form expanded 195 pass_form(Exp, Env, St1); 196 {no,F1,St1} -> %Expanded all if flag set 197 {F1,Env,St1} 198 end. 199 200%% pass_ewc(Forms, Env, State) -> {Env,State}. 201%% Pass over the list of forms which evaluate at compile 202%% time. Function and macro definitions are collected in the 203%% environment and other experssions are evaluated. The shell set 204%% forms are also specially recognised and the variables are bound 205%% and kept in the environment as well. The functions and macrso 206%% behave as in the shell. 207 208pass_ewc(Fs, Env, St) -> 209 mapfoldl2(fun (F, E, S) -> pass_ewc_form(F, E, S) end, Env, St, Fs). 210 211pass_ewc_form(['progn'|Pfs0], Env0, St0) -> 212 {Pfs1,Env1,St1} = pass_ewc(Pfs0, Env0, St0), 213 {['progn'|Pfs1],Env1,St1}; 214pass_ewc_form(['eval-when-compile'|Efs0], Env0, St0) -> 215 {Efs1,Env1,St1} = pass_ewc(Efs0, Env0, St0), 216 {['progn'|Efs1],Env1,St1}; 217pass_ewc_form(['define-macro'|Def]=M, Env0, St0) -> 218 %% Do we really want this? It behaves as a top-level macro def. 219 case pass_define_macro(Def, Env0, St0) of 220 {yes,Env1,St1} -> 221 Ret = ?IF(St1#mac.keep, M, [progn]), 222 {Ret,Env1,St1}; %Don't macro expand now 223 no -> 224 St1 = add_error({bad_env_form,macro}, St0), 225 {[progn],Env0,St1} %Just throw it away 226 end; 227pass_ewc_form(['define-function',Name,_,Def]=F, Env0, St0) -> 228 case function_arity(Def) of 229 {yes,Ar} -> %Definition not too bad 230 Env1 = lfe_eval:add_dynamic_func(Name, Ar, Def, Env0), 231 Ret = ?IF(St0#mac.keep, F, [progn]), 232 {Ret,Env1,St0}; %Don't macro expand now 233 no -> %Definition really bad 234 St1 = add_error({bad_env_form,function}, St0), 235 {[progn],Env0,St1} %Just throw it away 236 end; 237pass_ewc_form([set|Args], Env, St) -> 238 pass_eval_set(Args, Env, St); 239pass_ewc_form(F0, Env, St0) -> 240 %% First expand enough to test top form, if so process again. 241 case pass_expand_expr(F0, Env, St0, false) of 242 {yes,F1,St1} -> %Top form expanded 243 pass_ewc_form(F1, Env, St1); 244 {no,F1,St1} -> %Not expanded 245 try 246 lfe_eval:expr(F1, Env), 247 {['progn'],Env,St1} %Ignore the value 248 catch 249 _:_ -> 250 {['progn'],Env,add_error({bad_env_form,expression}, St1)} 251 end 252 end. 253 254function_arity([lambda,Args|_]) -> 255 ?IF(lfe_lib:is_symb_list(Args), {yes,length(Args)}, no); 256function_arity(['match-lambda',[Pat|_]|_]) -> 257 ?IF(lfe_lib:is_proper_list(Pat), {yes,length(Pat)}, no); 258function_arity(_) -> no. 259 260%% pass_eval_set(Args, Env, State) -> {Set,Env,State}. 261%% Evaluate the set form. 262 263pass_eval_set(Args, Env, St) -> 264 try 265 pass_eval_set_1(Args, Env, St) 266 catch 267 _:_ -> %Catch everything 268 {[progn],Env,add_error({bad_env_form,'set'}, St)} 269 end. 270 271pass_eval_set_1(Args, Env, St0) -> 272 case exp_form(['let'|Args], Env, St0) of 273 {['let',Pat,G,Exp],St1} -> 274 pass_eval_set_1(Pat, [G], Exp, Env, St1); 275 {['let',Pat,Exp],St1} -> 276 pass_eval_set_1(Pat, [], Exp, Env, St1) 277 end. %Just crash here 278 279pass_eval_set_1(Pat, Guard, Exp, Env0, St) -> 280 Val = lfe_eval:expr(Exp, Env0), 281 {yes,_,Bs} = lfe_eval:match_when(Pat, Val, Guard, Env0), 282 Env1 = foldl(fun ({N,V}, E) -> add_vbinding(N, V, E) end, Env0, Bs), 283 Sets = ?IF(St#mac.keep, [ [set,N,V] || {N,V} <- Bs ], []), 284 {['progn'|Sets],Env1,St}. 285 286%% pass_expand_expr(Expr, Env, State, DeepFlag) -> 287%% {yes,Exp,State} | {no,State}. 288%% Try to macro expand Expr, catch errors and return them in State. 289%% Only try to expand list expressions. 290 291pass_expand_expr([_|_]=E0, Env, St0, Deep) -> 292 try 293 case exp_macro(E0, Env, St0) of 294 {yes,_,_}=Yes -> Yes; 295 no when Deep -> %Deep expand if flag set. 296 {E1,St1} = exp_form(E0, Env, St0), 297 {no,E1,St1}; 298 no -> {no,E0,St0} 299 end 300 catch 301 _:Error -> {no,E0,add_error(Error, St0)} 302 end; 303pass_expand_expr(E, _, St, _) -> {no,E,St}. 304 305%% pass_define_macro([Name,Meta,Def], Env, State) -> 306%% {yes,Env,State} | no. 307%% Add the macro definition to the environment. We do a small format 308%% check. 309 310pass_define_macro([Name,_,Def], Env, St) -> 311 case Def of 312 ['lambda'|_] -> {yes,add_mbinding(Name, Def, Env),St}; 313 ['match-lambda'|_] -> {yes,add_mbinding(Name, Def, Env),St}; 314 _ -> no 315 end. 316 317%% add_error(Error, State) -> State. 318%% add_error(Line, Error, State) -> State. 319%% add_warning(Warning, State) -> State. 320%% add_warning(Line, Warning, State) -> State. 321 322add_error(E, St) -> add_error(St#mac.line, E, St). 323 324add_error(L, E, St) -> 325 St#mac{errors=St#mac.errors ++ [{L,?MODULE,E}]}. 326 327%% add_warning(W, St) -> add_warning(St#mac.line, W, St). 328%% add_warning(L, W, St) -> 329%% St#mac{warnings=St#mac.warnings ++ [{L,?MODULE,W}]}. 330 331%% exp_form(Form, Env, State) -> {Form,State}. 332%% Completely expand a form using expansions in Env and pre-defined 333%% macros. N.B. builtin core forms cannot be overidden and are 334%% handled here first. Some core forms also are particular about how 335%% their bodies are to be expanded and we handle these specially 336%% here. The rest we just expand the tail at the end. 337 338%% Known Core forms which need special handling. 339exp_form([quote,_]=Q, _, St) -> {Q,St}; 340exp_form([cons,H0,T0], Env, St0) -> 341 {H1,St1} = exp_form(H0, Env, St0), 342 {T1,St2} = exp_form(T0, Env, St1), 343 {[cons,H1,T1],St2}; 344exp_form([car,E0], Env, St0) -> %Catch these to prevent 345 {E1,St1} = exp_form(E0, Env, St0), %redefining them 346 {[car,E1],St1}; 347exp_form([cdr,E0], Env, St0) -> 348 {E1,St1} = exp_form(E0, Env, St0), 349 {[cdr,E1],St1}; 350exp_form([list|As], Env, St) -> 351 exp_normal_core(list, As, Env, St); 352exp_form([tuple|As], Env, St) -> 353 exp_normal_core(tuple, As, Env, St); 354exp_form([tref|[_,_]=As], Env, St) -> 355 exp_normal_core(tref, As, Env, St); 356exp_form([tset|[_,_,_]=As], Env, St) -> 357 exp_normal_core(tset, As, Env, St); 358exp_form([binary|As], Env, St) -> 359 exp_normal_core(binary, As, Env, St); 360exp_form([map|As], Env, St) -> 361 exp_normal_core(map, As, Env, St); 362exp_form([mref|As], Env, St) -> 363 exp_normal_core(mref, As, Env, St); 364exp_form([mset|As], Env, St) -> 365 exp_normal_core(mset, As, Env, St); 366exp_form([mupd|As], Env, St) -> 367 exp_normal_core(mupd, As, Env, St); 368exp_form(['map-get'|As], Env, St) -> 369 exp_normal_core('map-get', As, Env, St); 370exp_form(['map-set'|As], Env, St) -> 371 exp_normal_core('map-set', As, Env, St); 372exp_form(['map-update'|As], Env, St) -> 373 exp_normal_core('map-update', As, Env, St); 374exp_form([function|_]=F, _, St) -> {F,St}; 375%% Core closure special forms. 376exp_form([lambda,Head|B], Env, St) -> 377 exp_head_tail(lambda, Head, B, Env, St); 378exp_form(['match-lambda'|B0], Env, St0) -> 379 {B1,St1} = exp_ml_clauses(B0, Env, St0), 380 {['match-lambda'|B1],St1}; 381exp_form(['let',Vbs|B], Env, St) -> 382 exp_let(Vbs, B, Env, St); 383exp_form(['let-function',Fbs|B], Env, St) -> 384 exp_let_function(Fbs, B, Env, St); 385exp_form(['letrec-function',Fbs|B], Env, St) -> 386 exp_letrec_function(Fbs, B, Env, St); 387exp_form(['let-macro',Mbs|B], Env, St) -> 388 exp_let_macro(Mbs, B, Env, St); 389%% Core control special forms. 390exp_form([progn|As], Env, St) -> 391 exp_normal_core(progn, As, Env, St); 392exp_form(['if'|As], Env, St) -> 393 exp_normal_core('if', As, Env, St); 394exp_form(['case',E0|Cls0], Env, St0) -> 395 {E1,St1} = exp_form(E0, Env, St0), 396 {Cls1,St2} = exp_clauses(Cls0, Env, St1), 397 {['case',E1|Cls1],St2}; 398exp_form(['receive'|Cls0], Env, St0) -> 399 {Cls1,St1} = exp_clauses(Cls0, Env, St0), 400 {['receive'|Cls1],St1}; 401exp_form(['catch'|B0], Env, St0) -> 402 {B1,St1} = exp_tail(B0, Env, St0), 403 {['catch'|B1],St1}; 404exp_form(['try',E|B], Env, St) -> 405 exp_try(E, B, Env, St); 406exp_form([funcall|As], Env, St) -> 407 exp_normal_core(funcall, As, Env, St); 408exp_form([call|As], Env, St) -> 409 exp_normal_core(call, As, Env, St); 410%% Core definition special forms. 411exp_form(['eval-when-compile'|B], Env, St) -> 412 exp_normal_core('eval-when-compile', B, Env, St); 413exp_form(['define-function',Head|B], Env, St) -> 414 exp_head_tail('define-function', Head, B, Env, St); 415exp_form(['define-macro',Head|B], Env, St) -> 416 exp_head_tail('define-macro', Head, B, Env, St); 417%% These don't expand at all as name clashes are allowed. 418exp_form(['define-module',_Mod|_]=Form, _, St) -> {Form,St}; 419exp_form(['extend-module'|_]=Form, _, St) -> {Form,St}; 420exp_form(['define-type',_Type|_]=Form, _, St) -> {Form,St}; 421exp_form(['define-opaque-type',_Type|_]=Form, _, St) -> {Form,St}; 422exp_form(['define-function-spec',_Func|_]=Form, _, St) -> {Form,St}; 423%% And don't forget when. 424exp_form(['when'|G], Env, St) -> 425 exp_normal_core('when', G, Env, St); 426%% Now the case where we can have macros. 427exp_form([Fun|_]=Call, Env, St0) when is_atom(Fun) -> 428 %% Expand top macro as much as possible. 429 case exp_macro(Call, Env, St0) of 430 {yes,Exp,St1} -> exp_form(Exp, Env, St1); 431 no -> exp_tail(Call, Env, St0) 432 end; 433exp_form([_|_]=Form, Env, St) -> exp_tail(Form, Env, St); 434exp_form(Tup, _, St) when is_tuple(Tup) -> 435 %% Should we expand this? We assume implicit quote here. 436 {Tup,St}; 437%% Everything else is atomic. 438exp_form(F, _, St) -> {F,St}. %Atomic 439 440exp_normal_core(Name, As0, Env, St0) -> 441 {As1,St1} = exp_tail(As0, Env, St0), 442 {[Name|As1],St1}. 443 444exp_head_tail(Name, Head, B0, Env, St0) -> 445 {B1,St1} = exp_tail(B0, Env, St0), 446 {[Name,Head|B1],St1}. 447 448%% exp_list(Exprs, Env, State) -> {Exps,State}. 449%% Expand a proper list of exprs. 450 451exp_list(Es, Env, St) -> 452 mapfoldl(fun (E, S) -> exp_form(E, Env, S) end, St, Es). 453 454%% exp_tail(Tail, Env, State) -> {Etail,State}. 455%% exp_tail(ExpFun, Tail, Env, State) -> {Etail,State}. 456%% Expand the tail of a list, need not be a proper list. 457 458exp_tail(Tail, Env, St) -> 459 exp_tail(fun exp_form/3, Tail, Env, St). 460 461exp_tail(Fun, [E0|Es0], Env, St0) -> 462 {E1,St1} = Fun(E0, Env, St0), 463 {Es1,St2} = exp_tail(Fun, Es0, Env, St1), 464 {[E1|Es1],St2}; 465exp_tail(_, [], _, St) -> {[],St}; 466exp_tail(Fun, E, Env, St) -> Fun(E, Env, St). %Same on improper tail. 467 468%% exp_clauses(Clauses, Env, State) -> {ExpCls,State}. 469%% exp_ml_clauses(Clauses, Env, State) -> {ExpCls,State}. 470%% Expand macros in clause patterns, guards and body. Must handle 471%% match-lambda clauses differently as pattern is an explicit list of 472%% patterns *NOT* a pattern which is a list. This will affect what is 473%% detected a macro call. 474 475exp_clauses(Cls, Env, St) -> 476 exp_tail(fun exp_clause/3, Cls, Env, St). 477 478exp_clause([P0,['when'|G0]|B0], Env, St0) -> 479 {P1,St1} = exp_form(P0, Env, St0), 480 {G1,St2} = exp_tail(G0, Env, St1), 481 {B1,St3} = exp_tail(B0, Env, St2), 482 {[P1,['when'|G1]|B1],St3}; 483exp_clause([P0|B0], Env, St0) -> 484 {P1,St1} = exp_form(P0, Env, St0), 485 {B1,St2} = exp_tail(B0, Env, St1), 486 {[P1|B1],St2}; 487exp_clause(Other, Env, St) -> exp_form(Other, Env, St). 488 489exp_ml_clauses(Cls, Env, St) -> 490 exp_tail(fun exp_ml_clause/3, Cls, Env, St). 491 492exp_ml_clause([Ps0,['when'|G0]|B0], Env, St0) -> 493 {Ps1,St1} = exp_tail(Ps0, Env, St0), 494 {G1,St2} = exp_tail(G0, Env, St1), 495 {B1,St3} = exp_tail(B0, Env, St2), 496 {[Ps1,['when'|G1]|B1],St3}; 497exp_ml_clause([Ps0|B0], Env, St0) -> 498 {Ps1,St1} = exp_tail(Ps0, Env, St0), 499 {B1,St2} = exp_tail(B0, Env, St1), 500 {[Ps1|B1],St2}; 501exp_ml_clause(Other, Env, St) -> exp_form(Other, Env, St). 502 503%% exp_let(VarBindings, Body, Env, State) -> {Expansion,State}. 504%% We only do limited syntax checking here. 505 506exp_let(Vbs0, B0, Env, St0) -> 507 {Vbs1,St1} = exp_clauses(Vbs0, Env, St0), 508 {B1,St2} = exp_tail(B0, Env, St1), 509 {['let',Vbs1|B1],St2}. 510 511%% exp_let_function(FuncBindings, Body, Env, State) -> {Expansion,State}. 512%% exp_letrec_function(FuncBindings, Body, Env, State) -> {Expansion,State}. 513%% Expand a let/letrec-function. We do add them to the environment as 514%% they might be used when expanding macros. 515 516exp_let_function(Fbs0, B0, Env, St0) -> 517 {Fbs1,B1,St1} = do_exp_let_function('let-function', Fbs0, B0, Env, St0), 518 {['let-function',Fbs1|B1],St1}. 519 520exp_letrec_function(Fbs0, B0, Env, St0) -> 521 {Fbs1,B1,St1} = do_exp_let_function('letrec-function', Fbs0, B0, Env, St0), 522 {['letrec-function',Fbs1|B1],St1}. 523 524do_exp_let_function(Type, Fbs0, B0, Env0, St0) -> 525 %% Only very limited syntax checking here (see above). 526 Efun = fun ([V,Def], {Env,St}) when is_atom(V) -> 527 case function_arity(Def) of 528 {yes,Ar} -> 529 {lfe_eval:add_dynamic_func(V, Ar, Def, Env),St}; 530 no -> 531 {Env,add_error(St#mac.line, {bad_form,Type}, St)} 532 end; 533 (_, {Env,St}) -> 534 {Env,add_error(St#mac.line, {bad_form,Type}, St)} 535 end, 536 {Env1,St1} = foldl(Efun, {Env0,St0}, Fbs0), 537 {Fbs1,St2} = exp_clauses(Fbs0, Env1, St1), 538 {B1,St3} = exp_tail(B0, Env1, St2), 539 {Fbs1,B1,St3}. 540 541%% exp_let_macro(MacroBindings, Body, Env, State) -> {Expansion,State}. 542%% Expand a let_syntax. We add the actual macro binding to the env as 543%% we may need them while expanding the body. 544 545exp_let_macro(Mbs, B0, Env0, St0) -> 546 %% Add the macro defs from expansion and return body in a progn. 547 Env1 = foldl(fun ([Name,['lambda'|_]=Def], Env) when is_atom(Name) -> 548 add_mbinding(Name, Def, Env); 549 ([Name,['match-lambda'|_]=Def], Env) when is_atom(Name) -> 550 add_mbinding(Name, Def, Env); 551 (_, Env) -> Env %Ignore mistakes 552 end, Env0, Mbs), 553 {B1,St1} = exp_tail(B0, Env1, St0), %Expand the body 554 {['progn'|B1],St1}. 555 556exp_try(E0, B0, Env, St0) -> 557 {E1,St1} = exp_form(E0, Env, St0), 558 {B1,St2} = exp_tail(fun (['case'|Cls0], E, Sta) -> 559 {Cls1,Stb} = exp_clauses(Cls0, E, Sta), 560 {['case'|Cls1],Stb}; 561 (['catch'|Cls0], E, Sta) -> 562 {Cls1,Stb} = exp_clauses(Cls0, E, Sta), 563 {['catch'|Cls1],Stb}; 564 (['after'|A0], E, Sta) -> 565 {A1,Stb} = exp_tail(A0, E, Sta), 566 {['after'|A1],Stb}; 567 (Other, _, St) -> {Other,St} 568 end, B0, Env, St1), 569 {['try',E1|B1],St2}. 570 571%% exp_macro(Call, Env, State) -> {yes,Exp,State} | no. 572%% Expand the macro in top call, but not if it is a core form. 573 574exp_macro([Name|_]=Call, Env, St) -> 575 case lfe_internal:is_core_form(Name) of 576 true -> no; %Never expand core forms 577 false -> 578 case get_mbinding(Name, Env) of 579 {yes,Def} -> 580 %% User macro bindings. 581 exp_userdef_macro(Call, Def, Env, St); 582 no -> 583 %% Default macro bindings. 584 exp_predef_macro(Call, Env, St) 585 end 586 end. 587 588%% exp_userdef_macro(Call, Def, Env, State) -> {yes,Exp,State}. 589%% Evaluate the macro definition by applying it to the call args. The 590%% definition is either a lambda or match-lambda, expand it and apply 591%% it to argument list. 592 593exp_userdef_macro([Mac|Args], Def0, Env, St0) -> 594 %%lfe_io:format("udef: ~p\n", [[Mac|Args]]), 595 %%lfe_io:format("macro: ~p\n", [Def0]), 596 try 597 {Def1,St1} = exp_form(Def0, Env, St0), %Expand definition 598 Exp = lfe_eval:apply(Def1, [Args,Env], Env), 599 {yes,Exp,St1} 600 catch 601 %% error:no_Error -> boom 602 %% error:Error -> 603 %% Stack = erlang:get_stacktrace(), 604 %% erlang:error({expand_macro,[Mac|Args],{Error,Stack}}) 605 error:Error -> 606 Stack = erlang:get_stacktrace(), 607 erlang:raise(error, {expand_macro,[Mac|Args],Error}, Stack) 608 %% error:Error -> 609 %% Stack0 = erlang:get_stacktrace(), 610 %% Stack1 = trim_stacktrace(Stack0), 611 %% erlang:error({expand_macro,[Mac|Args],{Error,Stack1}}) 612 end. 613 614%% exp_predef_macro(Call, Env, State) -> {yes,Exp,State} | no. 615%% Evaluate predefined macro definition catching errors. 616 617exp_predef_macro(Call, Env, St) -> 618 %%lfe_io:format("pdef: ~p\n", [Call]), 619 try 620 exp_predef(Call, Env, St) 621 catch 622 %% error:Error -> 623 %% Stack = erlang:get_stacktrace(), 624 %% erlang:raise({expand_macro,Call,{Error,Stack}}) 625 error:Error -> 626 Stack = erlang:get_stacktrace(), 627 erlang:raise(error, {expand_macro,Call,Error}, Stack) 628 %% error:Error -> 629 %% Stack0 = erlang:get_stacktrace(), 630 %% Stack1 = trim_stacktrace(Stack0), 631 %% erlang:error({expand_macro,Call,{Error,Stack1}}) 632 end. 633 634%% trim_stacktrace([{lfe_macro,_,_,_}=S|_]) -> [S]; %R15 and later 635%% trim_stacktrace([{lfe_macro,_,_}|_]=S) -> [S]; %Pre R15 636%% trim_stacktrace([S|Stk]) -> [S|trim_stacktrace(Stk)]; 637%% trim_stacktrace([]) -> []. 638 639%% exp_predef(Form, Env, State) -> {yes,Form,State} | no. 640%% Expand the built-in predefined macros completely at top-level 641%% without returning a new predefined top-level macro. This make the 642%% macros "safe" even if they have been redefined as it is this 643%% definition which is used. 644 645%% Builtin default macro expansions. 646exp_predef([caar,E], _, St) -> {yes,[car,[car,E]],St}; 647exp_predef([cadr,E], _, St) -> {yes,[car,[cdr,E]],St}; 648exp_predef([cdar,E], _, St) -> {yes,[cdr,[car,E]],St}; 649exp_predef([cddr,E], _, St) -> {yes,[cdr,[cdr,E]],St}; 650%% More c*r macros, a la CL HyperSpec. 651exp_predef([caaar,E], _, St) -> {yes,[car,[car,[car,E]]],St}; 652exp_predef([caadr,E], _, St) -> {yes,[car,[car,[cdr,E]]],St}; 653exp_predef([cadar,E], _, St) -> {yes,[car,[cdr,[car,E]]],St}; 654exp_predef([caddr,E], _, St) -> {yes,[car,[cdr,[cdr,E]]],St}; 655exp_predef([cdaar,E], _, St) -> {yes,[cdr,[car,[car,E]]],St}; 656exp_predef([cdadr,E], _, St) -> {yes,[cdr,[car,[cdr,E]]],St}; 657exp_predef([cddar,E], _, St) -> {yes,[cdr,[cdr,[car,E]]],St}; 658exp_predef([cdddr,E], _, St) -> {yes,[cdr,[cdr,[cdr,E]]],St}; 659%% Six-letter c*r macros from the CL HyperSpec. 660exp_predef([caaaar,E], _, St) -> {yes,[car,[car,[car,[car,E]]]],St}; 661exp_predef([caaadr,E], _, St) -> {yes,[car,[car,[car,[cdr,E]]]],St}; 662exp_predef([caadar,E], _, St) -> {yes,[car,[car,[cdr,[car,E]]]],St}; 663exp_predef([caaddr,E], _, St) -> {yes,[car,[car,[cdr,[cdr,E]]]],St}; 664exp_predef([cadaar,E], _, St) -> {yes,[car,[cdr,[car,[car,E]]]],St}; 665exp_predef([cadadr,E], _, St) -> {yes,[car,[cdr,[car,[cdr,E]]]],St}; 666exp_predef([caddar,E], _, St) -> {yes,[car,[cdr,[cdr,[car,E]]]],St}; 667exp_predef([cadddr,E], _, St) -> {yes,[car,[cdr,[cdr,[cdr,E]]]],St}; 668exp_predef([cdaaar,E], _, St) -> {yes,[cdr,[car,[car,[car,E]]]],St}; 669exp_predef([cdaadr,E], _, St) -> {yes,[cdr,[car,[car,[cdr,E]]]],St}; 670exp_predef([cdadar,E], _, St) -> {yes,[cdr,[car,[cdr,[car,E]]]],St}; 671exp_predef([cdaddr,E], _, St) -> {yes,[cdr,[car,[cdr,[cdr,E]]]],St}; 672exp_predef([cddaar,E], _, St) -> {yes,[cdr,[cdr,[car,[car,E]]]],St}; 673exp_predef([cddadr,E], _, St) -> {yes,[cdr,[cdr,[car,[cdr,E]]]],St}; 674exp_predef([cdddar,E], _, St) -> {yes,[cdr,[cdr,[cdr,[car,E]]]],St}; 675exp_predef([cddddr,E], _, St) -> {yes,[cdr,[cdr,[cdr,[cdr,E]]]],St}; 676 677%% Arithmetic operations and comparison operations. 678%% Be careful to make these behave as if they were a function and 679%% strictly evalated all their arguments. 680exp_predef(['+'|Es], _, St0) -> 681 case Es of 682 [] -> {yes,0,St0}; %Identity 683 _ -> 684 {Exp,St1} = exp_arith(Es, '+', St0), 685 {yes,Exp,St1} 686 end; 687exp_predef(['-'|Es], _, St0) -> 688 case Es of 689 [_|_] -> %Non-empty argument list 690 {Exp,St1} = exp_arith(Es, '-', St0), 691 {yes,Exp,St1} 692 end; 693exp_predef(['*'|Es], _, St0) -> 694 case Es of 695 [] -> {yes,1,St0}; %Identity 696 [_] -> {yes,exp_bif('*', [1|Es]),St0}; %Check if number 697 _ -> 698 {Exp,St1} = exp_arith(Es, '*', St0), 699 {yes,Exp,St1} 700 end; 701exp_predef(['/'|Es], _, St0) -> 702 case Es of 703 [_] -> {yes,exp_bif('/', [1|Es]),St0}; %According to definition 704 _ -> 705 {Exp,St1} = exp_arith(Es, '/', St0), 706 {yes,Exp,St1} 707 end; 708%% Logical operators. 709exp_predef([Op|Es], _, St0) 710 when Op =:= 'and'; Op =:= 'or'; Op =:= 'xor' -> 711 {Exp,St1} = exp_logical(Es, Op, St0), 712 {yes,Exp,St1}; 713%% Comparison operators. 714exp_predef(['!='|Es], Env, St) -> exp_predef(['/='|Es], Env, St); 715exp_predef(['==='|Es], Env, St) -> exp_predef(['=:='|Es], Env, St); 716exp_predef(['!=='|Es], Env, St) -> exp_predef(['=/='|Es], Env, St); 717exp_predef([Op|Es], _, St0) when Op == '/=' ; Op == '=/=' -> 718 {Exp,St1} = exp_nequal(Es, Op, St0), 719 {yes,Exp,St1}; 720exp_predef([Op|Es], _, St0) 721 when Op =:= '>'; Op =:= '>='; Op =:= '<'; Op =:= '=<'; 722 Op =:= '=='; Op =:= '=:=' -> 723 case Es of 724 [_|_] -> 725 {Exp,St1} = exp_comp(Es, Op, St0), 726 {yes,Exp,St1} 727 end; 728exp_predef([backquote,Bq], _, St) -> %We do this here. 729 {yes,exp_backquote(Bq),St}; 730exp_predef(['++'|Abody], _, St) -> 731 Exp = exp_append(Abody), 732 {yes,Exp,St}; 733exp_predef(['++*'|Abody], _, St) -> 734 Exp = exp_prefix(Abody), 735 {yes,Exp,St}; 736exp_predef(['?'|As], _, St) -> 737 Omega = [omega,omega], 738 Exp = case As of 739 [To,Def] -> ['receive',Omega,['after',To,Def]]; 740 [To] -> ['receive',Omega,['after',To,[exit,?Q(timeout)]]]; 741 [] -> ['receive',Omega] 742 end, 743 {yes,Exp, St}; 744exp_predef(['list*'|As], _, St) -> 745 Exp = exp_list_star(As), 746 {yes,Exp,St}; 747exp_predef(['let*'|Lbody], _, St) -> 748 Exp = exp_let_star(Lbody), 749 {yes,Exp,St}; 750exp_predef(['flet*'|Lbody], _, St) -> 751 Exp = exp_flet_star(Lbody), 752 {yes,Exp,St}; 753exp_predef(['cond'|Cbody], _, St) -> 754 Exp = exp_cond(Cbody), 755 {yes,Exp,St}; 756exp_predef(['do'|Dbody], _, St0) -> 757 {Exp,St1} = exp_do(Dbody, St0), 758 {yes,Exp,St1}; 759exp_predef([lc|Lbody], _, St0) -> 760 %% (lc (qual ...) e ...) 761 [Qs|Es] = Lbody, 762 {Exp,St1} = lc_te(Es, Qs, St0), 763 {yes,Exp,St1}; 764%% Add an alias for lc. 765exp_predef(['list-comp'|Lbody], _, St0) -> 766 [Qs|Es] = Lbody, 767 {Exp,St1} = lc_te(Es, Qs, St0), 768 {yes,Exp,St1}; 769exp_predef([bc|Bbody], _, St0) -> 770 %% (bc (qual ...) e ...) 771 [Qs|Es] = Bbody, 772 {Exp,St1} = bc_te(Es, Qs, St0), 773 {yes,Exp,St1}; 774%% Add an alias for bc. 775exp_predef(['binary-comp'|Bbody], _, St0) -> 776 [Qs|Es] = Bbody, 777 {Exp,St1} = bc_te(Es, Qs, St0), 778 {yes,Exp,St1}; 779exp_predef(['andalso'|Abody], _, St) -> 780 Exp = exp_andalso(Abody), 781 {yes,Exp,St}; 782exp_predef(['orelse'|Obody], _, St) -> 783 Exp = exp_orelse(Obody), 784 {yes,Exp,St}; 785%% The fun forms assume M, F and Ar are atoms and integer. We leave 786%% them as before for backwards compatibility. 787exp_predef(['fun',F,Ar], _, St0) -> 788 {Vs,St1} = new_symbs(Ar, St0), 789 {yes,['lambda',Vs,[F|Vs]],St1}; 790exp_predef(['fun',M,F,Ar], _, St0) -> 791 {Vs,St1} = new_symbs(Ar, St0), 792 {yes,['lambda',Vs,['call',?Q(M),?Q(F)|Vs]],St1}; 793exp_predef(['defrecord'|Def], Env, St) -> 794 lfe_macro_record:define(Def, Env, St); 795%% Include-XXX as macros for now. Move to top-level forms? 796exp_predef(['include-file'|Ibody], Env, St) -> 797 lfe_macro_include:file(Ibody, Env, St); 798exp_predef(['include-lib'|Ibody], Env, St) -> 799 lfe_macro_include:lib(Ibody, Env, St); 800%% Compatibility macros for the older Scheme like syntax. 801exp_predef(['begin'|Body], _, St) -> 802 {yes,['progn'|Body],St}; 803exp_predef(['define',Head|Body], _, St) -> 804 %% Let the lint catch errors here. 805 Exp = case lfe_lib:is_symb_list(Head) of 806 true -> 807 ['define-function',hd(Head),[],[lambda,tl(Head)|Body]]; 808 false -> 809 ['define-function',Head,[],Body] 810 end, 811 {yes,Exp,St}; 812exp_predef(['define-record'|Def], _, St) -> 813 {yes,[defrecord|Def],St}; 814exp_predef(['define-syntax',Name,Def], _, St) -> 815 {Meta,Mdef} = exp_syntax(Name, Def), 816 {yes,['define-macro',Name,Meta,Mdef],St}; 817exp_predef(['let-syntax',Defs|Body], _, St) -> 818 Fun = fun ([Name,Def]) -> 819 {_,Def} = exp_syntax(Name, Def), 820 [Name,Def] 821 end, 822 Mdefs = map(Fun, Defs), 823 {yes,['let-macro',Mdefs|Body],St}; 824%% Common Lisp inspired macros. 825exp_predef([defmodule,Name|Rest], _, St) -> 826 %% Need to handle parametrised module defs here. Limited checking. 827 Mname = case Name of 828 [Mod|_] -> Mod; %Parametrised module 829 Mod -> Mod %Normal module 830 end, 831 MODULE = [defmacro,'MODULE',[],?BQ(?Q(Mname))], 832 {Meta,Atts} = exp_defmodule(Rest), 833 {yes,[progn,['define-module',Name,Meta,Atts],MODULE],St#mac{module=Mname}}; 834exp_predef([deftype,Type0|Def0], _, St) -> 835 {Type1,Def1} = exp_deftype(Type0, Def0), 836 {yes,['define-type',Type1,Def1],St}; 837exp_predef([defopaque,Type0|Def0], _, St) -> 838 {Type1,Def1} = exp_deftype(Type0, Def0), 839 {yes,['define-opaque-type',Type1,Def1],St}; 840exp_predef([defspec,Func0|Spec0], _, St) -> 841 {Func1,Spec1} = exp_defspec(Func0, Spec0), 842 {yes,['define-function-spec',Func1,Spec1],St}; 843exp_predef([defun,Name|Rest], _, St) -> 844 %% Educated guess whether traditional (defun name (a1 a2 ...) ...) 845 %% or matching (defun name (patlist1 ...) (patlist2 ...)) 846 {Meta,Def} = exp_defun(Rest), 847 {yes,['define-function',Name,Meta,Def],St}; 848exp_predef([defmacro,Name|Rest], _, St) -> 849 %% Educated guess whether traditional (defmacro name (a1 a2 ...) ...) 850 %% or matching (defmacro name (patlist1 ...) (patlist2 ...)) 851 {Meta,Def} = exp_defmacro(Rest), 852 {yes,['define-macro',Name,Meta,Def],St}; 853exp_predef([defsyntax,Name|Rules], _, St) -> 854 {Meta,Def} = exp_rules(Name, [], Rules), 855 {yes,['define-macro',Name,Meta,Def],St}; 856exp_predef([flet,Defs|Body], _, St) -> 857 Fun = fun ([Name|Rest]) -> 858 {_,Def} = exp_defun(Rest), %Ignore meta data 859 [Name,Def] 860 end, 861 Fdefs = map(Fun, Defs), 862 {yes,['let-function',Fdefs|Body], St}; 863exp_predef([fletrec,Defs|Body], _, St) -> 864 Fun = fun ([Name|Rest]) -> 865 {_,Def} = exp_defun(Rest), %Ignore meta data 866 [Name,Def] 867 end, 868 Fdefs = map(Fun, Defs), 869 {yes,['letrec-function',Fdefs|Body], St}; 870exp_predef([macrolet,Defs|Body], _, St) -> 871 Fun = fun ([Name|Rest]) -> 872 {_,Def} = exp_defmacro(Rest), %Ignore meta data 873 [Name,Def] 874 end, 875 Mdefs = map(Fun, Defs), 876 {yes,['let-macro',Mdefs|Body],St}; 877exp_predef([syntaxlet,Defs|Body], _, St) -> 878 Fun = fun ([Name|Rest]) -> 879 {_,Def} = exp_rules(Name, [], Rest), 880 [Name,Def] 881 end, 882 Mdefs = map(Fun, Defs), 883 {yes,['let-macro',Mdefs|Body],St}; 884exp_predef([prog1|Body], _, St0) -> 885 %% We do a simple optimisation here. 886 case Body of %Catch bad form here 887 [Expr] -> {yes,Expr,St0}; 888 [First|Rest] -> 889 {V,St1} = new_symb(St0), 890 {yes,['let',[[V,First]]|Rest ++ [V]],St1} 891 end; 892exp_predef([prog2|Body], _, St) -> 893 [First|Rest] = Body, %Catch bad form here 894 {yes,[progn,First,[prog1|Rest]],St}; 895%% This has to go here for the time being so as to be able to macro 896%% expand body. 897exp_predef(['match-spec'|Body], Env, St0) -> 898 %% Expand it like a match-lambda. 899 {Exp,St1} = exp_ml_clauses(Body, Env, St0), 900 MS = lfe_ms:expand(Exp), 901 {yes,MS,St1}; 902%% (qlc (lc (qual ...) e ...) opts) 903exp_predef([qlc,LC], Env, St) -> exp_qlc(LC, [], Env, St); 904exp_predef([qlc,LC,Opts], Env, St) -> exp_qlc(LC, [Opts], Env, St); 905%% Some predefined file macros. 906exp_predef(['MODULE'], _, St) -> 907 {yes,?Q(St#mac.module),St}; 908exp_predef(['LINE'], _, St) -> 909 {yes,?Q(St#mac.line),St}; 910exp_predef([':',M,F|As], Env, St0) when is_atom(M), is_atom(F) -> 911 case exp_call_macro(M, F, As, Env, St0) of 912 {yes,_,_}=Yes -> Yes; %{yes,Exp,St} 913 {no,St1} -> %Use the default expansion 914 {yes,['call',?Q(M),?Q(F)|As], St1} 915 end; 916exp_predef([':',M,F|As], _, St) -> 917 %% Catch the other junk here. 918 {yes,['call',?Q(M),?Q(F)|As], St}; 919exp_predef([Fun|As], _, St) when is_atom(Fun) -> 920 case string:tokens(atom_to_list(Fun), ":") of 921 [M,F] -> 922 {yes,[':',list_to_atom(M),list_to_atom(F)|As],St}; 923 _ -> no %This will also catch a:b:c 924 end; 925%% This was not a call to a predefined macro. 926exp_predef(_, _, _) -> no. 927 928%% exp_call_macro(Module, Name, Args, Env, State) -> 929%% {yes,From,State} | {no,State}. 930%% Expand macro in Module if it exists. Try to be smart and avoid 931%% loading a module, and trying to load a module, unneccessarily. 932 933exp_call_macro(M, F, As, Env, St) -> 934 case erlang:function_exported(M, 'LFE-EXPAND-EXPORTED-MACRO', 3) of 935 true -> 936 case M:'LFE-EXPAND-EXPORTED-MACRO'(F, As, Env) of 937 {yes,Exp} -> {yes,Exp,St}; 938 no -> {no,St} 939 end; 940 false -> 941 %% Slightly faster code:ensure_loaded/1. 942 case erlang:module_loaded(M) of 943 true -> {no,St}; %Module loaded but no macros 944 false -> 945 Unl = St#mac.unloadable, 946 case lists:member(M, Unl) of 947 true -> {no,St}; %Can't load this module 948 false -> 949 %% Try loading file and try again. 950 case code:load_file(M) of 951 {module,_} -> exp_call_macro(M, F, As, Env, St); 952 {error,_} -> 953 %% Echo modules we couldn't load 954 %%lfe_io:format("ecp: ~p\n", [{M,Unl}]), 955 St1 = St#mac{unloadable=[M|Unl]}, 956 {no,St1} 957 end 958 end 959 end 960 end. 961 962%% exp_qlc(LC, Opts, Env, State) -> {yes,Expansion,State}. 963%% Expand a Query List Comprehension returning a call to qlc:q/2. We 964%% first convert the LC into vanilla erlang AST, expand it using in 965%% lfe_qlc.erl, which ql_pt.erl with a special interface, then convert 966%% it back to LFE. 967 968exp_qlc([lc,Qs|Es], Opts, Env, St0) -> 969 %% Expand macros in the LC before translating it preserving 970 %% structure. 971 {Eqs,St1} = exp_qlc_quals(Qs, Env, St0), 972 {Ees,St2} = exp_list(Es, Env, St1), 973 %% lfe_io:format("Q0 = ~p\n", [[lc,Eqs|Ees]]), 974 %% Now translate to vanilla AST, call qlc expand and then convert 975 %% back to LFE. lfe_qlc:expand/2 wants a list of conversions not 976 %% a conversion of a list. 977 Vlc = lfe_trans:to_expr([lc,Eqs|Ees], 42), 978 %% lfe_io:format("~w\n", [Vlc]), 979 Vos = map(fun (O) -> lfe_trans:to_expr(O, 42) end, Opts), 980 %% io:put_chars(["E0 = ",erl_pp:expr(Vlc, 5, []),"\n"]), 981 {ok,Vexp} = lfe_qlc:expand(Vlc, Vos), 982 %% io:put_chars([erl_pp:expr(Vexp),"\n"]), 983 Exp = lfe_trans:from_expr(Vexp), 984 %% lfe_io:format("Q1 = ~p\n", [Exp]), 985 {yes,Exp,St2}. 986 987exp_qlc_quals(Qs, Env, St) -> 988 mapfoldl(fun (Q, S) -> exp_qlc_qual(Q, Env, S) end, St, Qs). 989 990exp_qlc_qual(['<-',P0,['when'|G0],E0], Env, St0) -> 991 {P1,St1} = exp_form(P0, Env, St0), 992 {G1,St2} = exp_tail(G0, Env, St1), 993 {E1,St3} = exp_form(E0, Env, St2), 994 {['<-',P1,['when'|G1],E1],St3}; 995exp_qlc_qual(['<-',P0,E0], Env, St0) -> 996 {P1,St1} = exp_form(P0, Env, St0), 997 {E1,St2} = exp_form(E0, Env, St1), 998 {['<-',P1,E1],St2}; 999exp_qlc_qual(T, Env, St) -> exp_form(T, Env, St). 1000 1001%% exp_bif(Bif, Args) -> Expansion. 1002 1003exp_bif(B, As) -> [call,?Q(erlang),?Q(B)|As]. 1004 1005%% exp_args(Args, State) -> {LetBinds,State}. 1006%% Expand Args into a list of let bindings suitable for a let* or 1007%% nested lets to force sequential left-to-right evaluation. 1008 1009exp_args(As, St) -> 1010 mapfoldl(fun (A, St0) -> {V,St1} = new_symb(St0), {[V,A],St1} end, St, As). 1011 1012%% exp_arith(Args, Op, State) -> {Exp,State}. 1013%% Expand arithmetic call strictly forcing evaluation of all 1014%% arguments. Note that single argument version may need special 1015%% casing. 1016 1017exp_arith([A], Op, St) -> {exp_bif(Op, [A]),St}; 1018exp_arith([A,B], Op, St) -> {exp_bif(Op, [A,B]),St}; 1019exp_arith(As, Op, St0) -> 1020 {Ls,St1} = exp_args(As, St0), 1021 B = foldl(fun ([V,_], Acc) -> exp_bif(Op, [Acc,V]) end, hd(hd(Ls)), tl(Ls)), 1022 {exp_let_star([Ls,B]),St1}. 1023 1024%% exp_logical(Args, Op State) -> {Exp,State}. 1025%% Expand logical call forcing evaluation of all arguments but not 1026%% strictly; this guarantees expansion is hygenic. Note that single 1027%% argument version may need special casing. 1028 1029exp_logical([A], Op, St) -> {exp_bif(Op, [A,?Q(true)]),St}; 1030exp_logical([A,B], Op, St) -> {exp_bif(Op, [A,B]),St}; 1031exp_logical(As, Op, St0) -> 1032 {Ls,St1} = exp_args(As, St0), 1033 B = foldl(fun ([V,_], Acc) -> exp_bif(Op, [Acc,V]) end, hd(hd(Ls)), tl(Ls)), 1034 {['let',Ls,B],St1}. 1035 1036%% exp_comp(Args, Op, State) -> {Exp,State}. 1037%% Expand comparison test strictly forcing evaluation of all 1038%% arguments. Note that single argument version may need special 1039%% casing. 1040 1041exp_comp([A], _, St) -> %Force evaluation 1042 {[progn,A,?Q(true)],St}; 1043exp_comp([A,B], Op, St) -> {exp_bif(Op, [A,B]),St}; 1044exp_comp(As, Op, St0) -> 1045 {Ls,St1} = exp_args(As, St0), 1046 Ts = op_pairs(Ls, Op), 1047 {exp_let_star([Ls,exp_andalso(Ts)]),St1}. 1048 1049op_pairs([[V0,_]|Ls], Op) -> 1050 element(1, mapfoldl(fun ([V1,_], Acc) -> {exp_bif(Op, [Acc,V1]),V1} end, 1051 V0, Ls)). 1052 1053%% exp_nequal(Args, Op, State) -> {Exp,State}. 1054%% Expand not equal test strictly forcing evaluation of all 1055%% arguments. We need to compare all the arguments with each other. 1056 1057exp_nequal([A], _, St) -> %Force evaluation 1058 {[progn,A,?Q(true)],St}; 1059exp_nequal([A,B], Op, St) -> {exp_bif(Op, [A,B]),St}; 1060exp_nequal(As, Op, St0) -> 1061 {Ls,St1} = exp_args(As, St0), 1062 Ts = op_all_pairs(Ls, Op), 1063 {exp_let_star([Ls,exp_andalso(Ts)]),St1}. 1064 1065op_all_pairs([], _) -> []; 1066op_all_pairs([[V,_]|Ls], Op) -> 1067 [ exp_bif(Op, [V,V1]) || [V1,_] <- Ls] ++ op_all_pairs(Ls, Op). 1068 1069%% exp_append(Args) -> Expansion. 1070%% Expand ++ in such a way as to allow its use in patterns. There are 1071%% a lot of interesting cases here. Only be smart with proper forms. 1072 1073exp_append(Args) -> 1074 case Args of 1075 %% Cases with quoted lists. 1076 [?Q([A|As])|Es] -> [cons,?Q(A),exp_append([?Q(As)|Es])]; 1077 [?Q([])|Es] -> exp_append(Es); 1078 %% Cases with explicit cons/list/list*. 1079 [['list*',A]|Es] -> exp_append([A|Es]); 1080 [['list*',A|As]|Es] -> [cons,A,exp_append([['list*'|As]|Es])]; 1081 [[list,A|As]|Es] -> [cons,A,exp_append([[list|As]|Es])]; 1082 [[list]|Es] -> exp_append(Es); 1083 [[cons,H,T]|Es] -> [cons,H,exp_append([T|Es])]; 1084 [[]|Es] -> exp_append(Es); 1085 %% Cases with lists of numbers (strings). 1086 %% [[N|Ns]|Es] when is_number(N) -> [cons,N,exp_append([Ns|Es])]; 1087 %% Default cases with unquoted arg. 1088 [E] -> E; %Last arg not checked 1089 [E|Es] -> exp_bif('++', [E,exp_append(Es)]); 1090 [] -> [] 1091 end. 1092 1093%% exp_prefix(Args) -> Expansion. 1094%% Expand ++* in such a way as to allow its use in patterns. 1095%% Handle lists of numbers (strings) explicitly, otherwise 1096%% default to exp_append/1. 1097 1098exp_prefix([['list*',A]|Es]) -> exp_prefix([A|Es]); 1099exp_prefix([['list*',A|As]|Es]) -> [cons,A,exp_prefix([['list*'|As]|Es])]; 1100exp_prefix([[list,A|As]|Es]) -> [cons,A,exp_prefix([[list|As]|Es])]; 1101exp_prefix([[list]|Es]) -> exp_prefix(Es); 1102exp_prefix([[cons,H,T]|Es]) -> [cons,H,exp_prefix([T|Es])]; 1103exp_prefix([[N|Ns]|Es]) when is_number(N) -> [cons,N,exp_prefix([Ns|Es])]; 1104exp_prefix([[]|Es]) -> exp_prefix(Es); 1105exp_prefix(Args) -> exp_append(Args). 1106 1107%% exp_list_star(ListBody) -> Cons. 1108 1109exp_list_star([E]) -> E; 1110exp_list_star([E|Es]) -> 1111 [cons,E,exp_list_star(Es)]; 1112exp_list_star([]) -> []. 1113 1114%% exp_let_star(FletBody) -> Flets. 1115 1116exp_let_star([[Vb|Vbs]|B]) -> 1117 ['let',[Vb],exp_let_star([Vbs|B])]; 1118exp_let_star([[]|B]) -> [progn|B]; 1119exp_let_star([Vb|B]) -> ['let',Vb|B]. %Pass error to let for lint. 1120 1121%% exp_flet_star(FletBody) -> Flets. 1122 1123exp_flet_star([[Fb|Fbs]|B]) -> 1124 [flet,[Fb],exp_flet_star([Fbs|B])]; 1125exp_flet_star([[]|B]) -> [progn|B]; 1126exp_flet_star([Fb|B]) -> [flet,Fb|B]. %Pass error to flet for lint 1127 1128%% exp_cond(CondBody) -> Tests. 1129%% Expand a cond body to a sequence of if/case tests. 1130 1131exp_cond([['else'|B]]) -> [progn|B]; 1132exp_cond([[['?=',P,E]|B]|Cond]) -> 1133 ['case',E,[P|B],['_',exp_cond(Cond)]]; 1134exp_cond([[['?=',P,['when'|_]=G,E]|B]|Cond]) -> 1135 ['case',E,[P,G|B],['_',exp_cond(Cond)]]; 1136exp_cond([[Test|B]|Cond]) -> %Test and body 1137 ['if',Test,[progn|B],exp_cond(Cond)]; 1138exp_cond([Test|Cond]) -> %Naked test 1139 ['if',Test,?Q(true),exp_cond(Cond)]; 1140exp_cond([]) -> ?Q(false). 1141 1142%% exp_do(DoBody) -> DoLoop. 1143%% Expand a do body into a loop. Add a variable 'do-state' which is 1144%% the value of the do body which can be used when setting new values 1145%% to do vars. 1146 1147exp_do([Pars,[Test,Ret]|Body], St0) -> 1148 {Vs,Is,Cs} = foldr(fun ([V,I,C], {Vs,Is,Cs}) -> {[V|Vs],[I|Is],[C|Cs]} end, 1149 {[],[],[]}, Pars), 1150 {Fun,St1} = new_fun_name("do", St0), 1151 Exp = ['letrec-function', 1152 [[Fun,[lambda,Vs, 1153 ['if',Test,Ret, 1154 ['let',[['do-state', 1155 ['progn'] ++ Body]], 1156 [Fun|Cs]]]]]], 1157 [Fun|Is]], 1158 {Exp,St1}. 1159 1160%% exp_andalso(AndAlsoBody) -> Ifs. 1161%% exp_orelse(OrElseBody) -> Ifs. 1162 1163exp_andalso([E]) -> E; %Let user check last call 1164exp_andalso([E|Es]) -> 1165 ['if',E,exp_andalso(Es),?Q(false)]; 1166exp_andalso([]) -> ?Q(true). 1167 1168exp_orelse([E]) -> E; %Let user check last call 1169exp_orelse([E|Es]) -> ['if',E,?Q(true),exp_orelse(Es)]; 1170exp_orelse([]) -> ?Q(false). 1171 1172%% exp_defmodule(Rest) -> {Meta,Attributes}. 1173%% Extract the comment string either if it is first. Ignore 'doc' 1174%% attributes. Allow empty module definition. 1175 1176exp_defmodule([]) -> {[],[]}; 1177exp_defmodule([Doc|Atts]=Rest) -> 1178 ?IF(lfe_lib:is_doc_string(Doc), {[[doc,Doc]],Atts}, {[],Rest}). 1179 1180%% exp_deftype(Type, Def) -> {Type,Def}. 1181%% Paramterless types to be written as just type name and default 1182%% type is any. 1183 1184exp_deftype(T, D) -> 1185 Type = if is_list(T) -> T; true -> [T] end, 1186 Def = if D =:= [] -> [any]; true -> hd(D) end, 1187 {Type,Def}. 1188 1189%% exp_defspec(Func, Def) -> {Func,Def}. 1190%% Do very little here, leave it to lint 1191 1192exp_defspec([_,_]=Func, Def) -> {Func,Def}; 1193exp_defspec(Name, Def) -> 1194 {[Name,defspec_arity(Def)],Def}. 1195 1196%% defspec_arity(Spec) -> Arity. 1197%% Just return the length of the first arg list and let lint check 1198%% properly later. 1199 1200defspec_arity([[Args|_]|_]) -> 1201 case lfe_lib:is_proper_list(Args) of 1202 true -> length(Args); 1203 false -> 0 1204 end; 1205defspec_arity(_) -> 0. 1206 1207%% exp_defun(Rest) -> {Meta,Lambda | MatchLambda}. 1208%% Educated guess whether traditional (defun name (a1 a2 ...) ...) 1209%% or matching (defun name (patlist1 ...) (patlist2 ...)) and whether 1210%% there is a comment string. 1211 1212exp_defun([Args|Body]=Rest) -> 1213 case lfe_lib:is_symb_list(Args) of 1214 true -> exp_lambda_defun(Args, Body); 1215 false -> exp_match_defun(Rest) 1216 end. 1217 1218exp_lambda_defun(Args, Body) -> 1219 {Meta,Def} = exp_meta(Body, []), 1220 {Meta,['lambda',Args|Def]}. 1221 1222exp_match_defun(Rest) -> 1223 {Meta,Cls} = exp_meta(Rest, []), 1224 {Meta,['match-lambda'|Cls]}. 1225 1226exp_meta([[spec|Spec]|Rest], Meta) -> 1227 exp_meta(Rest, Meta ++ [[spec|Spec]]); 1228exp_meta([Doc|Rest], Meta) -> 1229 %% The untagged doc string but not at the end. 1230 ?IF(lfe_lib:is_doc_string(Doc) and (Rest =/= []), 1231 exp_meta(Rest, Meta ++ [[doc,Doc]]), 1232 {Meta,[Doc|Rest]}); 1233exp_meta([], Meta) -> {Meta,[]}. 1234 1235%% exp_defmacro(Rest) -> {Meta,MatchLambda}. 1236%% Educated guess whether traditional (defmacro name (a1 a2 ...) ...) 1237%% or matching (defmacro name (patlist1 ...) (patlist2 ...)). Special 1238%% case (defmacro name arg ...) to make arg be whole argument list. 1239%% N.B. Macro definition is function of 2 arguments: the whole 1240%% argument list of macro call; and $ENV, the current macro 1241%% environment. 1242 1243exp_defmacro([Args|Body]=Rest) -> 1244 {Meta,Cls} = case lfe_lib:is_symb_list(Args) of 1245 true -> exp_lambda_defmacro([list|Args], Body); 1246 false -> 1247 if is_atom(Args) -> 1248 exp_lambda_defmacro(Args, Body); 1249 true -> 1250 exp_match_defmacro(Rest) 1251 end 1252 end, 1253 {Meta,['match-lambda'|Cls]}. 1254 1255exp_lambda_defmacro(Args, Body) -> 1256 {Meta,Def} = exp_meta(Body, []), 1257 {Meta,[[[Args,'$ENV']|Def]]}. 1258 1259exp_match_defmacro(Rest) -> 1260 {Meta,Cls} = exp_meta(Rest, []), 1261 {Meta,map(fun ([Head|Body]) -> [[Head,'$ENV']|Body] end, Cls)}. 1262 1263%% exp_syntax(Name, Def) -> {Meta,Lambda | MatchLambda}. 1264%% N.B. New macro definition is function of 2 arguments, the whole 1265%% argument list of macro call, and the current macro environment. 1266 1267exp_syntax(Name, Def) -> 1268 case Def of 1269 [macro|Cls] -> 1270 Mcls = map(fun ([Pat|Body]) -> [[Pat,'$ENV']|Body] end, Cls), 1271 {[],['match-lambda'|Mcls]}; 1272 ['syntax-rules'|Rules] -> 1273 exp_rules(Name, [], Rules) 1274 end. 1275 1276%% exp_rules(Name, Keywords, Rules) -> {Meta,Lambda}. 1277%% Expand into call function which expands macro an invocation time, 1278%% this saves much space and costs us nothing. 1279%% N.B. New macro definition is function of 2 arguments, the whole 1280%% argument list of macro call, and the current macro environment. 1281 1282exp_rules(Name, Keywords, Rules) -> 1283 {[],[lambda,[args,'$ENV'], 1284 [':',lfe_macro,mbe_syntax_rules_proc, 1285 [quote,Name],[quote,Keywords],[quote,Rules],args]]}. 1286 1287%% By Andr� van Tonder 1288%% Unoptimized. See Dybvig source for optimized version. 1289%% Resembles one by Richard Kelsey and Jonathan Rees. 1290%% (define-syntax quasiquote 1291%% (lambda (s) 1292%% (define (qq-expand x level) 1293%% (syntax-case x (quasiquote unquote unquote-splicing) 1294%% (`x (quasisyntax (list 'quasiquote 1295%% #,(qq-expand (syntax x) (+ level 1))))) 1296%% (,x (> level 0) 1297%% (quasisyntax (cons 'unquote 1298%% #,(qq-expand (syntax x) (- level 1))))) 1299%% (,@x (> level 0) 1300%% (quasisyntax (cons 'unquote-splicing 1301%% #,(qq-expand (syntax x) (- level 1))))) 1302%% (,x (= level 0) 1303%% (syntax x)) 1304%% (((unquote x ...) . y) 1305%% (= level 0) 1306%% (quasisyntax (append (list x ...) 1307%% #,(qq-expand (syntax y) 0)))) 1308%% (((unquote-splicing x ...) . y) 1309%% (= level 0) 1310%% (quasisyntax (append (append x ...) 1311%% #,(qq-expand (syntax y) 0)))) 1312%% ((x . y) 1313%% (quasisyntax (cons #,(qq-expand (syntax x) level) 1314%% #,(qq-expand (syntax y) level)))) 1315%% (#(x ...) 1316%% (quasisyntax (list->vector #,(qq-expand (syntax (x ...)) 1317%% level)))) 1318%% (x (syntax 'x)))) 1319%% (syntax-case s () 1320%% ((_ x) (qq-expand (syntax x) 0))))) 1321 1322%% exp_backquote(Exp) -> Exp. 1323%% Not very efficient quasiquote expander, but very compact code. Is 1324%% R6RS compliant and can handle comma (unquote) and comma-at 1325%% (unquote-splicing) with more than one argument properly. Actually 1326%% with simple cons/append optimisers code now quite good. 1327 1328exp_backquote(Exp) -> exp_backquote(Exp, 0). 1329 1330exp_backquote([backquote,X], N) -> 1331 [list,[quote,backquote],exp_backquote(X, N+1)]; 1332exp_backquote([comma|X], N) when N > 0 -> 1333 exp_bq_cons([quote,comma], exp_backquote(X, N-1)); 1334exp_backquote([comma,X], 0) -> X; 1335exp_backquote(['comma-at'|X], N) when N > 0 -> 1336 exp_bq_cons([quote,'comma-at'], exp_backquote(X, N-1)); 1337%% Next 2 handle case of splicing into a list. 1338exp_backquote([[comma|X]|Y], 0) -> 1339 exp_bq_append([list|X], exp_backquote(Y, 0)); 1340exp_backquote([['comma-at'|X]|Y], 0) -> 1341 exp_bq_append(['++'|X], exp_backquote(Y, 0)); 1342exp_backquote([X|Y], N) -> %The general list case 1343 exp_bq_cons(exp_backquote(X, N), exp_backquote(Y, N)); 1344exp_backquote(X, N) when is_tuple(X) -> 1345 %% Straight [list_to_tuple,exp_backquote(tuple_to_list(X), N)] 1346 %% inefficient and [tuple|tl(exp_backquote(tuple_to_list(X), N))] 1347 %% can't handle splicing! 1348 case exp_backquote(tuple_to_list(X), N) of 1349 [list|Es] -> [tuple|Es]; %No splicing 1350 [cons|_]=E -> [list_to_tuple,E]; %Have splicing 1351 [] -> [tuple] %The empty tuple 1352 end; 1353exp_backquote(X, N) when ?IS_MAP(X) -> 1354 %% Splicing at top-level almost meaningless here, with [list|...] 1355 %% we have no splicing, while with [cons|...] we have splicing 1356 case exp_bq_map_pairs(maps:to_list(X), N) of 1357 [list|KVs] -> [map|KVs]; %No splicing 1358 %% [cons|_]=E -> %Have splicing 1359 %% [call,?Q(maps),?Q(from_list)|E]; 1360 [] -> [map] %The empty map 1361 end; 1362exp_backquote(X, _) when is_atom(X) -> [quote,X]; 1363exp_backquote(X, _) -> X. %Self quoting 1364 1365exp_bq_append(['++',L], R) -> %Catch single comma-at 1366 exp_bq_append(L, R); 1367exp_bq_append([], R) -> R; 1368exp_bq_append(L, []) -> L; 1369%% Will these 2 cases move code errors illegally? 1370exp_bq_append([list,L], [list|R]) -> [list,L|R]; 1371exp_bq_append([list,L], R) -> [cons,L,R]; 1372%%exp_bq_append(['++'|L], R) -> ['++'|L ++ [R]]; 1373%%exp_bq_append(L, ['++'|R]) -> ['++',L|R]; 1374exp_bq_append(L, R) -> ['++',L,R]. 1375 1376exp_bq_cons([quote,L], [quote,R]) -> [quote,[L|R]]; 1377exp_bq_cons(L, [list|R]) -> [list,L|R]; 1378exp_bq_cons(L, []) -> [list,L]; 1379exp_bq_cons(L, R) -> [cons,L,R]. 1380 1381-ifdef(HAS_MAPS). 1382exp_bq_map_pairs(Ps, N) -> 1383 KVs = foldr(fun ({K,V}, Acc) -> [K,V|Acc] end, [], Ps), 1384 exp_backquote(KVs, N). 1385-else. 1386exp_bq_map_pairs(_, _) -> [list]. 1387-endif. 1388 1389new_symb(St) -> 1390 C = St#mac.vc, 1391 {list_to_atom("|-" ++ integer_to_list(C) ++ "-|"),St#mac{vc=C+1}}. 1392 1393new_symbs(N, St) -> new_symbs(N, St, []). 1394 1395new_symbs(N, St0, Vs) when N > 0 -> 1396 {V,St1} = new_symb(St0), 1397 new_symbs(N-1, St1, [V|Vs]); 1398new_symbs(0, St, Vs) -> {Vs,St}. 1399 1400new_fun_name(Pre, St) -> 1401 C = St#mac.fc, 1402 {list_to_atom(Pre ++ "$^" ++ integer_to_list(C)),St#mac{fc=C+1}}. 1403 1404%% Macro by Example 1405%% Proper syntax-rules which can handle ... ellipsis by Dorai Sitaram. 1406%% 1407%% While we extend patterns to include tuples and binaries as in 1408%% normal LFE we leave the keyword handling in even though it is 1409%% subsumed by quotes and not really used. 1410 1411%% To make it more lispy! 1412-define(car(L), hd(L)). 1413-define(cdr(L), tl(L)). 1414-define(cadr(L), hd(tl(L))). 1415-define(cddr(L), tl(tl(L))). 1416 1417-define(mbe_ellipsis(Car, Cddr), [Car,'...'|Cddr]). 1418 1419is_mbe_symbol(S) -> 1420 is_atom(S) andalso not is_boolean(S). 1421 1422%% Tests if ellipsis pattern, (p ... . rest) 1423%% is_mbe_ellipsis(?mbe_ellipsis(_, _)) -> true; 1424%% is_mbe_ellipsis(_) -> false. 1425 1426mbe_match_pat([quote,P], E, _) -> P =:= E; 1427mbe_match_pat([tuple|Ps], [tuple|Es], Ks) -> %Match tuple constructor 1428 mbe_match_pat(Ps, Es, Ks); 1429mbe_match_pat([tuple|Ps], E, Ks) -> %Match literal tuple 1430 case is_tuple(E) of 1431 true -> mbe_match_pat(Ps, tuple_to_list(E), Ks); 1432 false -> false 1433 end; 1434mbe_match_pat(?mbe_ellipsis(Pcar, _), E, Ks) -> 1435 case lfe_lib:is_proper_list(E) of 1436 true -> 1437 all(fun (X) -> mbe_match_pat(Pcar, X, Ks) end, E); 1438 false -> false 1439 end; 1440mbe_match_pat([Pcar|Pcdr], E, Ks) -> 1441 case E of 1442 [Ecar|Ecdr] -> 1443 mbe_match_pat(Pcar, Ecar, Ks) andalso 1444 mbe_match_pat(Pcdr, Ecdr, Ks); 1445 _ -> false 1446 end; 1447mbe_match_pat(Pat, E, Ks) -> 1448 case is_mbe_symbol(Pat) of 1449 true -> 1450 case member(Pat, Ks) of 1451 true -> Pat =:= E; 1452 false -> true 1453 end; 1454 false -> Pat =:= E 1455 end. 1456 1457mbe_get_ellipsis_nestings(Pat, Ks) -> 1458 m_g_e_n(Pat, Ks). 1459 1460m_g_e_n([quote,_], _) -> []; 1461m_g_e_n([tuple|Ps], Ks) -> m_g_e_n(Ps, Ks); 1462m_g_e_n(?mbe_ellipsis(Pcar, Pcddr), Ks) -> 1463 [m_g_e_n(Pcar, Ks)|m_g_e_n(Pcddr, Ks)]; 1464m_g_e_n([Pcar|Pcdr], Ks) -> 1465 m_g_e_n(Pcar, Ks) ++ m_g_e_n(Pcdr, Ks); 1466m_g_e_n(Pat, Ks) -> 1467 case is_mbe_symbol(Pat) of 1468 true -> 1469 case member(Pat, Ks) of 1470 true -> []; 1471 false -> [Pat] 1472 end; 1473 false -> [] 1474 end. 1475 1476mbe_ellipsis_sub_envs(Nestings, R) -> 1477 ormap(fun (C) -> 1478 case mbe_intersect(Nestings, ?car(C)) of 1479 true -> ?cdr(C); 1480 false -> false 1481 end end, R). 1482 1483%% Return first value of F applied to elements in list which is not false. 1484ormap(F, [H|T]) -> 1485 case F(H) of 1486 false -> ormap(F, T); 1487 V -> V 1488 end; 1489ormap(_, []) -> false. 1490 1491mbe_intersect(V, Y) -> 1492 case is_mbe_symbol(V) orelse is_mbe_symbol(Y) of 1493 true -> V =:= Y; 1494 false -> 1495 any(fun (V0) -> 1496 any(fun (Y0) -> mbe_intersect(V0, Y0) end, Y) 1497 end, V) 1498 end. 1499 1500%% mbe_get_bindings(Pattern, Expression, Keywords) -> Bindings. 1501 1502mbe_get_bindings([quote,_], _, _) -> []; 1503mbe_get_bindings([tuple|Ps], [tuple|Es], Ks) -> %Tuple constructor 1504 mbe_get_bindings(Ps, Es, Ks); 1505mbe_get_bindings([tuple|Ps], E, Ks) -> %Literal tuple 1506 mbe_get_bindings(Ps, tuple_to_list(E), Ks); 1507mbe_get_bindings(?mbe_ellipsis(Pcar, _), E, Ks) -> 1508 [[mbe_get_ellipsis_nestings(Pcar, Ks) | 1509 map(fun (X) -> mbe_get_bindings(Pcar, X, Ks) end, E)]]; 1510mbe_get_bindings([Pcar|Pcdr], [Ecar|Ecdr], Ks) -> 1511 mbe_get_bindings(Pcar, Ecar, Ks) ++ 1512 mbe_get_bindings(Pcdr, Ecdr, Ks); 1513mbe_get_bindings(Pat, E, Ks) -> 1514 case is_mbe_symbol(Pat) of 1515 true -> 1516 case member(Pat, Ks) of 1517 true -> []; 1518 false -> [[Pat|E]] 1519 end; 1520 false -> [] 1521 end. 1522 1523%% mbe_expand_pattern(Pattern, Bindings, Keywords) -> Form. 1524 1525mbe_expand_pattern([quote,P], R, Ks) -> 1526 [quote,mbe_expand_pattern(P, R, Ks)]; 1527mbe_expand_pattern([tuple|Ps], R, Ks) -> 1528 [tuple|mbe_expand_pattern(Ps, R, Ks)]; 1529mbe_expand_pattern(?mbe_ellipsis(Pcar, Pcddr), R, Ks) -> 1530 Nestings = mbe_get_ellipsis_nestings(Pcar, Ks), 1531 Rr = mbe_ellipsis_sub_envs(Nestings, R), 1532 map(fun (R0) -> mbe_expand_pattern(Pcar, R0 ++ R, Ks) end, Rr) ++ 1533 mbe_expand_pattern(Pcddr, R, Ks); 1534mbe_expand_pattern([Pcar|Pcdr], R, Ks) -> 1535 [mbe_expand_pattern(Pcar, R, Ks)| 1536 mbe_expand_pattern(Pcdr, R, Ks)]; 1537mbe_expand_pattern(Pat, R, Ks) -> 1538 case is_mbe_symbol(Pat) of 1539 true -> 1540 case member(Pat, Ks) of 1541 true -> Pat; 1542 false -> 1543 case lfe:assoc(Pat, R) of 1544 [_|Cdr] -> Cdr; 1545 [] -> Pat 1546 end 1547 end; 1548 false -> Pat 1549 end. 1550 1551%% mbe_syntax_rules_proc(Name, Keywords, Rules, Argsym, Keywordsym) -> 1552%% Sexpr. 1553%% Generate the sexpr to evaluate in a macro from Name and 1554%% Rules. When the sexpr is applied to arguments (in Argsym) and 1555%% evaluated then expansion is returned. 1556 1557%% Return sexpr to evaluate. 1558mbe_syntax_rules_proc(Name, Ks0, Cls, Argsym, Ksym) -> 1559 Ks = [Name|Ks0], 1560 %% Don't prepend the macro name to the arguments! 1561 ['let',[[Ksym,[quote,Ks]]], 1562 ['cond'] ++ 1563 map(fun (C) -> 1564 Inpat = hd(C), 1565 Outpat = hd(tl(C)), 1566 [[':',lfe_macro,mbe_match_pat,[quote,Inpat], Argsym, Ksym], 1567 ['let', 1568 [[r,[':',lfe_macro,mbe_get_bindings, 1569 [quote,Inpat],Argsym,Ksym]]], 1570 [':',lfe_macro,mbe_expand_pattern, 1571 [quote,Outpat],r,Ksym]]] 1572 end, Cls) ++ 1573 [[[quote,true],[':',erlang,error, 1574 [tuple, 1575 [quote,expand_macro], 1576 [cons,[quote,Name],Argsym], %??? Must check this 1577 [quote,macro_clause]]]]]]. 1578 1579%% Do it all directly. 1580mbe_syntax_rules_proc(Name, Ks0, Cls, Args) -> 1581 Ks = [Name|Ks0], 1582 case ormap(fun ([Pat,Exp]) -> 1583 case mbe_match_pat(Pat, Args, Ks) of 1584 true -> 1585 R = mbe_get_bindings(Pat, Args, Ks), 1586 [mbe_expand_pattern(Exp, R, Ks)]; 1587 false -> false 1588 end 1589 end, Cls) of 1590 [Res] -> Res; 1591 false -> erlang:error({expand_macro,[Name|Args],macro_clause}) 1592 end. 1593 1594%% lc_te(Exprs, Qualifiers, State) -> {Exp,State}. 1595%% bc_te(Exprs, Qualifiers, State) -> {Exp,State}. 1596%% Expand a list/binary comprehension. Algorithm straight out of 1597%% Simon PJs book. 1598 1599%% lc_te(Es, Qs, St) -> lc_tq(Es, Qs, [], St). 1600lc_te(Es, Qs, St) -> lc_te(Es, Qs, [], St). 1601 1602lc_te(Es, Qs, End, St) -> 1603 c_tq(fun (E, S) -> {[cons,['progn'|Es],E],S} end, Qs, End, St). 1604 1605%%bc_te(Es, Qs, St) -> bc_tq(Es, Qs, <<>>, St). 1606bc_te(Es, Qs, St) -> 1607 c_tq(fun (E, S) -> 1608 %% Separate last form to be binary segment. 1609 case reverse(Es) of 1610 [R] -> {[binary,R,[E,bitstring]],S}; 1611 [R|Rs] -> {['progn'|reverse(Rs)] ++ 1612 [[binary,R,[E,bitstring]]],S}; 1613 [] -> {E,S} 1614 end 1615 end, Qs, <<>>, St). 1616 1617%% c_tq(BuildExp, Qualifiers, End, State) -> {Exp,State}. 1618 1619c_tq(Exp, [['<-',P,Gen]|Qs], End, St) -> %List generator 1620 c_l_tq(Exp, P, [], Gen, Qs, End, St); 1621c_tq(Exp, [['<-',P,['when'|G],Gen]|Qs], End, St) -> %List generator 1622 c_l_tq(Exp, P, G, Gen, Qs, End, St); 1623c_tq(Exp, [['<=',P,Gen]|Qs], End, St) -> %Bits generator 1624 c_b_tq(Exp, P, [], Gen, Qs, End, St); 1625c_tq(Exp, [['<=',P,['when'|G],Gen]|Qs], End, St) -> %Bits generator 1626 c_b_tq(Exp, P, G, Gen, Qs, End, St); 1627c_tq(Exp, [['?=',P,E]|Qs], End, St0) -> %Test match 1628 {Rest,St1} = c_tq(Exp, Qs, End, St0), 1629 {['case',E,[P,Rest],['_',End]],St1}; 1630c_tq(Exp, [['?=',P,['when'|_]=G,E]|Qs], End, St0) -> %Test match 1631 {Rest,St1} = c_tq(Exp, Qs, End, St0), 1632 {['case',E,[P,G,Rest],['_',End]],St1}; 1633c_tq(Exp, [T|Qs], End, St0) -> %Test 1634 {Rest,St1} = c_tq(Exp, Qs, End, St0), 1635 {['if',T,Rest,End],St1}; 1636c_tq(Exp, [], End, St) -> %End of qualifiers 1637 Exp(End, St). 1638 1639c_l_tq(Exp, P, G, Gen, Qs, End, St0) -> 1640 {H,St1} = new_fun_name("lc", St0), %Function name 1641 {Us,St2} = new_symb(St1), %Tail variable 1642 {Rest,St3} = c_tq(Exp, Qs, [H,Us], St2), %Do rest of qualifiers 1643 %% Build the match, no match and end clauses, no nomatch clause if 1644 %% pattern and guard guaranteed to match. Keeps compiler quiet. 1645 Cs0 = [ [[[]],End] ], %End of list 1646 Cs1 = case is_atom(P) and (G == []) of %No match, skip 1647 true -> Cs0; 1648 false -> [ [[[cons,'_',Us]],[H,Us]] |Cs0] 1649 end, 1650 Cs2 = [ [[[cons,P,Us]],['when'|G],Rest] |Cs1], %Matches pattern and guard 1651 {['letrec-function', 1652 [[H,['match-lambda'|Cs2]]], 1653 [H,Gen]],St3}. 1654 1655c_b_tq(Exp, P, G, Gen, Qs, End, St0) -> 1656 {H,St1} = new_fun_name("bc", St0), %Function name 1657 {B,St2} = new_symb(St1), %Bin variable 1658 {Rest,St3} = c_tq(Exp, Qs, [H,B], St2), %Do rest of qualifiers 1659 Brest = [B,bitstring,'big-endian',unsigned,[unit,1]], %,[size,all] 1660 %% Build the match and nomatch/end clauses. 1661 MatchC = [[[binary,P,Brest]],['when'|G],Rest], %Matches pattern and guard 1662 EndC = [[[binary,Brest]],End], %No match 1663 {['letrec-function', 1664 [[H,['match-lambda',MatchC,EndC]]], 1665 [H,Gen]],St3}. 1666 1667%% c_tq(Exp, [['<-',P,Gen]|Qs], End, St0) -> %List generator 1668%% {H,St1} = new_fun_name("lc", St0), %Function name 1669%% {Us,St2} = new_symb(St1), %Tail variable 1670%% {Rest,St3} = c_tq(Exp, Qs, [H,Us], St2), %Do rest of qualifiers 1671%% {['letrec-function', 1672%% [[H,['match-lambda', 1673%% [[[P|Us]],Rest], %Matches pattern 1674%% [[['_'|Us]],[H,Us]], %No match 1675%% [[[]],End]]]], %End of list 1676%% [H,Gen]],St3}; 1677 1678%% c_tq(Exp, [['<=',P,Gen]|Qs], End, St0) -> %Bits generator 1679%% {H,St1} = new_fun_name("bc", St0), %Function name 1680%% {B,St2} = new_symb(St1), %Bin variable 1681%% {Rest,St3} = c_tq(Exp, Qs, [H,B], St2), %Do rest of qualifiers 1682%% Brest = [B,bitstring,'big-endian',unsigned,[unit,1]], %,[size,all] 1683%% {['letrec-function', 1684%% [[H,['match-lambda', 1685%% [[[binary,P,Brest]],Rest], %Matches pattern 1686%% [[[binary,Brest]],End]]]], %No match 1687%% [H,Gen]],St3}; 1688 1689%% mapfoldl2(Fun, Acc1, Acc2, List) -> {List,Acc1,Acc2}. 1690%% Like normal mapfoldl but with 2 accumulators. 1691 1692mapfoldl2(Fun, A0, B0, [E0|Es0]) -> 1693 {E1,A1,B1} = Fun(E0, A0, B0), 1694 {Es1,A2,B2} = mapfoldl2(Fun, A1, B1, Es0), 1695 {[E1|Es1],A2,B2}; 1696mapfoldl2(_, A, B, []) -> {[],A,B}. 1697