From 1bfffad44c05952bb43231b231d9bd5e33cf2d57 Mon Sep 17 00:00:00 2001
From: Kaz Kylheku <kaz@kylheku.com>
Date: Fri, 3 Feb 2017 10:24:52 -0800
Subject: Forbid lexical function mutation.

* eval.c (expand_lisp1_setq): New static function.
(op_setqf): Check that the function binding which was
found is the global one. If not, throw an error that lexical
functions can't be mutated.
(do_expand): Handle sys:lisp1-setq operator expansion
seprately from the other setq operators, via the new function,
which enforces an expansion-time check against mutation
of lexical functions.
---
 eval.c | 40 +++++++++++++++++++++++++++++++++++++++-
 1 file changed, 39 insertions(+), 1 deletion(-)

(limited to 'eval.c')

diff --git a/eval.c b/eval.c
index a2f014b9..e73b9fb2 100644
--- a/eval.c
+++ b/eval.c
@@ -2095,6 +2095,40 @@ static val expand_lisp1_value(val form, val menv)
   }
 }
 
+static val expand_lisp1_setq(val form, val menv)
+{
+  if (!consp(cdr(form)) || !consp(cddr(form)) || cdddr(form))
+    eval_error(form, lit("~s: invalid syntax"), car(form), nao);
+
+  {
+    val op = car(form);
+    val sym = cadr(form);
+    val newval = caddr(form);
+    val binding_type = lexical_lisp1_binding(menv, sym);
+
+    if (nilp(binding_type)) {
+      if (!bindable(sym))
+        eval_error(form, lit("~s: misapplied to form ~s"),
+                   op, sym, nao);
+      if (!lookup_var(nil, sym) && !lookup_fun(nil, sym))
+        eval_defr_warn(last_form_expanded,
+                       cons(var_s, sym),
+                       lit("~s: unbound variable/function ~s"),
+                       op, sym, nao);
+      return rlcp(cons(op, cons(sym, cons(expand(newval, menv), nil))),
+                  form);
+    }
+
+    if (binding_type == var_k)
+      return expand(rlcp(cons(setq_s, cddr(form)), form), menv);
+
+    if (binding_type == fun_k)
+      eval_error(form, lit("~s: cannot assign lexical function ~s"), op, sym, nao);
+
+    eval_error(form, lit("~s: misapplied to symbol macro ~s"), op, sym, nao);
+  }
+}
+
 static val op_lisp1_value(val form, val env)
 {
   val args = rest(form);
@@ -2118,6 +2152,8 @@ static val op_setqf(val form, val env)
   val binding = lookup_fun(env, var);
   if (nilp(binding))
     eval_error(form, lit("unbound function ~s"), var, nao);
+  if (binding != lookup_fun(env, nil))
+    eval_error(form, lit("cannot assign lexical function ~s"), var, nao);
   return sys_rplacd(binding, eval(newval, env, form));
 }
 
@@ -4126,6 +4162,8 @@ static val do_expand(val form, val menv)
       return expand(first(args), menv);
     } else if (sym == sys_lisp1_value_s) {
       return expand_lisp1_value(form, menv);
+    } else if (sym == lisp1_setq_s) {
+      return expand_lisp1_setq(form, menv);
     } else if (sym == var_s || sym == expr_s) {
       return form;
     } else {
@@ -4137,7 +4175,7 @@ static val do_expand(val form, val menv)
       val args = rest(form_ex);
       val args_ex = expand_forms(args, menv);
 
-      if (sym == setq_s || sym == lisp1_setq_s || sym == setqf_s) {
+      if (sym == setq_s || sym == setqf_s) {
         if (!args)
           eval_error(form, lit("~s: missing argument"), sym, nao);
 
-- 
cgit v1.2.3