DWIM places must use Lisp-1 semantics.

This really only affects code which does something like
(set [f x] y) and f resolves as a function. (The TXR Program
bent over backwards to install a mutable object into a function
binding.) In this situation, we need to update the function binding
f, rather than some variable f.

* eval.c (op_lisp1_setq, op_lisp1_value): New static functions.
(eval_init): Register sys:lisp1-setq and sys:lisp1-value
special forms.

* place.tl (sys:*lisp1*): New special variable.
(sys:sym-place-update-expander, sys:sym-place-clobber-expander):
React to sys:*lisp1* variable by doing symbol access using Lisp-1
semantics, with help of newly introduced special forms.
(dwim): Bind sys:*lisp1* to true, if main argument is a symbolic place,
so that the update is done using Lisp-1 semantics. Use the
sys:lisp1-value operator when evaluating arguments.

1 files changed, 33 insertions, 0 deletions

diff --git a/eval.c b/eval.c
index 04420284..c82b4e34 100644
--- a/eval.c
+++ b/eval.c
@@ -1677,6 +1677,37 @@ static val op_setq(val form, val env)
   }
 }
 
+static val op_lisp1_setq(val form, val env)
+{
+  val args = rest(form);
+  val var = pop(&args);
+  val newval = pop(&args);
+
+  if (!bindable(var)) {
+    eval_error(form, lit("sys:lisp1-setq: ~s is not a bindable symbol"), var, nao);
+  } else {
+    val binding = lookup_sym_lisp1(env, var);
+    if (nilp(binding))
+      eval_error(form, lit("unbound variable ~s"), var, nao);
+    return sys_rplacd(binding, eval(newval, env, form));
+  }
+}
+
+static val op_lisp1_value(val form, val env)
+{
+  val args = rest(form);
+  val arg = car(args);
+
+  if (!bindable(arg)) {
+    return eval(arg, env, form);
+  } else {
+    val binding = lookup_sym_lisp1(env, arg);
+    if (nilp(binding))
+      eval_error(form, lit("unbound variable ~s"), arg, nao);
+    return cdr(binding);
+  }
+}
+
 static val op_for(val form, val env)
 {
   val forsym = first(form);
@@ -3868,6 +3899,8 @@ void eval_init(void)
   reg_op(tree_case_s, op_tree_case);
   reg_op(tree_bind_s, op_tree_bind);
   reg_op(setq_s, op_setq);
+  reg_op(intern(lit("lisp1-setq"), system_package), op_lisp1_setq);
+  reg_op(intern(lit("lisp1-value"), system_package), op_lisp1_value);
   reg_op(for_s, op_for);
   reg_op(for_star_s, op_for);
   reg_op(dohash_s, op_dohash);