compile/eval: new operator, mac-env-param-bind.

mac-env-param-bind is like mac-param-bind but also allows
the value for the :env parameter to be specified.

* eval.c (op_mac_env_param_bind_s): New sy mbol variable.
(op_mac_env_param_bind): New static function.
(do_expand): Handle mac_env_param_bind_s.
(eval_init): Initialize symbol variable and register macro.

* share/txr/stdlib/compiler.tl (compiler compile): Add case
for mac-env-param-bind.
(compiler comp-mac-env-param-bind): New method.

* share/txr/stdlib/doc-syms.tl: Updated with new hashes for
tree-bind and mac-param-bind, and inclusion of
mac-env-param-bind.

* tests/012/binding.tl: New file.

* txr.1: Documented.

5 files changed, 117 insertions, 13 deletions

diff --git a/eval.c b/eval.c
index 90ec43af..5983f2cd 100644
--- a/eval.c
+++ b/eval.c
@@ -77,7 +77,7 @@ val dwim_s, progn_s, prog1_s, prog2_s, sys_blk_s;
 val let_s, let_star_s, lambda_s, call_s, dvbind_s;
 val sys_catch_s, handler_bind_s, cond_s, if_s, iflet_s, when_s, usr_var_s;
 val defvar_s, defvarl_s, defparm_s, defparml_s, defun_s, defmacro_s, macro_s;
-val tree_case_s, tree_bind_s, mac_param_bind_s;
+val tree_case_s, tree_bind_s, mac_param_bind_s, mac_env_param_bind_s;
 val sys_mark_special_s;
 val caseq_s, caseql_s, casequal_s;
 val caseq_star_s, caseql_star_s, casequal_star_s;
@@ -2365,6 +2365,23 @@ static val op_mac_param_bind(val form, val env)
   return ret;
 }
 
+static val op_mac_env_param_bind(val form, val env)
+{
+  val body = cdr(form);
+  val ctx_form = pop(&body);
+  val menv = pop(&body);
+  val params = pop(&body);
+  val expr = pop(&body);
+  val ctx_val = eval(ctx_form, env, ctx_form);
+  val menv_val = eval(menv, env, menv);
+  val expr_val = eval(expr, env, expr);
+  val saved_de = dyn_env;
+  val new_env = bind_macro_params(env, menv_val, params, expr_val, nil, ctx_val);
+  val ret = eval_progn(body, new_env, body);
+  dyn_env = saved_de;
+  return ret;
+}
+
 static val op_setq(val form, val env)
 {
   val args = rest(form);
@@ -4774,9 +4791,13 @@ again:
       }
     } else if (sym == tree_case_s) {
       return expand_tree_case(form, menv);
-    } else if (sym == tree_bind_s || sym == mac_param_bind_s) {
+    } else if (sym == tree_bind_s || sym == mac_param_bind_s ||
+               sym == mac_env_param_bind_s)
+    {
       val args = rest(form);
-      val ctx_expr = if3(sym == mac_param_bind_s, pop(&args), nil);
+      val ctx_expr = if3(sym == mac_param_bind_s || sym == mac_env_param_bind_s,
+                         pop(&args), nil);
+      val menvarg = if3(sym == mac_env_param_bind_s, pop(&args), nil);
       val params = pop(&args);
       val expr = pop(&args);
       val body = args;
@@ -4784,9 +4805,20 @@ again:
                  expand_params(params, body, menv, t, form));
       val new_menv = make_var_shadowing_env(menv, get_param_syms(params_ex));
       val ctx_expr_ex = expand(ctx_expr, menv);
+      val menvarg_ex = expand(menvarg, menv);
       val body_ex = expand_progn(body_ex0, new_menv);
       val expr_ex = expand(expr, new_menv);
 
+      if (sym == mac_env_param_bind_s) {
+        if (ctx_expr_ex == ctx_expr && params_ex == params &&
+            menvarg_ex == menvarg && expr_ex == expr && body_ex == body)
+          return form;
+        return rlcp(cons(sym, cons(ctx_expr_ex,
+                                   cons(menvarg_ex,
+                                        cons(params_ex,
+                                             cons(expr_ex, body_ex))))), form);
+      }
+
       if (sym == mac_param_bind_s) {
         if (ctx_expr_ex == ctx_expr && params_ex == params &&
             expr_ex == expr && body_ex == body)
@@ -6361,6 +6393,7 @@ void eval_init(void)
   tree_case_s = intern(lit("tree-case"), user_package);
   tree_bind_s = intern(lit("tree-bind"), user_package);
   mac_param_bind_s = intern(lit("mac-param-bind"), user_package);
+  mac_env_param_bind_s = intern(lit("mac-env-param-bind"), user_package);
   setq_s = intern(lit("setq"), system_package);
   sys_lisp1_setq_s = intern(lit("lisp1-setq"), system_package);
   sys_lisp1_value_s = intern(lit("lisp1-value"), system_package);
@@ -6471,6 +6504,7 @@ void eval_init(void)
   reg_op(tree_case_s, op_tree_case);
   reg_op(tree_bind_s, op_tree_bind);
   reg_op(mac_param_bind_s, op_mac_param_bind);
+  reg_op(mac_env_param_bind_s, op_mac_env_param_bind);
   reg_op(setq_s, op_setq);
   reg_op(sys_lisp1_setq_s, op_lisp1_setq);
   reg_op(sys_lisp1_value_s, op_lisp1_value);
diff --git a/share/txr/stdlib/compiler.tl b/share/txr/stdlib/compiler.tl
index 88612e60..127d68af 100644
--- a/share/txr/stdlib/compiler.tl
+++ b/share/txr/stdlib/compiler.tl
@@ -506,6 +506,7 @@
               (dohash me.(compile oreg env (expand-dohash form)))
               (tree-bind me.(comp-tree-bind oreg env form))
               (mac-param-bind me.(comp-mac-param-bind oreg env form))
+              (mac-env-param-bind me.(comp-mac-env-param-bind oreg env form))
               (tree-case me.(comp-tree-case oreg env form))
               (sys:lisp1-value me.(comp-lisp1-value oreg env form))
               (dwim me.(comp-dwim oreg env form))
@@ -1498,6 +1499,17 @@
                                                       obj-var t nil body)))))
         me.(compile oreg env expn)))))
 
+(defmeth compiler comp-mac-env-param-bind (me oreg env form)
+  (mac-param-bind form (op context menv params obj . body) form
+    (with-gensyms (obj-var form-var)
+      (let ((expn (expand ^(let* ((,obj-var ,obj)
+                                  (,form-var ,context))
+                             ,(expand-bind-mac-params form-var
+                                                      form-var
+                                                      params menv
+                                                      obj-var t nil body)))))
+        me.(compile oreg env expn)))))
+
 (defmeth compiler comp-tree-case (me oreg env form)
   (mac-param-bind form (op obj . cases) form
     (let* ((ncases (len cases))
diff --git a/share/txr/stdlib/doc-syms.tl b/share/txr/stdlib/doc-syms.tl
index b980e6b3..64ad54dd 100644
--- a/share/txr/stdlib/doc-syms.tl
+++ b/share/txr/stdlib/doc-syms.tl
@@ -931,7 +931,7 @@
      ("o-rdwr" "N-034BF6C9")
      ("len" "N-03AD172A")
      ("progn" "N-03F7A8B8")
-     ("tree-bind" "N-00A580D9")
+     ("tree-bind" "N-021A9008")
      ("tb" "N-02AB6E53")
      ("rpos" "N-01F68300")
      ("buf-get-int" "N-03C7C985")
@@ -1150,6 +1150,7 @@
      ("make-random-state" "N-032BEE6C")
      ("dir-name" "N-02C01721")
      ("rfind-if" "N-0301CDB6")
+     ("mac-env-param-bind" "N-021A9008")
      ("scan" "N-03E989D0")
      ("vmin" "N-01812D70")
      ("copy-list" "N-006ED237")
@@ -1712,7 +1713,7 @@
      ("indent-foff" "N-00512FDD")
      ("env-fbindings" "N-0018DCDC")
      ("keep-if*" "N-01413802")
-     ("mac-param-bind" "N-00A580D9")
+     ("mac-param-bind" "N-021A9008")
      ("ignerr" "N-007287AC")
      (":match" "N-03B92C0D")
      ("set-max-length" "N-031FA9E5")
diff --git a/tests/012/binding.tl b/tests/012/binding.tl
new file mode 100644
index 00000000..59c1ff04
--- /dev/null
+++ b/tests/012/binding.tl
@@ -0,0 +1,5 @@
+(load "../common")
+
+(test
+  (mac-env-param-bind '(foo) 42 (:env e :form f x y) '(1 2) (list x y e f))
+  (1 2 42 (foo)))
diff --git a/txr.1 b/txr.1
index 34b68440..3cd95a38 100644
--- a/txr.1
+++ b/txr.1
@@ -37075,11 +37075,13 @@ The
 operator is a mongrel of these two semantics: it permits expansion to proceed,
 but then suppresses evaluation of the result.
 
-.coNP Operators @ tree-bind and @ mac-param-bind
+.coNP Operators @, tree-bind @ mac-param-bind and @ mac-env-param-bind
 .synb
 .mets (tree-bind < macro-style-params < expr << form *)
 .mets (mac-param-bind < context-expr
 .mets \ \  < macro-style-params < expr << form *)
+.mets (mac-env-param-bind < context-expr < env-expr
+.mets \ \  < macro-style-params < expr << form *)
 .syne
 .desc
 The
@@ -37097,13 +37099,15 @@ of the last
 is returned. If there are no forms,
 .code nil
 is returned.
-
-Note: this operator throws an exception if there is a
-structural mismatch between the parameters and the value of
-.codn expr .
-
-One way to avoid this exception is to use
-.codn tree-case .
+Under
+.codn tree-bind ,
+the value of the
+.code :form
+available to
+.meta macro-style-params
+is the
+.code tree-bind
+form itself.
 
 The
 .code mac-param-bind
@@ -37120,6 +37124,54 @@ operator's error diagnostic refers to the
 .code tree-bind
 form, which is cryptic if the binding is used for the implementation
 of some other construct, hidden from the user of that construct.
+In addition,
+.meta context-expr
+specifies the value for the
+.code :form
+parameter that
+.meta macro-style-params
+may refer to.
+
+The
+.code mac-env-param-bind
+is an extension of
+.code mac-param-bind
+which takes one more argument,
+.codn env-expr ,
+before the macro parameters. This expression is evaluated,
+and becomes the value of the
+.code :env
+parameter that
+.meta macro-style-params
+may refer to.
+
+Under
+.code tree-bind
+and
+.codn mac-param-bind ,
+the
+.code :env
+parameter takes on the value
+.codn nil .
+
+Under all three operators, the
+.code :whole
+parameter takes on the value of
+.metn expr .
+
+These operators throw an exception if there is a
+structural mismatch between the parameters and the value of
+.codn expr .
+One way to avoid this exception is to use
+.codn tree-case ,
+which is based on the conventions of
+.codn tree-bind .
+There exists no
+.code tree-case
+analog for
+.code mac-param-bind
+or
+.codn mac-env-param-bind .
 
 .coNP Operator @ tree-case
 .synb