lambda-set method: treat [struct ...] as place.

* eval.c (eval_init): Change registration of dwim-set to only
one required argument, with the rest variadic.

* lib.c (lambda_set_s): New symbol variable.
(dwim_set): Change to variadic function that takes all
arguments other than the object/sequence being operated on as
struct args *. Rewrite to do a test on the object type first,
handling hashes and structs specially.
(obj_init): Initialize lambda_set_s.

* share/txr/stdlib/place.tl (defplace dwim): Rewritten for
more generic syntax. The only argument required is obj-place;
the other arguments are treated as a variable argument list,
all treated uniformly.  This eliminates the special handling
of the default value for hash lookups.

* args.h (args_count): New inline function.

* txr.1: Updated documentation for dwim operator, which neglects
to mention use over objects thanks to the lambda function.
Documented lambda-set.

6 files changed, 209 insertions, 53 deletions

diff --git a/args.h b/args.h
index 68d301b8..5735b828 100644
--- a/args.h
+++ b/args.h
@@ -181,6 +181,11 @@ INLINE void args_clear(struct args *args)
   args->fill = 0;
 }
 
+INLINE cnum args_count(struct args *args)
+{
+  return args->fill + c_num(length_list(args->list));
+}
+
 val args_get_checked(val name, struct args *args, cnum *arg_index);
 struct args *args_copy(struct args *to, struct args *from);
 struct args *args_copy_zap(struct args *to, struct args *from);
diff --git a/eval.c b/eval.c
index 30ecbb99..d6a52f86 100644
--- a/eval.c
+++ b/eval.c
@@ -5347,7 +5347,7 @@ 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_n3(dwim_set));
+  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("update"), user_package), func_n2(update));
   reg_fun(intern(lit("search"), user_package), func_n4o(search, 2));
diff --git a/lib.c b/lib.c
index 5b304237..745a227a 100644
--- a/lib.c
+++ b/lib.c
@@ -102,7 +102,7 @@ val error_s, type_error_s, internal_error_s, panic_s;
 val numeric_error_s, range_error_s;
 val query_error_s, file_error_s, process_error_s, syntax_error_s;
 val timeout_error_s, system_error_s;
-val gensym_counter_s, nullify_s, from_list_s;
+val gensym_counter_s, nullify_s, from_list_s, lambda_set_s;
 
 val nothrow_k, args_k, colon_k, auto_k, fun_k;
 val wrap_k, reflect_k;
@@ -8435,28 +8435,59 @@ val replace(val seq, val items, val from, val to)
   }
 }
 
-val dwim_set(val seq, val ind_range, val newval)
+val dwim_set(val seq, varg vargs)
 {
-  switch (type(ind_range)) {
-  case NIL:
-  case CONS:
-  case LCONS:
-  case VEC:
-    if (hashp(seq)) {
-      (void) sethash(seq, ind_range, newval);
-      return seq;
-    }
-    return replace(seq, newval, ind_range, colon_k);
-  case RNG:
-    if (!hashp(seq))
-    {
-      range_bind (x, y, ind_range);
-      return replace(seq, newval, x, y);
+  switch (type(seq)) {
+  case COBJ:
+    if (type(seq) == COBJ) {
+      if (seq->co.cls == hash_s) {
+        cnum nva = args_count(vargs);
+
+        if (nva < 2)
+          uw_throwf(error_s, lit("sethash: missing required arguments"), nao);
+
+        if (nva > 3)
+            uw_throwf(error_s, lit("sethash: too many arguments"), nao);
+
+        if (nva == 2) {
+          args_normalize(vargs, 2);
+          (void) sethash(seq, vargs->arg[0], vargs->arg[1]);
+        } else {
+          args_normalize(vargs, 3);
+          (void) sethash(seq, vargs->arg[0], vargs->arg[2]);
+        }
+
+        return seq;
+      }
+      if (structp(seq))
+        return funcall(method_args(seq, lambda_set_s, vargs));
     }
     /* fallthrough */
   default:
-    (void) refset(seq, ind_range, newval);
-    return seq;
+    {
+      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);
+      ind_range = args_get(vargs, &index);
+      newval = args_get(vargs, &index);
+
+      switch (type(ind_range)) {
+      case NIL:
+      case CONS:
+      case LCONS:
+      case VEC:
+        return replace(seq, newval, ind_range, colon_k);
+      case RNG:
+        {
+          range_bind (x, y, ind_range);
+          return replace(seq, newval, x, y);
+        }
+      default:
+        (void) refset(seq, ind_range, newval);
+        return seq;
+      }
+    }
   }
 }
 
@@ -8994,6 +9025,7 @@ static void obj_init(void)
   name_s = intern(lit("name"), user_package);
   nullify_s = intern(lit("nullify"), user_package);
   from_list_s = intern(lit("from-list"), user_package);
+  lambda_set_s = intern(lit("lambda-set"), user_package);
 
   args_k = intern(lit("args"), keyword_package);
   nothrow_k = intern(lit("nothrow"), keyword_package);
diff --git a/lib.h b/lib.h
index 30d4bd5c..8bc72fd4 100644
--- a/lib.h
+++ b/lib.h
@@ -962,7 +962,7 @@ 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, val ind_range, val newval);
+val dwim_set(val seq, varg);
 val dwim_del(val seq, val ind_range);
 val butlast(val seq, val idx);
 val replace(val seq, val items, val from, val to);
diff --git a/share/txr/stdlib/place.tl b/share/txr/stdlib/place.tl
index d5fdf778..eaf6bda6 100644
--- a/share/txr/stdlib/place.tl
+++ b/share/txr/stdlib/place.tl
@@ -654,61 +654,53 @@
                   ^(set-hash-userdata ,',hash ,val)))
       ,body)))
 
-(defplace (dwim obj-place index : (default nil have-default-p) :env env) body
+(defplace (dwim obj-place :env env . args) body
   (getter setter
-    (with-gensyms (ogetter-sym osetter-sym obj-sym
-                   index-sym dflval-sym newval-sym)
-      (let ((sys:*lisp1* t))
+    (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))
-                  (,index-sym (sys:l1-val ,index))
-                  ,*(if have-default-p
-                      ^((,dflval-sym (sys:l1-val ,default)))))
+                  ,*(mapcar (ret ^(,@1 (sys:l1-val ,@2))) arg-syms args))
              (macrolet ((,getter ()
-                         '[,obj-sym ,index-sym
-                                    ,*(if have-default-p ^(,dflval-sym))])
+                          '[,obj-sym ,*arg-syms])
                         (,setter (val)
-                           ^(rlet ((,',newval-sym ,val))
-                              (,',osetter-sym
-                                (sys:dwim-set ,',obj-sym
-                                              ,',index-sym ,',newval-sym))
-                              ,',newval-sym)))
+                          ^(rlet ((,',newval-sym ,val))
+                             (,',osetter-sym
+                               (sys:dwim-set ,',obj-sym
+                                             ,*',arg-syms ,',newval-sym))
+                             ,',newval-sym)))
                ,body))))))
   (ssetter
-    (with-gensyms (osetter-sym ogetter-sym
-                   obj-sym newval-sym index-sym)
-      (let ((sys:*lisp1* t))
+    (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
           ^(macrolet ((,ssetter (val)
                        ^(rlet ((,',obj-sym (,',ogetter-sym))
-                               (,',index-sym (sys:l1-val ,',index))
+                               ,*(mapcar (ret ^(,@1 (sys:l1-val ,@2)))
+                                         ',arg-syms ',args)
                                (,',newval-sym ,val))
                           (,',osetter-sym
                             (sys:dwim-set ,',obj-sym
-                                          ,*(if ,have-default-p
-                                              ^((prog1
-                                                  ,',index-sym
-                                                  (sys:l1-val ,',default)))
-                                              ^(,',index-sym))
+                                          ,*',arg-syms
                                           ,',newval-sym))
                           ,',newval-sym)))
                ,body)))))
 
   (deleter
-    (with-gensyms (osetter-sym ogetter-sym
-                   obj-sym index-sym oldval-sym)
-      (let ((sys:*lisp1* t))
+    (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))
-                               (,',index-sym (sys:l1-val ,',index)))
-                          (let ((,',oldval-sym [,',obj-sym
-                                                ,',index-sym
-                                                ,*(if ,have-default-p
-                                                    ^(,',default))]))
+                               ,*(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 ,',index-sym))
+                                (sys:dwim-del ,',obj-sym ,*',arg-syms))
                               ,',oldval-sym)))))
                ,body))))))
 
diff --git a/txr.1 b/txr.1
index cdefd6d1..cebf3b93 100644
--- a/txr.1
+++ b/txr.1
@@ -12755,6 +12755,21 @@ Note that
 .meta string
 is always required, and is always the rightmost argument.
 
+.meIP >> [ struct << arg *]
+The structure instance
+.meta struct
+is inquired whether it supports a method named by the symbol
+.metn lambda .
+If so, that method is invoked on the object. The method
+receives
+.meta struct
+followed by the value of every
+.metn arg .
+If this form is used as a place, then the object must
+support a
+.code lambda-set
+method.
+
 .RE
 .PP
 
@@ -22469,6 +22484,118 @@ is evaluated only once:
   (mapcar s list)  <-->  (mapcar (meth s lambda) list)
 .cble
 
+Note: a form such as
+.code "[s args ...]"
+where
+.code s
+is a structure can be treated as a place if the method
+.code lambda-set
+is also implemented.
+
+.coNP Method @ lambda-set
+.synb
+.mets << object .(lambda-set << arg * << new-value)
+.syne
+.desc
+The
+.code lambda-set
+method, in conjunction with a
+.code lambda
+method, allows structures to be used as place accessors. If
+structure
+.code s
+supports a
+.meta lambda-set
+with four arguments, then the following use of the
+.code dwim
+operator is possible:
+
+.cblk
+  (set [s a b c d] v)
+  (set (dwim s a b c d) v) ;; precisely equivalently
+.cble
+
+This has an effect which can be described by the following code:
+
+.cblk
+  (progn
+    (set s s.(lambda-set a b c d v))
+    v)
+.cble
+
+except that
+.code s
+and
+.code v
+are evaluated only once, and
+.code a
+through
+.code d
+are evaluated using the Lisp-1 semantics due the
+.code dwim
+operator.
+
+If a place-mutating operator is used on this form which requires the prior
+value, such as the
+.code inc
+macro, then the structure must support the
+.code lambda
+function also.
+
+If
+.code lambda
+takes
+.I n
+arguments, then
+.code lambda-set
+should take
+.I n+1
+arguments. The first
+.I n
+arguments of these two methods are congruent; the extra rightmost argument
+of
+.code lambda-set
+is the new value to be stored into the place denoted by the prior
+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.
+
+.TP* Example
+
+The following defines a structure with a single instance
+slot
+.code hash
+which holds a hash table, as well as
+.code lambda
+and
+.code lambda-set
+methods:
+
+.cblk
+  (defstruct hash-wrapper nil
+    (hash (hash))
+
+    (:method lambda (self key)
+      [self.hash key])
+
+    (:method lambda-set (self key new-val)
+      (set [self.hash key] new-val) self))
+.cble
+
+An instance of this structure can now be used as follows:
+
+.cblk
+   (let ((s (new hash-wrapper)))
+     (set [s "apple"] 3
+          [s "orange] 4)
+     [s "apple"]) -> 3
+.cble
+
 .coNP Methods @, car @, cdr and @ nullify
 .synb
 .mets << object .(car)