* eval.c (iapply_s): new global variable.

(iapply, me_ip): new static functions.
(do_apf): Bugfix: use apply_intrinsic, not apply.
(do_ipf, ipf): New static functions.
(eval_init): initialize iapply_s. register me_ip macro
expander, and the iapply and ipf functions.

* txr.1: Documented iapply, ipf and ip.

3 files changed, 88 insertions, 8 deletions

diff --git a/ChangeLog b/ChangeLog
index b69ea1f9..3a6881d5 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,14 @@
+2014-06-26  kaz kylheku  <kaz@kylheku.com>
+
+	* eval.c (iapply_s): new global variable.
+	(iapply, me_ip): new static functions.
+	(do_apf): Bugfix: use apply_intrinsic, not apply.
+	(do_ipf, ipf): New static functions.
+	(eval_init): initialize iapply_s. register me_ip macro
+	expander, and the iapply and ipf functions.
+
+	* txr.1: Documented iapply, ipf and ip.
+
 2014-06-26  Kaz Kylheku  <kaz@kylheku.com>
 
 	* lib.c (last): Bugfix: reversed null test.
diff --git a/eval.c b/eval.c
index f3a9dd19..f113d879 100644
--- a/eval.c
+++ b/eval.c
@@ -78,7 +78,8 @@ val for_s, for_star_s, each_s, each_star_s, collect_each_s, collect_each_star_s;
 val append_each_s, append_each_star_s;
 val dohash_s;
 val uw_protect_s, return_s, return_from_s;
-val list_s, append_s, apply_s, gen_s, gun_s, generate_s, rest_s, plus_s;
+val list_s, append_s, apply_s, iapply_s;
+val gen_s, gun_s, generate_s, rest_s, plus_s;
 val promise_s, op_s, identity_s;
 val hash_lit_s, hash_construct_s;
 val vector_lit_s, vector_list_s;
@@ -659,6 +660,31 @@ val apply_intrinsic(val fun, val args)
   return apply(fun, apply_frob_args(args), nil);
 }
 
+static val iapply(val fun, val args)
+{
+  if (args && atom(args)) {
+    args = cons(args, nil);
+  } else {
+    loc plast = lastcons(args);
+    if (!nullocp(plast)) {
+      deref(plast) = car(deref(plast));
+    } else {
+      args = car(args);
+    }
+
+    if (args && atom(args)) {
+      args = cons(args, nil);
+    } else if (args) {
+      val la = last(args);
+      val cd = cdr(la);
+      if (cd && atom(cd))
+        rplacd(la, cons(cd, nil));
+    }
+  }
+
+  return apply(fun, args, nil);
+}
+
 static val call(val fun, val args)
 {
   return apply(fun, args, cons(apply_s, nil));
@@ -2395,6 +2421,13 @@ static val me_ap(val form, val menv)
               list(apply_s, cons(op_s, rest(form)), args, nao), nao);
 }
 
+static val me_ip(val form, val menv)
+{
+  val args = gensym(lit("args-"));
+  return list(lambda_s, cons(args, nil),
+              list(iapply_s, cons(op_s, rest(form)), args, nao), nao);
+}
+
 static val me_ret(val form, val menv)
 {
   return cons(op_s, cons(identity_s, rest(form)));
@@ -3120,7 +3153,7 @@ static val retf(val ret)
 
 static val do_apf(val fun, val args)
 {
-  return apply(fun, args, nil);
+  return apply_intrinsic(fun, args);
 }
 
 static val apf(val fun)
@@ -3128,6 +3161,16 @@ static val apf(val fun)
   return func_f1(fun, do_apf);
 }
 
+static val do_ipf(val fun, val args)
+{
+  return iapply(fun, args);
+}
+
+static val ipf(val fun)
+{
+  return func_f1(fun, do_ipf);
+}
+
 static val prinl(val obj, val stream)
 {
   val ret = obj_print(obj, stream);
@@ -3194,6 +3237,7 @@ void eval_init(void)
   list_s = intern(lit("list"), user_package);
   append_s = intern(lit("append"), user_package);
   apply_s = intern(lit("apply"), user_package);
+  iapply_s = intern(lit("iapply"), user_package);
   gen_s = intern(lit("gen"), user_package);
   gun_s = intern(lit("gun"), user_package);
   generate_s = intern(lit("generate"), user_package);
@@ -3269,6 +3313,7 @@ void eval_init(void)
   reg_mac(op_s, me_op);
   reg_mac(do_s, me_op);
   reg_mac(intern(lit("ap"), user_package), me_ap);
+  reg_mac(intern(lit("ip"), user_package), me_ip);
   reg_mac(intern(lit("ret"), user_package), me_ret);
   reg_mac(qquote_s, me_qquote);
   reg_mac(sys_qquote_s, me_qquote);
@@ -3312,6 +3357,7 @@ void eval_init(void)
   reg_fun(intern(lit("mappend"), user_package), func_n1v(mappendv));
   reg_fun(intern(lit("mappend*"), user_package), func_n1v(lazy_mappendv));
   reg_fun(apply_s, func_n1v(apply_intrinsic));
+  reg_fun(iapply_s, func_n1v(iapply));
   reg_fun(call_s, func_n1v(call));
   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));
@@ -3484,6 +3530,7 @@ void eval_init(void)
   reg_fun(intern(lit("and"), user_package), func_n0v(and_fun));
   reg_fun(intern(lit("retf"), user_package), func_n1(retf));
   reg_fun(intern(lit("apf"), user_package), func_n1(apf));
+  reg_fun(intern(lit("ipf"), user_package), func_n1(ipf));
   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 c90771f0..8e021b5a 100644
--- a/txr.1
+++ b/txr.1
@@ -8153,12 +8153,13 @@ can be expressed as:
 
   (mapcar function (conses list0) (conses list1) ... (conses listn))
 
-.SS Function apply
+.SS Functions apply and iapply
 
 .TP
 Syntax:
 
   (apply <function> [ <arg>* <trailing-args> ])
+  (iapply <function> [ <arg>* <trailing-args> ])
 
 .TP
 Description:
@@ -8180,6 +8181,16 @@ these arguments is interpreted as <trailing-args>. The previous arguments
 represent leading arguments which are applied to <function>, prior to the
 arguments taken from <trailing-args>.
 
+The iapply function ("improper apply") is similar to apply, except with regard
+to the treatment of <trailing-args>. Firstly, under iapply, if <trailing-args>
+is an atom other than nil (possibly a sequence, such as a vector or string),
+then it is treated as an ordinary argument: <function> is invoked with a proper
+argument list, whose last element is <trailing-args>.  Secondly, if
+<trailing-args> is a list, but an improper list, then the terminating atom of
+<trailing-args> becomes an ordinary argument. Thus, in all possible cases,
+iapply treats an extra non-nil atom as an argument, and never calls
+<function> with an improper argument list.
+
 .TP
 Examples:
 
@@ -12003,12 +12014,13 @@ is the first argument of the inner function. Of course, if there
 are three levels of nesting, then three metas are needed to insert
 a parameter from the outermost op, into the innermost op.
 
-.SS Macro ap
+.SS Macros ap and ip
 
 .TP
 Syntax:
 
   (ap <form>+)
+  (ip <form>+)
 
 .TP
 Description:
@@ -12016,7 +12028,7 @@ Description:
 The ap macro is based on the op macro and has identical argument
 conventions.
 
-The ap macro analyzes its argumetns and produces a function, in exactly the
+The ap macro analyzes its arguments and produces a function, in exactly the
 same same way as the op macro.   It then returns a different one-argument
 function which accepts a list, and calls that function, applying the
 list as arguments.
@@ -12030,7 +12042,13 @@ except that the symbol args is to be understood as a generated symbol (gensym).
 The ap macro nests properly with op and do, in any combination, in regard
 to the @@n notation.
 
-See also: the apf function.
+The ip macro is very similar to the ap macro, except that it is based
+on the semantics of the function iapply rather than apply, according
+to the following equivalence:
+
+  (ap form ...) <--> (lambda (args) (iapply (op form ...)))
+
+See also: the apf function
 
 .SS Macro ret
 
@@ -12232,21 +12250,25 @@ Example:
   ;; the function returned by (retf 42) ignores 1 2 3 and returns 42.
   (call (retf 42) 1 2 3) -> 42
 
-.SH Function apf
+.SH Functions apf and ipf
 
 .TP
 Syntax:
 
   (apf <function>)
+  (ipf <function>)
 
 .TP
 Description:
 
 The apf function returns a one-argument function which accepts
 a list. When the function is called, it treats the list as
-argument which are applied to <function>. It returns whatever
+argument which are applied to <function> as if by apply. It returns whatever
 <function> returns.
 
+The ipf function is similar to apf, except that the returned
+function applies arguments as if by iapply rather than apply.
+
 See also: the ap macro.
 
 .TP