Relax restrictions on dwim places.

No longer require the leftmost expression in a dwim place to
itself be a place, except when the expression evaluates to
a list, and the list is subject to an element deletion or
a range operation.

* eval.c (eval_init): Register dwim-set and dwim-del with
one additional argument that the C functions now take.

* lib.c (dwim_set, dwim_del): Take a new place_p argument
which informs these functions whether the object they
are operating on came from a syntactic place. The forbidden
situations are diagnosed based on this flag: modification
of the subrange of a list, or deletion of a list ref.
Some error messages reworded.

* lib.h (dwim_set, dwim_del): Declarations updated.

* share/txr/stdlib/place.tl (defplace dwim): Produce a
different update, clobber and delete expansion when
the obj-place form isn't a place. In the non-place case,
do not assign the result of the sys:dwim-set or
sys:dwim-del operation back obj-place. Furthermore,
pass a Boolean flag to sys:dwim-set and sys:dwim-del
indicating which situation is the case: did the object
argument come from a place or non-place.

* txr.1: Documentation updated.

5 files changed, 107 insertions, 46 deletions

diff --git a/eval.c b/eval.c
index d6a52f86..389efdf2 100644
--- a/eval.c
+++ b/eval.c
@@ -5347,8 +5347,8 @@ void eval_init(void)
   reg_fun(intern(lit("ref"), user_package), func_n2(ref));
   reg_fun(intern(lit("refset"), user_package), func_n3(refset));
   reg_fun(intern(lit("replace"), user_package), func_n4o(replace, 2));
-  reg_fun(intern(lit("dwim-set"), system_package), func_n1v(dwim_set));
-  reg_fun(intern(lit("dwim-del"), system_package), func_n2(dwim_del));
+  reg_fun(intern(lit("dwim-set"), system_package), func_n2v(dwim_set));
+  reg_fun(intern(lit("dwim-del"), system_package), func_n3(dwim_del));
   reg_fun(intern(lit("update"), user_package), func_n2(update));
   reg_fun(intern(lit("search"), user_package), func_n4o(search, 2));
   reg_fun(intern(lit("rsearch"), user_package), func_n4o(rsearch, 2));
diff --git a/lib.c b/lib.c
index 745a227a..05541f5d 100644
--- a/lib.c
+++ b/lib.c
@@ -8435,7 +8435,7 @@ val replace(val seq, val items, val from, val to)
   }
 }
 
-val dwim_set(val seq, varg vargs)
+val dwim_set(val place_p, val seq, varg vargs)
 {
   switch (type(seq)) {
   case COBJ:
@@ -8459,8 +8459,10 @@ val dwim_set(val seq, varg vargs)
 
         return seq;
       }
-      if (structp(seq))
-        return funcall(method_args(seq, lambda_set_s, vargs));
+      if (structp(seq)) {
+        (void) funcall(method_args(seq, lambda_set_s, vargs));
+        return seq;
+      }
     }
     /* fallthrough */
   default:
@@ -8468,7 +8470,7 @@ val dwim_set(val seq, varg vargs)
       cnum index = 0;
       val ind_range, newval;
       if (!args_two_more(vargs, 0))
-        uw_throwf(error_s, lit("dwim place assignment: missing required arguments"), nao);
+        uw_throwf(error_s, lit("index/range assignment: missing required arguments"), nao);
       ind_range = args_get(vargs, &index);
       newval = args_get(vargs, &index);
 
@@ -8477,10 +8479,14 @@ val dwim_set(val seq, varg vargs)
       case CONS:
       case LCONS:
       case VEC:
+        if (!place_p && listp(seq))
+          goto notplace;
         return replace(seq, newval, ind_range, colon_k);
       case RNG:
         {
           range_bind (x, y, ind_range);
+          if (!place_p && listp(seq))
+            goto notplace;
           return replace(seq, newval, x, y);
         }
       default:
@@ -8489,14 +8495,33 @@ val dwim_set(val seq, varg vargs)
       }
     }
   }
+notplace:
+  uw_throwf(error_s, lit("range assignment: list form must be place"), nao);
 }
 
-val dwim_del(val seq, val ind_range)
+val dwim_del(val place_p, val seq, val ind_range)
 {
-  if (hashp(seq)) {
-    (void) remhash(seq, ind_range);
-    return seq;
-  } else if (rangep(ind_range)) {
+  switch (type(seq)) {
+  case NIL:
+  case CONS:
+  case LCONS:
+    if (!place_p)
+      uw_throwf(error_s, lit("index/range delete: list form must be place"),
+                nao);
+    break;
+  case COBJ:
+    if (seq->co.cls == hash_s) {
+      (void) remhash(seq, ind_range);
+      return seq;
+    }
+    if (structp(seq))
+      uw_throwf(error_s, lit("index/range delete: not supported for structs"),
+                nao);
+  default:
+    break;
+  }
+
+  if (rangep(ind_range)) {
     return replace(seq, nil, from(ind_range), to(ind_range));
   } else {
     return replace(seq, nil, ind_range, succ(ind_range));
diff --git a/lib.h b/lib.h
index 8bc72fd4..50ee8640 100644
--- a/lib.h
+++ b/lib.h
@@ -962,8 +962,8 @@ val empty(val seq);
 val sub(val seq, val from, val to);
 val ref(val seq, val ind);
 val refset(val seq, val ind, val newval);
-val dwim_set(val seq, varg);
-val dwim_del(val seq, val ind_range);
+val dwim_set(val place_p, val seq, varg);
+val dwim_del(val place_p, val seq, val ind_range);
 val butlast(val seq, val idx);
 val replace(val seq, val items, val from, val to);
 val update(val seq, val fun);
diff --git a/share/txr/stdlib/place.tl b/share/txr/stdlib/place.tl
index eaf6bda6..7112f0ae 100644
--- a/share/txr/stdlib/place.tl
+++ b/share/txr/stdlib/place.tl
@@ -659,32 +659,54 @@
     (with-gensyms (ogetter-sym osetter-sym obj-sym newval-sym)
       (let ((arg-syms (mapcar (ret (gensym)) args))
             (sys:*lisp1* t))
-        (with-update-expander (ogetter-sym osetter-sym) obj-place nil
-          ^(rlet ((,obj-sym (,ogetter-sym))
+        (if (place-form-p obj-place sys:*pl-env*)
+          (with-update-expander (ogetter-sym osetter-sym) obj-place nil
+            ^(rlet ((,obj-sym (,ogetter-sym))
+                    ,*(mapcar (ret ^(,@1 (sys:l1-val ,@2))) arg-syms args))
+               (macrolet ((,getter ()
+                            '[,obj-sym ,*arg-syms])
+                          (,setter (val)
+                            ^(rlet ((,',newval-sym ,val))
+                               (,',osetter-sym
+                                 (sys:dwim-set t ,',obj-sym
+                                               ,*',arg-syms ,',newval-sym))
+                               ,',newval-sym)))
+                 ,body)))
+          ^(rlet ((,obj-sym ,obj-place)
                   ,*(mapcar (ret ^(,@1 (sys:l1-val ,@2))) arg-syms args))
              (macrolet ((,getter ()
                           '[,obj-sym ,*arg-syms])
                         (,setter (val)
                           ^(rlet ((,',newval-sym ,val))
-                             (,',osetter-sym
-                               (sys:dwim-set ,',obj-sym
-                                             ,*',arg-syms ,',newval-sym))
+                             (sys:dwim-set nil ,',obj-sym
+                                           ,*',arg-syms ,',newval-sym)
                              ,',newval-sym)))
                ,body))))))
   (ssetter
     (with-gensyms (osetter-sym ogetter-sym obj-sym newval-sym)
       (let ((arg-syms (mapcar (ret (gensym)) args))
             (sys:*lisp1* t))
-        (with-update-expander (ogetter-sym osetter-sym) obj-place nil
+        (if (place-form-p obj-place sys:*pl-env*)
+          (with-update-expander (ogetter-sym osetter-sym) obj-place nil
+            ^(macrolet ((,ssetter (val)
+                         ^(rlet ((,',obj-sym (,',ogetter-sym))
+                                 ,*(mapcar (ret ^(,@1 (sys:l1-val ,@2)))
+                                           ',arg-syms ',args)
+                                 (,',newval-sym ,val))
+                            (,',osetter-sym
+                              (sys:dwim-set t ,',obj-sym
+                                            ,*',arg-syms
+                                            ,',newval-sym))
+                            ,',newval-sym)))
+                 ,body))
           ^(macrolet ((,ssetter (val)
-                       ^(rlet ((,',obj-sym (,',ogetter-sym))
+                       ^(rlet ((,',obj-sym ,',obj-place)
                                ,*(mapcar (ret ^(,@1 (sys:l1-val ,@2)))
                                          ',arg-syms ',args)
                                (,',newval-sym ,val))
-                          (,',osetter-sym
-                            (sys:dwim-set ,',obj-sym
-                                          ,*',arg-syms
-                                          ,',newval-sym))
+                          (sys:dwim-set nil ,',obj-sym
+                                        ,*',arg-syms
+                                        ,',newval-sym)
                           ,',newval-sym)))
                ,body)))))
 
@@ -692,17 +714,27 @@
     (with-gensyms (osetter-sym ogetter-sym obj-sym oldval-sym)
       (let ((arg-syms (mapcar (ret (gensym)) args))
             (sys:*lisp1* t))
-        (with-update-expander (ogetter-sym osetter-sym) obj-place nil
-          ^(macrolet ((,deleter ()  ;; todo: place must not have optional val
-                       ^(rlet ((,',obj-sym (,',ogetter-sym))
-                               ,*(mapcar (ret ^(,@1 (sys:l1-val ,@2)))
-                                         ',arg-syms ',args))
-                          (let ((,',oldval-sym [,',obj-sym ,*',arg-syms]))
-                            (progn
-                              (,',osetter-sym
-                                (sys:dwim-del ,',obj-sym ,*',arg-syms))
-                              ,',oldval-sym)))))
-               ,body))))))
+        (if (place-form-p obj-place sys:*pl-env*)
+          (with-update-expander (ogetter-sym osetter-sym) obj-place nil
+            ^(macrolet ((,deleter ()
+                         ^(rlet ((,',obj-sym (,',ogetter-sym))
+                                 ,*(mapcar (ret ^(,@1 (sys:l1-val ,@2)))
+                                           ',arg-syms ',args))
+                            (let ((,',oldval-sym [,',obj-sym ,*',arg-syms]))
+                              (progn
+                                (,',osetter-sym
+                                  (sys:dwim-del t ,',obj-sym ,*',arg-syms))
+                                ,',oldval-sym)))))
+                 ,body))
+            ^(macrolet ((,deleter ()
+                         ^(rlet ((,',obj-sym ,',obj-place)
+                                 ,*(mapcar (ret ^(,@1 (sys:l1-val ,@2)))
+                                           ',arg-syms ',args))
+                            (let ((,',oldval-sym [,',obj-sym ,*',arg-syms]))
+                              (progn
+                                (sys:dwim-del nil ,',obj-sym ,*',arg-syms)
+                                ,',oldval-sym)))))
+                 ,body))))))
 
 (defplace (force promise) body
   (getter setter
diff --git a/txr.1 b/txr.1
index cebf3b93..47b20ac1 100644
--- a/txr.1
+++ b/txr.1
@@ -12634,14 +12634,18 @@ at the specified
 .metn index ,
 which is a nonnegative integer.
 
-This form is also a place if the
-.meta sequence
-subform is a place. If a value is stored to this place, it replaces the
+This form is also a syntactic place.
+If a value is stored to this place, it replaces the
 element.
 
 The place may also be deleted, which has the effect of removing the element
 from the sequence, shifting the elements at higher indices, if any, down one
 element position, and shortening the sequence by one.
+If the place is deleted, and if
+.meta sequence
+is a list, then the
+.meta sequence
+form itself must be a place.
 
 .meIP >> [ sequence << from-index..to-below-index ]
 Retrieve the specified range of elements.
@@ -12655,14 +12659,17 @@ fields of a range object. The
 .code rcons
 function.  See the section on Range Indexing below.
 
-This form is also a syntactic place, if the
-.meta sequence
-subform is a place. Storing a value in this place
+This form is also a syntactic place.  Storing a value in this place
 has the effect of replacing the subsequence with
 a new subsequence. Deleting the place has the
 effect of removing the specified subsequence
 from
 .metn sequence .
+If
+.meta sequence
+is a list, then the
+.meta sequence
+form must itself be a place.
 The
 .meta new-value
 argument in a range assignment can be a string, vector or list,
@@ -22519,7 +22526,7 @@ This has an effect which can be described by the following code:
 
 .cblk
   (progn
-    (set s s.(lambda-set a b c d v))
+    s s.(lambda-set a b c d v)
     v)
 .cble
 
@@ -22560,10 +22567,7 @@ arguments.
 
 The return value of
 .code lambda-set
-is significant. Unless there is a very good reason for the method to
-do otherwise, it should return the structure itself. This is because
-the place-mutating operators store this returned value back to the place
-which holds the structure itself.
+is ignored.
 
 .TP* Example