New special operator: progv

Adding a progv operator, similar to the Common Lisp one.

* eval.c (progv_s): New symbol variable.
(op_progv): New static function.
(do_expand): Recognize and traverse the progv form.
(rt_progv): New static function: run-time support
for compiled progv.
(eval_init): Initialize progv_s, and register the the
op_progv operator interpreting function.

* stdlib/compilert (compiler compile): Handle progv
operator ...
(compiler comp-progv): ... via this new method.

* tests/019/progv.tl: New file.

* txr.1: Documented.

* stdlib/doc-syms.tl: Updated.

5 files changed, 185 insertions, 1 deletions

diff --git a/eval.c b/eval.c
index ab54586e..d8381d8b 100644
--- a/eval.c
+++ b/eval.c
@@ -74,7 +74,7 @@ val op_table, pm_table;
 val dyn_env;
 
 val eval_error_s, case_error_s;
-val dwim_s, progn_s, prog1_s, prog2_s, sys_blk_s;
+val dwim_s, progn_s, prog1_s, prog2_s, progv_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;
@@ -1900,6 +1900,41 @@ static val op_prog1(val form, val env)
   return eval_prog1(rest(form), env, form);
 }
 
+static val op_progv(val form, val env)
+{
+  val args = cdr(form);
+  val vars_expr = pop(&args);
+  val vals_expr = pop(&args);
+  val body = args;
+  val vars = eval(vars_expr, env, form);
+  val vals = eval(vals_expr, env, form);
+  val saved_de = dyn_env;
+  val new_env = dyn_env = make_env(nil, nil, saved_de);
+  val ret, vari, vali;
+
+  for (vari = vars, vali = vals; vari && vali;
+       vari = cdr(vari), vali = cdr(vali))
+  {
+    val var = car(vari);
+    if (!bindable(var))
+      not_bindable_error(form, var);
+    env_vbind(new_env, var, car(vali));
+  }
+
+  for (; vari; vari = cdr(vari)) {
+    val var = car(vari);
+    if (!bindable(var))
+      not_bindable_error(form, var);
+    env_vbind(new_env, var, unbound_s);
+  }
+
+  ret = eval_progn(body, env, form);
+
+  dyn_env = saved_de;
+
+  return ret;
+}
+
 static val op_let(val form, val env)
 {
   val let = first(form);
@@ -5226,6 +5261,17 @@ again:
         return car(args_ex);
       }
       return expand(first(args), menv);
+    } else if (sym == progv_s) {
+      val body = (syn_check(form, sym, cddr, 0), cdddr(form));
+      val vars = cadr(form);
+      val vals = caddr(form);
+      val vars_ex = expand(vars, menv);
+      val vals_ex = expand(vals, menv);
+      val body_ex = expand_forms(body, menv);
+
+      if (vars_ex == vars && vals_ex == vals && body_ex == body)
+        return form;
+      return rlcp(cons(sym, cons(vars_ex, cons(vals_ex, body_ex))), form);
     } else if (sym == sys_lisp1_value_s) {
       return expand_lisp1_value(form, menv);
     } else if (sym == sys_lisp1_setq_s) {
@@ -5859,6 +5905,22 @@ static val set_symbol_value(val sym, val value)
   return value;
 }
 
+static val rt_progv(val syms, val values)
+{
+  val env = dyn_env;
+
+  for (; syms; syms = cdr(syms), values = cdr(values))
+  {
+    val sym = car(syms);
+    val value = if3(values, car(values), unbound_s);
+    if (!bindable(sym))
+      uw_throwf(error_s, lit("progv: ~s isn't a bindable symbol"), sym, nao);
+    env_vbind(env, sym, value);
+  }
+
+  return nil;
+}
+
 static val symbol_function(val sym)
 {
   uses_or2;
@@ -6829,6 +6891,7 @@ void eval_init(void)
   progn_s = intern(lit("progn"), user_package);
   prog1_s = intern(lit("prog1"), user_package);
   prog2_s = intern(lit("prog2"), user_package);
+  progv_s = intern(lit("progv"), user_package);
   sys_blk_s = intern(lit("blk"), system_package);
   let_s = intern(lit("let"), user_package);
   let_star_s = intern(lit("let*"), user_package);
@@ -6965,6 +7028,7 @@ void eval_init(void)
   reg_op(sys_splice_s, op_unquote_error);
   reg_op(progn_s, op_progn);
   reg_op(prog1_s, op_prog1);
+  reg_op(progv_s, op_progv);
   reg_op(let_s, op_let);
   reg_op(each_op_s, op_each);
   reg_op(let_star_s, op_let);
@@ -7680,6 +7744,7 @@ void eval_init(void)
 
   reg_fun(intern(lit("rt-defvarl"), system_package), func_n1(rt_defvarl));
   reg_fun(intern(lit("rt-defv"), system_package), func_n1(rt_defv));
+  reg_fun(intern(lit("rt-progv"), system_package), func_n2(rt_progv));
   reg_fun(intern(lit("rt-defun"), system_package), func_n2(rt_defun));
   reg_fun(intern(lit("rt-defmacro"), system_package), func_n3(rt_defmacro));
   reg_fun(intern(lit("rt-defsymacro"), system_package), func_n2(rt_defsymacro));
diff --git a/stdlib/compiler.tl b/stdlib/compiler.tl
index cdbd3a3f..cc4eef7b 100644
--- a/stdlib/compiler.tl
+++ b/stdlib/compiler.tl
@@ -531,6 +531,7 @@
               (and me.(compile oreg env (expand-and form)))
               (or me.(comp-or oreg env form))
               (prog1 me.(comp-prog1 oreg env form))
+              (progv me.(comp-progv oreg env form))
               (sys:quasi me.(comp-quasi oreg env form))
               (dohash me.(compile oreg env (expand-dohash form)))
               (tree-bind me.(comp-tree-bind oreg env form))
@@ -1324,6 +1325,32 @@
     ((t fi) me.(compile oreg env fi))
     ((t) me.(compile oreg env nil))))
 
+(defmeth compiler comp-progv (me oreg env form)
+  (tree-case form
+    ((t syms vals)
+     me.(comp-progn oreg env ^(progn ,syms ,vals nil)))
+    ((t syms vals . body)
+     (let* ((denv (new env up env co me))
+            (sreg me.(alloc-treg))
+            (vreg me.(alloc-treg))
+            (sfrag me.(compile sreg env syms))
+            (vfrag me.(compile vreg env vals))
+            (bfrag me.(comp-progn oreg denv body)))
+       me.(free-treg sreg)
+       me.(free-treg vreg)
+       (new (frag bfrag.oreg
+                  (append sfrag.code
+                          vfrag.code
+                          ^((dframe ,denv.lev 0)
+                            (gcall ,oreg
+                                   ,me.(get-sidx 'sys:rt-progv)
+                                   ,sfrag.oreg
+                                   ,vfrag.oreg))
+                          bfrag.code
+                          '((end nil)))
+                  (uni sfrag.fvars (uni vfrag.fvars bfrag.fvars))
+                  (uni sfrag.ffuns (uni vfrag.ffuns bfrag.ffuns))))))))
+
 (defmeth compiler comp-quasi (me oreg env form)
   (let ((qexp (expand-quasi form)))
     me.(compile oreg env (expand qexp))))
diff --git a/stdlib/doc-syms.tl b/stdlib/doc-syms.tl
index f3e6e9b7..8dbadf88 100644
--- a/stdlib/doc-syms.tl
+++ b/stdlib/doc-syms.tl
@@ -1504,6 +1504,7 @@
       ("prog1" "N-03F7A8B8")
       ("prog2" "N-03A0E48C")
       ("progn" "N-03F7A8B8")
+      ("progv" "N-033405DF")
       ("promisep" "N-00C7553F")
       ("prop" "N-01C6D406")
       ("proper-list-p" "N-03F70343")
diff --git a/tests/019/progv.tl b/tests/019/progv.tl
new file mode 100644
index 00000000..7ab3aafe
--- /dev/null
+++ b/tests/019/progv.tl
@@ -0,0 +1,29 @@
+(load "../common")
+
+(defvar a 42)
+(defvar b 73)
+
+(mtest
+  (progv '(a) '(1) a) 1
+  (progv '(a b) '(1 2) (cons a b)) (1 . 2)
+  (progv '(x) '(1) (let ((x 4)) (symbol-value 'x))) 1)
+
+(let ((n (list 'a 'b))
+      (v (list 1 2)))
+  (mtest
+    (progv n v (cons a b)) (1 . 2)))
+
+(defvarl x)
+
+(let ((x 'lexical)
+     (vars (list 'x))
+     (vals (list 'dynamic)))
+  (test
+    (progv vars vals (list x (symbol-value 'x)))
+    (lexical dynamic)))
+
+(compile-only
+  (eval-only
+    (with-compile-opts (nil unused)
+      (compile-file (base-name *load-path*) "temp.tlo"))
+    (remove-path "temp.tlo")))
diff --git a/txr.1 b/txr.1
index f0558d16..539c95b2 100644
--- a/txr.1
+++ b/txr.1
@@ -15060,6 +15060,68 @@ closures, but are captured in delimited continuations.
   (let (:a nil)) -> error, :a and nil can't be used as variables
 .brev
 
+.coNP Operator @ progv
+.synb
+.mets (progv < symbols-expr < values-expr << body-form *)
+.syne
+.desc
+The
+.code progv
+operator binds dynamic variables, and evaluates the
+.metn body-form s
+in the dynamic scope of those bindings. The bindings are removed
+when the form terminates. The result value is that of the
+last
+.meta body-form
+or else
+.code nil
+if there are no forms.
+
+The
+.meta symbols-expr
+and
+.meta values-expr
+are expressions which are evaluated. Their values are expected
+to be lists, of bindable symbols and arbitrary values, respectively.
+The symbols coming from one list are bound to the values coming
+from the other list.
+
+If there are more symbols than values, then the extra symbols
+will appear unbound, as if they were first bound and then hidden
+using the
+.code makunbound
+function.
+
+If there are more values than symbols, the extra values are ignored.
+
+Note that dynamic binding takes place for the symbols even if they
+have not been introduced as special variables via
+.code defvar
+or
+.codn defparm .
+However, if those symbols appear as expressions denoting variables inside the
+.metn body-form s,
+they will not necessarily be treated as dynamic variables.
+If they have lexical definitions in scope, those will be referenced.
+Furthermore, the compiler treats undefined variables as global
+references, and not dynamic.
+
+.TP* Examples:
+
+.verb
+
+  (progv '(a b) '(1 2) (cons a b))  ->  (1 . 2)
+
+  (progv '(x) '(1) (let ((x 4)) (symbol-value 'x))) -> 1
+
+  (let ((x 'lexical)
+        (vars (list 'x))
+        (vals (list 'dynamic)))
+    (progv vars vals (list x (symbol-value 'x))))
+
+  --> (lexical dynamic)
+.brev
+
 .SS* Functions
 .coNP Operator @ defun
 .synb