New special operator: compiler-let

* eval.c (compiler_let_s): New symbol variable.
(op_let): Recognize compiler-let for sequential
binding.
(do_expand): Traverse and diagnose compiler-let
form.
(eval_init): Initialize compiler_let_s and register
the interpreted version of the operator.

* stdlib/compiler.tl (compiler compile): Handle
compiler-let form.
(compiler comp-compiler-let): New method.
(no-dvbind-eval): New function.

* autoload.c (compiler-set-entries): Intern the
compiler-let symbol in the user package.

* txr.1: Documented.

* stdlib/doc-syms.tl: Updated.

5 files changed, 87 insertions, 3 deletions

diff --git a/autoload.c b/autoload.c
index 002ddee4..0f0f3039 100644
--- a/autoload.c
+++ b/autoload.c
@@ -660,7 +660,7 @@ static val compiler_set_entries(val fun)
     lit("compile-toplevel"), lit("compile"), lit("compile-file"),
     lit("compile-update-file"),
     lit("with-compilation-unit"), lit("dump-compiled-objects"),
-    lit("with-compile-opts"),
+    lit("with-compile-opts"), lit("compiler-let"),
     nil
   };
   val vname[] = {
diff --git a/eval.c b/eval.c
index d8381d8b..f8ecb236 100644
--- a/eval.c
+++ b/eval.c
@@ -104,7 +104,7 @@ val defsymacro_s, symacrolet_s, prof_s, switch_s, struct_s;
 val fbind_s, lbind_s, flet_s, labels_s;
 val load_path_s, load_hooks_s, load_recursive_s, load_search_dirs_s;
 val load_time_s, load_time_lit_s;
-val eval_only_s, compile_only_s;
+val eval_only_s, compile_only_s, compiler_let_s;
 val const_foldable_s;
 val pct_fun_s;
 
@@ -1937,12 +1937,14 @@ static val op_progv(val form, val env)
 
 static val op_let(val form, val env)
 {
+  uses_or2;
   val let = first(form);
   val args = rest(form);
   val vars = first(args);
   val body = rest(args);
   val saved_de = dyn_env;
-  val new_env = bindings_helper(vars, env, eq(let, let_star_s), nil, form);
+  val sequential = or2(eq(let, let_star_s), eq(let, compiler_let_s));
+  val new_env = bindings_helper(vars, env, sequential, nil, form);
   val ret = eval_progn(body, new_env, form);
   dyn_env = saved_de;
   return ret;
@@ -5280,6 +5282,26 @@ again:
       return expand_setqf(form, menv);
     } else if (sym == var_s || sym == expr_s) {
       return form;
+    } else if (sym == compiler_let_s) {
+      val body = (syn_check(form, sym, cdr, 0), rest(rest(form)));
+      val vars = second(form);
+      val body_ex = expand_progn(body, menv);
+      val vars_ex = expand_vars(vars, nil, form, 0);
+      {
+        val var;
+        for (var = vars_ex; var; var = cdr(var)) {
+          val var_init = car(var);
+          if (!consp(var_init))
+            eval_warn(form, lit("~s: not a var-init form: ~s"),
+                      sym, var_init, nao);
+          else if (!special_var_p(car(var_init)))
+            eval_warn(form, lit("~s: ~s is required to be a special variable"),
+                      sym, car(var_init), nao);
+        }
+      }
+      if (body == body_ex)
+        return form;
+      return rlcp(cons(sym, cons(vars_ex, body_ex)), form);
     } else {
       /* funtion call expansion also handles: prog1, call, if, and, or,
          unwind-protect, return and other special forms whose arguments
@@ -7010,6 +7032,7 @@ void eval_init(void)
   load_time_lit_s  = intern(lit("load-time-lit"), system_package);
   eval_only_s  = intern(lit("eval-only"), user_package);
   compile_only_s = intern(lit("compile-only"), user_package);
+  compiler_let_s = intern(lit("compiler-let"), user_package);
   const_foldable_s = intern(lit("%const-foldable%"), system_package);
   pct_fun_s = intern(lit("%fun%"), user_package);
 
@@ -7030,6 +7053,7 @@ void eval_init(void)
   reg_op(prog1_s, op_prog1);
   reg_op(progv_s, op_progv);
   reg_op(let_s, op_let);
+  reg_op(compiler_let_s, op_let);
   reg_op(each_op_s, op_each);
   reg_op(let_star_s, op_let);
   reg_op(fbind_s, op_fbind);
diff --git a/stdlib/compiler.tl b/stdlib/compiler.tl
index cc4eef7b..504d3ea8 100644
--- a/stdlib/compiler.tl
+++ b/stdlib/compiler.tl
@@ -564,6 +564,7 @@
               ((+ *) me.(comp-arith-form oreg env form))
               ((- /) me.(comp-arith-neg-form oreg env form))
               (typep me.(comp-typep oreg env form))
+              (compiler-let me.(comp-compiler-let oreg env form))
               (t me.(comp-fun-form oreg env form))))
            ((and (consp sym)
                  (eq (car sym) 'lambda)) me.(compile oreg env ^(call ,*form)))
@@ -1390,6 +1391,12 @@
     (@nil
      me.(comp-fun-form oreg env form))))
 
+(defmeth compiler comp-compiler-let (me oreg env form)
+  (tree-bind (t bindings . body) form
+    (progv [mapcar car bindings]
+           [mapcar [chain cadr no-dvbind-eval] bindings]
+           me.(comp-progn oreg env body))))
+
 (defmeth compiler comp-fun-form (me oreg env form)
   (let* ((olev *opt-level*)
          (sym (car form))
@@ -2306,6 +2313,9 @@
   (member (symbol-package sym)
           (load-time (list user-package system-package))))
 
+(defun no-dvbind-eval (form)
+  (eval (if-match (sys:dvbind @nil @exp) form exp form)))
+
 (defun usr:compile-toplevel (exp : (expanded-p nil))
   (let ((co (new compiler))
         (as (new assembler))
diff --git a/stdlib/doc-syms.tl b/stdlib/doc-syms.tl
index 8dbadf88..6391695f 100644
--- a/stdlib/doc-syms.tl
+++ b/stdlib/doc-syms.tl
@@ -379,6 +379,7 @@
       ("compile-toplevel" "N-00DE8B13")
       ("compile-update-file" "N-0211BE68")
       ("compile-warning" "N-032EA7D7")
+      ("compiler-let" "N-0345D216")
       ("compl-span-str" "N-0171717F")
       ("cond" "N-016C9E24")
       ("conda" "N-025CC33C")
diff --git a/txr.1 b/txr.1
index 539c95b2..e8cbfc60 100644
--- a/txr.1
+++ b/txr.1
@@ -88206,6 +88206,55 @@ with unused variable checking enabled.
      (compile-file "bar.tl"))
 .brev
 
+.coNP Operator @ compiler-let
+.synb
+.mets (compiler-let >> ({ sym | >> ( sym << init-form )}*) << body-form *)
+.syne
+.desc
+The
+.code compiler-let
+operator strongly resembles
+.code let*
+but has different semantics, relevant to compilation.
+
+Symbols bound using
+.code compiler-let
+are expected to be special variables. For every
+.metn sym ,
+the expression
+.mono
+.meti (special-var-p << sym )
+.onom
+should be true. The behavior is unspecified for any
+.meta sym
+which doesn't name a special variable.
+
+When the compiler encounters the
+.code compiler-let
+construct, the compiler itself establishes a dynamic scope in which the
+implied special variable bindings are in effect. This effect is not
+incorporated into the compiled code. The compiler then implicitly places the
+.metn body-form s,
+into a
+.code progn
+from, and compiles that form. While the implicit
+.code progn
+is being compiled, the dynamic bindings established by
+.code compiler-let
+are in scope.
+
+Thus
+.code compiler-let
+may be used to bind special variables which influence compiler behavior.
+
+The
+.code compiler-let
+form is treated like
+.code let*
+by the interpreter, provided that every
+.meta sym
+names a special variable.
+
 .coNP Macro @ load-time
 .synb
 .mets (load-time << form )