EEP 37: Funs with names

nox · nox · commit acbca8379bdd · 2013-12-12T10:46:08.000+01:00
This adds optional names to fun expressions. A named fun expression
is parsed as a tuple `{named_fun,Loc,Name,Clauses}` in erl_parse.

If a fun expression has a name, it must be present and be the same in
every of its clauses. The function name shadows the environment of the
expression shadowing the environment and it is shadowed by the
environment of the clauses' arguments. An unused function name triggers
a warning unless it is prefixed by _, just as every variable.
Variable _ is allowed as a function name.

It is not an error to put a named function in a record field default
value.

When transforming to Core Erlang, the named fun Fun is changed into
the following expression:

    letrec 'Fun'/Arity =
               fun (Args) -&gt;
                       let &lt;Fun&gt; = 'Fun'/Arity
                       in Case
    in 'Fun'/Arity

where Args is the list of arguments of 'Fun'/Arity and Case the
Core Erlang expression corresponding to the clauses of Fun.

This transformation allows us to entirely skip any k_var to k_local
transformation in the fun's clauses bodies.
diff --git a/lib/compiler/src/sys_pre_expand.erl b/lib/compiler/src/sys_pre_expand.erl
@@ -344,6 +344,8 @@ expr({'receive',Line,Cs0,To0,ToEs0}, St0) ->
     {{'receive',Line,Cs,To,ToEs},St3};
 expr({'fun',Line,Body}, St) ->
     fun_tq(Line, Body, St);
+expr({named_fun,Line,Name,Cs}, St) ->
+    fun_tq(Line, Cs, St, Name);
 expr({call,Line,{atom,La,N}=Atom,As0}, St0) ->
     {As,St1} = expr_list(As0, St0),
     Ar = length(As),
@@ -475,6 +477,11 @@ fun_tq(Lf, {clauses,Cs0}, St0) ->
     Index = Uniq = 0,
     {{'fun',Lf,{clauses,Cs1},{Index,Uniq,Fname}},St2}.
 
+fun_tq(Line, Cs0, St0, Name) ->
+    {Cs1,St1} = fun_clauses(Cs0, St0),
+    {Fname,St2} = new_fun_name(St1, Name),
+    {{named_fun,Line,Name,Cs1,{0,0,Fname}},St2}.
+
 fun_clauses([{clause,L,H0,G0,B0}|Cs0], St0) ->
     {H,St1} = head(H0, St0),
     {G,St2} = guard(G0, St1),
@@ -485,9 +492,12 @@ fun_clauses([], St) -> {[],St}.
 
 %% new_fun_name(State) -> {FunName,State}.
 
-new_fun_name(#expand{func=F,arity=A,fcount=I}=St) ->
+new_fun_name(St) ->
+    new_fun_name(St, 'fun').
+
+new_fun_name(#expand{func=F,arity=A,fcount=I}=St, FName) ->
     Name = "-" ++ atom_to_list(F) ++ "/" ++ integer_to_list(A)
-        ++ "-fun-" ++ integer_to_list(I) ++ "-",
+        ++ "-" ++ atom_to_list(FName) ++ "-" ++ integer_to_list(I) ++ "-",
     {list_to_atom(Name),St#expand{fcount=I+1}}.
 
 %% pattern_bin([Element], State) -> {[Element],[Variable],[UsedVar],State}.
diff --git a/lib/compiler/src/v3_core.erl b/lib/compiler/src/v3_core.erl
@@ -92,7 +92,7 @@
 -record(icase,     {anno=#a{},args,clauses,fc}).
 -record(icatch,    {anno=#a{},body}).
 -record(iclause,   {anno=#a{},pats,pguard=[],guard,body}).
--record(ifun,      {anno=#a{},id,vars,clauses,fc}).
+-record(ifun,      {anno=#a{},id,vars,clauses,fc,name=unnamed}).
 -record(iletrec,   {anno=#a{},defs,body}).
 -record(imatch,    {anno=#a{},pat,guard=[],arg,fc}).
 -record(iprimop,   {anno=#a{},name,args}).
@@ -587,7 +587,11 @@ expr({'fun',L,{function,M,F,A}}, St0) ->
 	    name=#c_literal{val=make_fun},
 	    args=As},Aps,St1};
 expr({'fun',L,{clauses,Cs},Id}, St) ->
-    fun_tq(Id, Cs, L, St);
+    fun_tq(Id, Cs, L, St, unnamed);
+expr({named_fun,L,'_',Cs,Id}, St) ->
+    fun_tq(Id, Cs, L, St, unnamed);
+expr({named_fun,L,Name,Cs,{Index,Uniq,_Fname}}, St) ->
+    fun_tq({Index,Uniq,Name}, Cs, L, St, {named, Name});
 expr({call,L,{remote,_,M,F},As0}, #core{wanted=Wanted}=St0) ->
     {[M1,F1|As1],Aps,St1} = safe_list([M,F|As0], St0),
     Lanno = lineno_anno(L, St1),
@@ -842,9 +846,9 @@ bitstr({bin_element,_,E0,Size0,[Type,{unit,Unit}|Flags]}, St0) ->
 	       flags=#c_literal{val=Flags}},
      Eps ++ Eps2,St2}.
 
-%% fun_tq(Id, [Clauses], Line, State) -> {Fun,[PreExp],State}.
+%% fun_tq(Id, [Clauses], Line, State, NameInfo) -> {Fun,[PreExp],State}.
 
-fun_tq({_,_,Name}=Id, Cs0, L, St0) ->
+fun_tq({_,_,Name}=Id, Cs0, L, St0, NameInfo) ->
     Arity = clause_arity(hd(Cs0)),
     {Cs1,St1} = clauses(Cs0, St0),
     {Args,St2} = new_vars(Arity, St1),
@@ -853,7 +857,7 @@ fun_tq({_,_,Name}=Id, Cs0, L, St0) ->
     Fc = function_clause(Ps, Anno, {Name,Arity}),
     Fun = #ifun{anno=#a{anno=Anno},
 		id=[{id,Id}],				%We KNOW!
-		vars=Args,clauses=Cs1,fc=Fc},
+		vars=Args,clauses=Cs1,fc=Fc,name=NameInfo},
     {Fun,[],St3}.
 
 %% lc_tq(Line, Exp, [Qualifier], Mc, State) -> {LetRec,[PreExp],State}.
@@ -1711,13 +1715,18 @@ uexpr(#icase{anno=A,args=As0,clauses=Cs0,fc=Fc0}, Ks, St0) ->
     Used = union(used_in_any(As1), used_in_any(Cs1)),
     New = new_in_all(Cs1),
     {#icase{anno=A#a{us=Used,ns=New},args=As1,clauses=Cs1,fc=Fc1},St3};
-uexpr(#ifun{anno=A,id=Id,vars=As,clauses=Cs0,fc=Fc0}, Ks0, St0) ->
+uexpr(#ifun{anno=A0,id=Id,vars=As,clauses=Cs0,fc=Fc0,name=Name}, Ks0, St0) ->
     Avs = lit_list_vars(As),
-    Ks1 = union(Avs, Ks0),
-    {Cs1,St1} = ufun_clauses(Cs0, Ks1, St0),
-    {Fc1,St2} = ufun_clause(Fc0, Ks1, St1),
-    Used = subtract(intersection(used_in_any(Cs1), Ks0), Avs),
-    {#ifun{anno=A#a{us=Used,ns=[]},id=Id,vars=As,clauses=Cs1,fc=Fc1},St2};
+    Ks1 = case Name of
+              unnamed -> Ks0;
+              {named,FName} -> union(subtract([FName], Avs), Ks0)
+          end,
+    Ks2 = union(Avs, Ks1),
+    {Cs1,St1} = ufun_clauses(Cs0, Ks2, St0),
+    {Fc1,St2} = ufun_clause(Fc0, Ks2, St1),
+    Used = subtract(intersection(used_in_any(Cs1), Ks1), Avs),
+    A1 = A0#a{us=Used,ns=[]},
+    {#ifun{anno=A1,id=Id,vars=As,clauses=Cs1,fc=Fc1,name=Name},St2};
 uexpr(#iapply{anno=A,op=Op,args=As}, _, St) ->
     Used = union(lit_vars(Op), lit_list_vars(As)),
     {#iapply{anno=A#a{us=Used},op=Op,args=As},St};
@@ -2012,15 +2021,24 @@ cexpr(#itry{anno=A,args=La,vars=Vs,body=Lb,evars=Evs,handler=Lh}, As, St0) ->
 cexpr(#icatch{anno=A,body=Les}, _As, St0) ->
     {Ces,_Us1,St1} = cexprs(Les, [], St0),	%Never export!
     {#c_catch{body=Ces},[],A#a.us,St1};
-cexpr(#ifun{anno=A,id=Id,vars=Args,clauses=Lcs,fc=Lfc}, _As, St0) ->
-    {Ccs,St1} = cclauses(Lcs, [], St0),		%NEVER export!
-    {Cfc,St2} = cclause(Lfc, [], St1),
-    Anno = A#a.anno,
-    {#c_fun{anno=Id++Anno,vars=Args,
-	    body=#c_case{anno=Anno,
-			 arg=set_anno(core_lib:make_values(Args), Anno),
-			 clauses=Ccs ++ [Cfc]}},
-     [],A#a.us,St2};
+cexpr(#ifun{name=unnamed}=Fun, As, St0) ->
+    cfun(Fun, As, St0);
+cexpr(#ifun{anno=#a{us=Us0}=A0,name={named,Name},fc=#iclause{pats=Ps}}=Fun0,
+      As, St0) ->
+    case is_element(Name, Us0) of
+        false ->
+            cfun(Fun0, As, St0);
+        true ->
+            A1 = A0#a{us=del_element(Name, Us0)},
+            Fun1 = Fun0#ifun{anno=A1},
+            {#c_fun{body=Body}=CFun0,[],Us1,St1} = cfun(Fun1, As, St0),
+            RecVar = #c_var{name={Name,length(Ps)}},
+            Let = #c_let{vars=[#c_var{name=Name}],arg=RecVar,body=Body},
+            CFun1 = CFun0#c_fun{body=Let},
+            Letrec = #c_letrec{defs=[{RecVar,CFun1}],
+                               body=RecVar},
+            {Letrec,[],Us1,St1}
+    end;
 cexpr(#iapply{anno=A,op=Op,args=Args}, _As, St) ->
     {#c_apply{anno=A#a.anno,op=Op,args=Args},[],A#a.us,St};
 cexpr(#icall{anno=A,module=Mod,name=Name,args=Args}, _As, St) ->
@@ -2047,6 +2065,16 @@ cexpr(Lit, _As, St) ->
     %%Vs = lit_vars(Lit),
     {set_anno(Lit, Anno#a.anno),[],Vs,St}.
 
+cfun(#ifun{anno=A,id=Id,vars=Args,clauses=Lcs,fc=Lfc}, _As, St0) ->
+    {Ccs,St1} = cclauses(Lcs, [], St0),     %NEVER export!
+    {Cfc,St2} = cclause(Lfc, [], St1),
+    Anno = A#a.anno,
+    {#c_fun{anno=Id++Anno,vars=Args,
+            body=#c_case{anno=Anno,
+                         arg=set_anno(core_lib:make_values(Args), Anno),
+                         clauses=Ccs ++ [Cfc]}},
+     [],A#a.us,St2}.
+
 %% lit_vars(Literal) -> [Var].
 
 lit_vars(Lit) -> lit_vars(Lit, []).
diff --git a/lib/dialyzer/test/options1_SUITE_data/src/compiler/sys_expand_pmod.erl b/lib/dialyzer/test/options1_SUITE_data/src/compiler/sys_expand_pmod.erl
@@ -341,6 +341,8 @@ expr({'fun',Line,Body,Info},St) ->
 	{function,M,F,A} ->			%This is an error in lint!
 	    {'fun',Line,{function,M,F,A},Info}
     end;
+expr({named_fun,Loc,Name,Cs,Info},St) ->
+    {named_fun,Loc,Name,fun_clauses(Cs, St),Info};
 expr({call,Lc,{atom,_,new}=Name,As0},#pmod{parameters=Ps}=St)
   when length(As0) =:= length(Ps) ->
     %% The new() function does not take a 'THIS' argument (it's static).
diff --git a/lib/stdlib/examples/erl_id_trans.erl b/lib/stdlib/examples/erl_id_trans.erl
@@ -419,6 +419,8 @@ expr({'fun',Line,Body}) ->
 	    A = expr(A0),
 	    {'fun',Line,{function,M,F,A}}
     end;
+expr({named_fun,Loc,Name,Cs}) ->
+    {named_fun,Loc,Name,fun_clauses(Cs)};
 expr({call,Line,F0,As0}) ->
     %% N.B. If F an atom then call to local function or BIF, if F a
     %% remote structure (see below) then call to other module,
diff --git a/lib/stdlib/src/epp.erl b/lib/stdlib/src/epp.erl
@@ -1247,6 +1247,8 @@ macro_arg([{'case',Lc}|Toks], E, Arg) ->
     macro_arg(Toks, ['end'|E], [{'case',Lc}|Arg]);
 macro_arg([{'fun',Lc}|[{'(',_}|_]=Toks], E, Arg) ->
     macro_arg(Toks, ['end'|E], [{'fun',Lc}|Arg]);
+macro_arg([{'fun',_}=Fun,{var,_,_}=Name|[{'(',_}|_]=Toks], E, Arg) ->
+    macro_arg(Toks, ['end'|E], [Name,Fun|Arg]);
 macro_arg([{'receive',Lr}|Toks], E, Arg) ->
     macro_arg(Toks, ['end'|E], [{'receive',Lr}|Arg]);
 macro_arg([{'try',Lr}|Toks], E, Arg) ->
diff --git a/lib/stdlib/src/erl_expand_records.erl b/lib/stdlib/src/erl_expand_records.erl
@@ -344,6 +344,9 @@ expr({'fun',_,{function,_M,_F,_A}}=Fun, St) ->
 expr({'fun',Line,{clauses,Cs0}}, St0) ->
     {Cs,St1} = clauses(Cs0, St0),
     {{'fun',Line,{clauses,Cs}},St1};
+expr({named_fun,Line,Name,Cs0}, St0) ->
+    {Cs,St1} = clauses(Cs0, St0),
+    {{named_fun,Line,Name,Cs},St1};
 expr({call,Line,{atom,_,is_record},[A,{atom,_,Name}]}, St) ->
     record_test(Line, A, Name, St);
 expr({call,Line,{remote,_,{atom,_,erlang},{atom,_,is_record}},
diff --git a/lib/stdlib/src/erl_lint.erl b/lib/stdlib/src/erl_lint.erl
@@ -2030,6 +2030,15 @@ expr({'fun',Line,Body}, Vt, St) ->
 	    {Bvt, St1} = expr_list([M,F,A], Vt, St),
 	    {vtupdate(Bvt, Vt),St1}
     end;
+expr({named_fun,_,'_',Cs}, Vt, St) ->
+    fun_clauses(Cs, Vt, St);
+expr({named_fun,Line,Name,Cs}, Vt, St0) ->
+    Nvt0 = [{Name,{bound,unused,[Line]}}],
+    St1 = shadow_vars(Nvt0, Vt, 'named fun', St0),
+    Nvt1 = vtupdate(vtsubtract(Vt, Nvt0), Nvt0),
+    {Csvt,St2} = fun_clauses(Cs, Nvt1, St1),
+    {_,St3} = check_unused_vars(vtupdate(Csvt, Nvt0), [], St2),
+    {vtold(Csvt, Vt),St3};
 expr({call,_Line,{atom,_Lr,is_record},[E,{atom,Ln,Name}]}, Vt, St0) ->
     {Rvt,St1} = expr(E, Vt, St0),
     {Rvt,exist_record(Ln, Name, St1)};
@@ -2182,6 +2191,7 @@ is_valid_record(Rec) ->
         {lc, _, _, _} -> false;
         {record_index, _, _, _} -> false;
         {'fun', _, _} -> false;
+        {named_fun, _, _, _} -> false;
         _ -> true
     end.
 
diff --git a/lib/stdlib/src/erl_parse.yrl b/lib/stdlib/src/erl_parse.yrl
@@ -406,6 +406,9 @@ fun_clause -> argument_list clause_guard clause_body :
 	{Args,Pos} = '$1',
 	{clause,Pos,'fun',Args,'$2','$3'}.
 
+fun_clause -> var argument_list clause_guard clause_body :
+	{clause,element(2, '$1'),element(3, '$1'),element(1, '$2'),'$3','$4'}.
+
 try_expr -> 'try' exprs 'of' cr_clauses try_catch :
 	build_try(?line('$1'),'$2','$4','$5').
 try_expr -> 'try' exprs try_catch :
@@ -799,8 +802,15 @@ build_rule(Cs) ->
 %% build_fun(Line, [Clause]) -> {'fun',Line,{clauses,[Clause]}}.
 
 build_fun(Line, Cs) ->
+    Name = element(3, hd(Cs)),
     Arity = length(element(4, hd(Cs))),
-    {'fun',Line,{clauses,check_clauses(Cs, 'fun', Arity)}}.
+    CheckedCs = check_clauses(Cs, Name, Arity),
+    case Name of
+        'fun' ->
+            {'fun',Line,{clauses,CheckedCs}};
+        Name ->
+            {named_fun,Line,Name,CheckedCs}
+    end.
 
 check_clauses(Cs, Name, Arity) ->
      mapl(fun ({clause,L,N,As,G,B}) when N =:= Name, length(As) =:= Arity ->
diff --git a/lib/stdlib/src/erl_pp.erl b/lib/stdlib/src/erl_pp.erl
@@ -511,10 +511,17 @@ lexpr({'fun',_,{function,M,F,A}}, _Prec, Opts) ->
     ArityItem = lexpr(A, Opts),
     ["fun ",NameItem,$:,CallItem,$/,ArityItem];
 lexpr({'fun',_,{clauses,Cs}}, _Prec, Opts) ->
-    {list,[{first,'fun',fun_clauses(Cs, Opts)},'end']};
+    {list,[{first,'fun',fun_clauses(Cs, Opts, unnamed)},'end']};
+lexpr({named_fun,_,Name,Cs}, _Prec, Opts) ->
+    {list,[{first,['fun', " "],fun_clauses(Cs, Opts, {named, Name})},'end']};
 lexpr({'fun',_,{clauses,Cs},Extra}, _Prec, Opts) ->
     {force_nl,fun_info(Extra),
-     {list,[{first,'fun',fun_clauses(Cs, Opts)},'end']}};
+     {list,[{first,'fun',fun_clauses(Cs, Opts, unnamed)},'end']}};
+lexpr({named_fun,_,Name,Cs,Extra}, _Prec, Opts) ->
+    {force_nl,fun_info(Extra),
+     {list,[{first,['fun', " "],fun_clauses(Cs, Opts, {named, Name})},'end']}};
+lexpr({'query',_,Lc}, _Prec, Opts) ->
+    {list,[{step,leaf("query"),lexpr(Lc, 0, Opts)},'end']};
 lexpr({call,_,{remote,_,{atom,_,M},{atom,_,F}=N}=Name,Args}, Prec, Opts) ->
     case erl_internal:bif(M, F, length(Args)) of
         true ->
@@ -729,8 +736,13 @@ stack_backtrace(S, El, Opts) ->
 %% fun_clauses(Clauses, Opts) -> [Char].
 %%  Print 'fun' clauses.
 
-fun_clauses(Cs, Opts) ->
-    nl_clauses(fun fun_clause/2, [$;], Opts, Cs).
+fun_clauses(Cs, Opts, unnamed) ->
+    nl_clauses(fun fun_clause/2, [$;], Opts, Cs);
+fun_clauses(Cs, Opts, {named, Name}) ->
+    nl_clauses(fun (C, H) ->
+                       {step,Gl,Bl} = fun_clause(C, H),
+                       {step,[atom_to_list(Name),Gl],Bl}
+               end, [$;], Opts, Cs).
 
 fun_clause({clause,_,A,G,B}, Opts) ->
     El = args(A, Opts),
diff --git a/lib/stdlib/src/ms_transform.erl b/lib/stdlib/src/ms_transform.erl
@@ -369,6 +369,13 @@ copy({var,_Line,Name} = VarDef,Bound) ->
 copy({'fun',Line,{clauses,Clauses}},Bound) -> % Dont export bindings from funs
     {NewClauses,_IgnoredBindings} = copy_list(Clauses,Bound),
     {{'fun',Line,{clauses,NewClauses}},Bound};
+copy({named_fun,Line,Name,Clauses},Bound) -> % Dont export bindings from funs
+    Bound1 = case Name of
+                 '_' -> Bound;
+                 Name -> gb_sets:add(Name,Bound)
+             end,
+    {NewClauses,_IgnoredBindings} = copy_list(Clauses,Bound1),
+    {{named_fun,Line,Name,NewClauses},Bound};
 copy({'case',Line,Of,ClausesList},Bound) -> % Dont export bindings from funs
     {NewOf,NewBind0} = copy(Of,Bound),
     {NewClausesList,NewBindings} = copy_case_clauses(ClausesList,NewBind0,[]),
diff --git a/lib/stdlib/src/qlc_pt.erl b/lib/stdlib/src/qlc_pt.erl
@@ -2540,6 +2540,19 @@ nos({'fun',L,{clauses,Cs}}, S) ->
                {clause,Ln,H,G,B}
            end || {clause,Ln,H0,G0,B0} <- Cs],
     {{'fun',L,{clauses,NCs}}, S};
+nos({named_fun,Loc,Name,Cs}, S) ->
+    {{var,NLoc,NName}, S1} = case Name of
+                                 '_' ->
+                                     S;
+                                 Name ->
+                                     nos_pattern({var,Loc,Name}, S)
+                               end,
+    NCs = [begin
+               {H, S2} = nos_pattern(H0, S1),
+               {[G, B], _} = nos([G0, B0], S2),
+               {clause,CLoc,H,G,B}
+           end || {clause,CLoc,H0,G0,B0} <- Cs],
+    {{named_fun,NLoc,NName,NCs}, S};
 nos({lc,L,E0,Qs0}, S) ->
     %% QLCs as well as LCs. It is OK to modify LCs as long as they
     %% occur within QLCs--the warning messages have already been found
@@ -2713,6 +2726,9 @@ var2const(E) ->
 
 var_map(F, {var, _, _}=V) ->
     F(V);
+var_map(F, {named_fun,NLoc,NName,Cs}) ->
+    {var,Loc,Name} = F({var,NLoc,NName}),
+    {named_fun,Loc,Name,var_map(F, Cs)};
 var_map(F, T) when is_tuple(T) ->
     list_to_tuple(var_map(F, tuple_to_list(T)));
 var_map(F, [E | Es]) ->
diff --git a/lib/syntax_tools/src/erl_syntax.erl b/lib/syntax_tools/src/erl_syntax.erl
diff --git a/lib/tools/src/cover.erl b/lib/tools/src/cover.erl
diff --git a/lib/tools/src/xref_reader.erl b/lib/tools/src/xref_reader.erl
