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.

3 files changed, 138 insertions, 48 deletions

diff --git a/ChangeLog b/ChangeLog
index 2bb42f0a..b3509a78 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,5 +1,29 @@
 2015-05-12  Kaz Kylheku  <kaz@kylheku.com>
 
+	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:l1-setq, sys:l1-val): New macros, optimizing
+	versions of sys:lisp1-setq and sys:lisp1-value special operators.
+	(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 macros and 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:l1-val operator when evaluating arguments.
+
+2015-05-12  Kaz Kylheku  <kaz@kylheku.com>
+
 	* eval.c (lookup_var_l): Gut this function of its silly
 	reimplementation of lookup_var.
 	(op_setq): Use lookup_var instead of lookup_var_l.
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);
diff --git a/place.tl b/place.tl
index a948f07b..6003fa30 100644
--- a/place.tl
+++ b/place.tl
@@ -28,20 +28,48 @@
     (defvar *place-clobber-expander* (hash))
     (defvar *place-update-expander* (hash))
     (defvar *place-delete-expander* (hash))
+    (defvar sys:*lisp1* nil)
 
     (defun sys:eval-err (. params)
       (throwf 'eval-error . params))
 
+    (defmacro sys:l1-setq (sym new-val :env e)
+      (caseq (lexical-lisp1-binding e sym)
+        (:var ^(sys:setq ,sym ,new-val))
+        (:symacro (sys:eval-err "sys:l1-setq: invalid use on symbol macro"))
+        (t (if (boundp sym)
+             ^(sys:setq ,sym ,new-val)
+             ^(sys:lisp1-setq ,sym ,new-val)))))
+
+    (defmacro sys:l1-val (u-expr :env e)
+      (let ((e-expr (macroexpand u-expr e)))
+        (if (and (symbolp e-expr) (not (constantp e-expr)))
+          (caseq (lexical-lisp1-binding e e-expr)
+            (:fun ^(fun ,u-expr))
+            (:var u-expr)
+            (nil (if (boundp e-expr)
+                   u-expr
+                   ^(sys:lisp1-value ,u-expr)))
+            (t (sys:eval-err "sys:l1-val: invalid case")))
+          u-expr)))
+
     (defun sys:sym-update-expander (getter-name setter-name
                                     place-expr op-body)
-      ^(macrolet ((,getter-name () ',place-expr)
-                  (,setter-name (val-expr) ^(sys:setq ,',place-expr ,val-expr)))
-         ,op-body))
+      (if sys:*lisp1*
+        ^(macrolet ((,getter-name () ^(sys:l1-val ,',place-expr))
+                    (,setter-name (val-expr) ^(sys:l1-setq ,',place-expr
+                                                           ,val-expr)))
+           ,op-body)
+        ^(macrolet ((,getter-name () ',place-expr)
+                    (,setter-name (val-expr) ^(sys:setq ,',place-expr
+                                                        ,val-expr)))
+           ,op-body)))
 
     (defun sys:sym-clobber-expander (simple-setter-name
                                      place-expr op-body)
-      ^(macrolet ((,simple-setter-name (val-expr) ^(sys:setq ,',place-expr
-                                                             ,val-expr)))
+      ^(macrolet ((,simple-setter-name (val-expr)
+                     ^(,(if sys:*lisp1* 'sys:l1-setq 'sys:setq)
+                        ,',place-expr ,val-expr)))
          ,op-body))
 
     (defun get-update-expander (place)
@@ -350,62 +378,67 @@
                        ^(remhash ,',hash ,',key))))
           ,body)))
 
-   (defplace (dwim obj-place index : (default nil have-default-p)) body
+   (defplace (dwim obj-place index : (default nil have-default-p) :env env) body
      (getter setter
        (with-gensyms (ogetter-sym osetter-sym obj-sym
                       oldval-sym newval-sym
                       index-sym index-sym
                       oldval-sym dflval-sym)
-         (with-update-expander (ogetter-sym osetter-sym) obj-place nil
-           ^(rlet ((,obj-sym (,ogetter-sym))
-                   (,index-sym ,index)
-                   ,*(if have-default-p
-                       ^((,dflval-sym ,default))))
-              (let ((,oldval-sym [,obj-sym
-                                 ,index-sym
-                                 ,*(if have-default-p ^(,dflval-sym))]))
-                (macrolet ((,getter () ',oldval-sym)
-                           (,setter (val)
-                              ^(rlet ((,',newval-sym ,val))
-                                 (,',osetter-sym
-                                   (sys:dwim-set ,',obj-sym
-                                                 ,',index-sym ,',newval-sym))
-                                 ,',newval-sym)))
-                   ,body))))))
+         (let ((sys:*lisp1* (or (symbolp obj-place) sys:*lisp1*)))
+           (with-update-expander (ogetter-sym osetter-sym) obj-place nil
+             ^(rlet ((,obj-sym (,ogetter-sym))
+                     (,index-sym (sys:l1-val ,index))
+                     ,*(if have-default-p
+                         ^((,dflval-sym (sys:l1-val ,default)))))
+                (let ((,oldval-sym [,obj-sym
+                                   ,index-sym
+                                   ,*(if have-default-p ^(,dflval-sym))]))
+                  (macrolet ((,getter () ',oldval-sym)
+                             (,setter (val)
+                                ^(rlet ((,',newval-sym ,val))
+                                   (,',osetter-sym
+                                     (sys:dwim-set ,',obj-sym
+                                                   ,',index-sym ,',newval-sym))
+                                   ,',newval-sym)))
+                     ,body)))))))
      (ssetter
        (with-gensyms (osetter-sym ogetter-sym
                       obj-sym newval-sym index-sym)
-         (with-update-expander (ogetter-sym osetter-sym) obj-place nil
-           ^(macrolet ((,ssetter (val)
-                        ^(rlet ((,',obj-sym (,',ogetter-sym))
-                                (,',index-sym ,',index)
-                                (,',newval-sym ,val))
-                           (,',osetter-sym
-                             (sys:dwim-set ,',obj-sym
-                                           ,*(if ,have-default-p
-                                               ^((prog1 ,',index-sym ,',default))
-                                               ^(,',index-sym))
-                                           ,',newval-sym))
-                           ,',newval-sym)))
-                ,body))))
+         (let ((sys:*lisp1* (or (symbolp obj-place) sys:*lisp1*)))
+           (with-update-expander (ogetter-sym osetter-sym) obj-place nil
+             ^(macrolet ((,ssetter (val)
+                          ^(rlet ((,',obj-sym (,',ogetter-sym))
+                                  (,',index-sym (sys:l1-val ,',index))
+                                  (,',newval-sym ,val))
+                             (,',osetter-sym
+                               (sys:dwim-set ,',obj-sym
+                                             ,*(if ,have-default-p
+                                                 ^((prog1
+                                                     ,',index-sym
+                                                     (sys:l1-val ,',default)))
+                                                 ^(,',index-sym))
+                                             ,',newval-sym))
+                             ,',newval-sym)))
+                  ,body)))))
 
      (deleter
        (with-gensyms (osetter-sym ogetter-sym
                       obj-sym index-sym oldval-sym
                       dflval-sym)
-         (with-update-expander (ogetter-sym osetter-sym) obj-place nil
-           ^(macrolet ((,deleter ()  ;; todo: place must not have optional val
-                        ^(rlet ((,',obj-sym (,',ogetter-sym)))
-                           (let* ((,',index-sym ,',index)
-                                  (,',oldval-sym [,',obj-sym
-                                                  ,',index-sym
-                                                  ,*(if ,have-default-p
-                                                      ^(,',default))]))
-                             (progn
-                               (,',osetter-sym
-                                 (sys:dwim-del ,',obj-sym ,',index-sym))
-                               ,',oldval-sym)))))
-                ,body)))))
+         (let ((sys:*lisp1* (or (symbolp obj-place) sys:*lisp1*)))
+           (with-update-expander (ogetter-sym osetter-sym) obj-place nil
+             ^(macrolet ((,deleter ()  ;; todo: place must not have optional val
+                          ^(rlet ((,',obj-sym (,',ogetter-sym)))
+                             (let* ((,',index-sym (sys:l1-val ,',index))
+                                    (,',oldval-sym [,',obj-sym
+                                                    ,',index-sym
+                                                    ,*(if ,have-default-p
+                                                        ^(,',default))]))
+                               (progn
+                                 (,',osetter-sym
+                                   (sys:dwim-del ,',obj-sym ,',index-sym))
+                                 ,',oldval-sym)))))
+                  ,body))))))
 
    (defplace (force promise) body
      (getter setter