From 0515d6ee6af5f16a951f7dd61ddc3f3e2cd0e562 Mon Sep 17 00:00:00 2001
From: Kaz Kylheku <kaz@kylheku.com>
Date: Sun, 25 Jan 2015 16:35:34 -0800
Subject: * eval.c (call_f): new global variable. (do_mapf, mapf): new static
 functions. (eval_init): protect call_f from gc, and initialize it.
 re-register call function using call_f. register mapf intrinsic.

* txr.1: Documented mapf.
---
 ChangeLog | 10 ++++++++++
 eval.c    | 21 +++++++++++++++++++--
 txr.1     | 45 +++++++++++++++++++++++++++++++++++++++++++++
 3 files changed, 74 insertions(+), 2 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index 5d6958b3..d8be7df6 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,13 @@
+2015-01-25  Kaz Kylheku  <kaz@kylheku.com>
+
+	* eval.c (call_f): New global variable.
+	(do_mapf, mapf): New static functions.
+	(eval_init): Protect call_f from gc, and initialize it.
+	Re-register call function using call_f.
+	Register mapf intrinsic.
+
+	* txr.1: Documented mapf.
+
 2015-01-25  Kaz Kylheku  <kaz@kylheku.com>
 
 	* eval.c (eval_init): Register dupl and swap_12_21 as
diff --git a/eval.c b/eval.c
index 4929973a..48925f79 100644
--- a/eval.c
+++ b/eval.c
@@ -89,6 +89,8 @@ val special_s, whole_k;
 
 val last_form_evaled;
 
+val call_f;
+
 val make_env(val vbindings, val fbindings, val up_env)
 {
   val env = make_obj();
@@ -3462,6 +3464,18 @@ static val callf(val func, val funlist)
   return chain(juxt_fun, apf_fun, nao);
 }
 
+static val do_mapf(val env, val args)
+{
+  cons_bind (fun, funlist, env);
+  val mapped_args = mapcarv(call_f, cons(funlist, cons(args, nil)));
+  return apply(fun, mapped_args, nil);
+}
+
+static val mapf(val fun, val funlist)
+{
+  return func_f0v(cons(fun, funlist), do_mapf);
+}
+
 static val prinl(val obj, val stream)
 {
   val ret = obj_print(obj, stream);
@@ -3500,7 +3514,7 @@ static val merge_wrap(val seq1, val seq2, val lessfun, val keyfun)
 void eval_init(void)
 {
   protect(&top_vb, &top_fb, &top_mb, &top_smb, &special, &dyn_env,
-          &op_table, &last_form_evaled, convert(val *, 0));
+          &op_table, &last_form_evaled, &call_f, convert(val *, 0));
   top_fb = make_hash(t, nil, nil);
   top_vb = make_hash(t, nil, nil);
   top_mb = make_hash(t, nil, nil);
@@ -3508,6 +3522,8 @@ void eval_init(void)
   special = make_hash(t, nil, nil);
   op_table = make_hash(nil, nil, nil);
 
+  call_f = func_n1v(call);
+
   dwim_s = intern(lit("dwim"), user_package);
   progn_s = intern(lit("progn"), user_package);
   prog1_s = intern(lit("prog1"), user_package);
@@ -3709,7 +3725,7 @@ void eval_init(void)
   reg_fun(intern(lit("mapdo"), user_package), func_n1v(mapdov));
   reg_fun(apply_s, func_n1v(apply_intrinsic));
   reg_fun(iapply_s, func_n1v(iapply));
-  reg_fun(call_s, func_n1v(call));
+  reg_fun(call_s, call_f);
   reg_fun(intern(lit("reduce-left"), user_package), func_n4o(reduce_left, 2));
   reg_fun(intern(lit("reduce-right"), user_package), func_n4o(reduce_right, 2));
   reg_fun(intern(lit("transpose"), user_package), func_n1(transpose));
@@ -3912,6 +3928,7 @@ void eval_init(void)
   reg_fun(apf_s, func_n1(apf));
   reg_fun(ipf_s, func_n1(ipf));
   reg_fun(intern(lit("callf"), user_package), func_n1v(callf));
+  reg_fun(intern(lit("mapf"), user_package), func_n1v(mapf));
   reg_fun(intern(lit("tf"), user_package), func_n0v(tf));
   reg_fun(intern(lit("nilf"), user_package), func_n0v(nilf));
 
diff --git a/txr.1 b/txr.1
index 29e9fa7b..668a12c9 100644
--- a/txr.1
+++ b/txr.1
@@ -21477,6 +21477,51 @@ arguments:
   -> ((1 1) (4 4))
 .cble
 
+.coNP Function @ mapf
+.synb
+.mets (mapf < main-function << arg-function *)
+.syne
+.desc
+The
+.code mapf
+function returns a function which distributes its arguments
+into the
+.metn arg-function -s.
+That is to say, each successive argument of the returned
+function is associated with a successive
+.metn arg-function .
+
+Each
+.metn arg-function
+is called, passed the corresponding argument. The return
+values of these functions are then passd as arguments
+to
+.meta main function
+and the resulting value is returned.
+
+If the returned function is calle with fewer arguments than there
+are
+.metn arg-function -s,
+then only that many functions are used. Conversely, if the function is
+called with more arguments than there are
+.metn arg-function -s, then those arguments are ignored.
+
+The following equivalence holds:
+
+.cblk
+  (mapf fm f0 f1 ...) <--> (lambda (. rest)
+                              [apply fm [mapcar call (list f0 f1 ...) rest]])
+.cble
+
+.TP* Example:
+
+.cblk
+  ;; Keep those pairs which are two of a kind
+
+  (keep-if [callf eql first second] '((1 1) (2 3) (4 4) (5 6)))
+  -> ((1 1) (4 4))
+.cble
+
 .SS* Input and Output (Streams)
 \*(TL supports input and output streams of various kinds, with
 generic operations that work across the stream types.
-- 
cgit v1.2.3