New macro: defset.

* lisplib.c (defset_instantiate, defset_set_entries): New
static functions.
(lisplib_init): Register auto-load of defset.tl, keyed on
defset symbol.

* share/txr/stdlib/defset.tl: New file.

* share/txr/stdlib/paramt.tl (param-parser-base opt-syms):
New method.

* txr.1: Documented.

4 files changed, 380 insertions, 2 deletions

diff --git a/lisplib.c b/lisplib.c
index 0ef52934..a3f0e9f6 100644
--- a/lisplib.c
+++ b/lisplib.c
@@ -757,6 +757,23 @@ static val save_exe_set_entries(val dlt, val fun)
   return nil;
 }
 
+static val defset_instantiate(val set_fun)
+{
+  funcall1(set_fun, nil);
+  load(format(nil, lit("~adefset"), stdlib_path, nao));
+  return nil;
+}
+
+static val defset_set_entries(val dlt, val fun)
+{
+  val name[] = {
+    lit("defset"),
+    nil
+  };
+  set_dlt_entries(dlt, name, fun);
+  return nil;
+}
+
 val dlt_register(val dlt,
                  val (*instantiate)(val),
                  val (*set_entries)(val, val))
@@ -806,6 +823,7 @@ void lisplib_init(void)
     dlt_register(dl_table, op_instantiate, op_set_entries);
 
   dlt_register(dl_table, save_exe_instantiate, save_exe_set_entries);
+  dlt_register(dl_table, defset_instantiate, defset_set_entries);
 
   reg_fun(intern(lit("try-load"), system_package), func_n1(lisplib_try_load));
 }
diff --git a/share/txr/stdlib/defset.tl b/share/txr/stdlib/defset.tl
new file mode 100644
index 00000000..9b1c9559
--- /dev/null
+++ b/share/txr/stdlib/defset.tl
@@ -0,0 +1,94 @@
+;; Copyright 2019
+;; Kaz Kylheku <kaz@kylheku.com>
+;; Vancouver, Canada
+;; All rights reserved.
+;;
+;; Redistribution and use in source and binary forms, with or without
+;; modification, are permitted provided that the following conditions are met:
+;;
+;; 1. Redistributions of source code must retain the above copyright notice, this
+;;    list of conditions and the following disclaimer.
+;;
+;; 2. Redistributions in binary form must reproduce the above copyright notice,
+;;    this list of conditions and the following disclaimer in the documentation
+;;    and/or other materials provided with the distribution.
+;;
+;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
+;; ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
+;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
+;; DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE
+;; FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR
+;; SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER
+;; CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
+;; OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+
+
+(compile-only
+  (load-for (struct sys:param-parser-base "param")))
+
+(defun mac-env-flatten (env)
+  (when env
+    (let ((lexvars [mapcar car
+                           [keep-if (op eq 'sys:special)
+                                    (env-vbindings env) cdr]]))
+      (append (mac-env-flatten (env-next env)) lexvars))))
+
+(defun analyze-params (params)
+  (let* ((env (gensym))
+         (lam ^(lambda ,params
+                (macrolet ((,env (:env e)
+                             (set (symbol-value ',env) e)))
+                  (,env))))
+         (explam (expand lam))
+         (syms (mac-env-flatten (symbol-value env))))
+    (list (cadr explam) syms)))
+
+(defun defset-expander-simple (macform get-fun set-fun)
+  (with-gensyms (getter setter params)
+    ^(defplace (,get-fun . ,params) body
+       (,getter ,setter
+          (let ((pgens (mapcar (ret (gensym)) ,params)))
+            ^(alet ,(zip pgens (list ,*params))
+               (macrolet ((,,getter () ^(,',',get-fun ,*',pgens))
+                          (,,setter (val) ^(,',',set-fun ,*',pgens ,val)))
+                 ,body)))))))
+
+(defun defset-expander (env macform name params newval getform setform)
+  (let* ((fp (new fun-param-parser form macform syntax params))
+         (fixpars (append fp.req fp.(opt-syms)))
+         (restpar fp.rest))
+    (with-gensyms (getter setter)
+      ^(defplace (,name ,*params) body
+         (,getter ,setter
+            (let* ((gpf-pairs (append (mapcar (op list (gensym) @1)
+                                              (list ,*fixpars))))
+                   (gpr-pairs (if ',restpar
+                                (mapcar (ret ^(,(gensym) ,@1)) ,restpar)))
+                   (pgens [mapcar car gpf-pairs])
+                   (rgens [mapcar car gpr-pairs]))
+              ^(alet (,*gpf-pairs ,*gpr-pairs)
+                 ,(expand ^(symacrolet (,*(zip ',fixpars
+                                               (mapcar (ret ^',@1) pgens))
+                                         ,*(if gpr-pairs
+                                             ^((,',restpar ',rgens))))
+                             (macrolet ((,,getter () ,',getform)
+                                        (,,setter (,',newval) ,',setform))
+                               ,body))
+                          ,env))))))))
+
+(defun defset-expander-hairy (env macform name params newval getform setform)
+  (compile-error macform "param list macro support is being researched"))
+
+(defmacro usr:defset (:env e :form mf . args)
+  (tree-case args
+    ((name (param . params) newval getform setform)
+     (if (and (keywordp param) (neq : param))
+       (defset-expander-hairy e mf . args)
+       (defset-expander e mf . args)))
+    ((name (. params) newval getform setform)
+     (defset-expander e mf . args))
+    ((get-fun set-fun)
+     (defset-expander-simple mf get-fun set-fun))
+    (x (compile-error mf "invalid syntax"))))
diff --git a/share/txr/stdlib/param.tl b/share/txr/stdlib/param.tl
index 2128a9d4..2fbf79be 100644
--- a/share/txr/stdlib/param.tl
+++ b/share/txr/stdlib/param.tl
@@ -54,11 +54,17 @@
                me.key key
                me.nreq (len rp)
                me.nopt (len opt)
-               me.nfix (+ me.nreq me.nopt))))))
+               me.nfix (+ me.nreq me.nopt)))))
+
+    (:method opt-syms (me)
+      (build
+        (each ((o me.opt))
+          (caseql (len o)
+            ((1 2) (add (car o)))
+            (3 (add (car o) (caddr o))))))))
 
   (defstruct (fun-param-parser syntax form) param-parser-base
     (mac-param-p nil))
 
   (defstruct (mac-param-parser syntax form) param-parser-base
     (mac-param-p t)))
-
diff --git a/txr.1 b/txr.1
index 34fac7dc..173c7e38 100644
--- a/txr.1
+++ b/txr.1
@@ -12463,6 +12463,8 @@ are both open-ended. Code can be written quite easily in \*(TL to introduce
 new kinds of places, as well as new place-mutating operators.
 New places can be introduced with the help of the
 .code defplace
+or
+.code defset
 macro, or possibly the
 .code define-place-macro
 macro in simple cases when a new syntactic place can be expressed as a
@@ -33470,6 +33472,8 @@ evaluations of the place form.
 The programmer who implements a new place does not write expanders directly,
 but rather defines them via the
 .code defplace
+or
+.code defset
 macro.
 
 The programmer who implements a new place update macro likewise does not
@@ -34494,6 +34498,262 @@ cells:
          ,body)))
 .cble
 
+.coNP Macro @ defset
+.synb
+.mets (defset < name < params < new-val-sym < get-form << set-form )
+.mets (defset < get-fun-sym << set-fun-sym )
+.syne
+.desc
+The
+.code defset
+macro provides a mechanism for introducing a new kind of syntactic place.
+It is simpler to use than
+.code defplace
+and more concise, but not as general.
+
+The
+.code defset
+macro is designed for situations in which a function or macro which evaluates
+all of its arguments is required to serve as a syntactic place.
+It provides two flavors of syntax: the long form, indicated by giving
+.code defset
+five arguments, and a short form, which uses two arguments.
+
+In the long form of
+.codn defset ,
+the syntactic place is described by
+.meta name
+and
+.metn params .
+The
+.code defset
+form expresses the request that call to the function or operator named
+.meta name
+is to be treated as a syntactic place, which has arguments described by
+the parameter list
+.metn params .
+
+The
+.meta new-val-sym
+parameter is the name of a symbol which will be bound to
+an expression which calculates the new value being stored into
+the syntactic place. This is intended to be referenced in the
+.meta set-form
+only, which should ensure that the expression that
+.meta new-val-sym
+holds is evaluated only once.
+
+The
+.meta get-form
+and
+.meta set-form
+arguments specify forms which generate the code for, respectively,
+accessing the value of the place, and storing a new value.
+
+The
+.code defset
+macro makes the necessary arrangements such that when an operator form
+named by
+.meta name
+is treated as a syntactic place, then at macro-expansion time, code is
+generated to evaluate all of its argument expressions into machine-generated
+variables. The names of those variables are automatically bound to the
+corresponding symbols given in the
+.meta params
+argument list of the
+.code defset
+syntax. Code is also generated to evaluate the expression which gives the
+new value to be stored, and that is bound to a generated variable whose
+name is bound to the
+.code new-val-sym
+symbol. Then arrangements are made to invoke the
+.code get-form
+and
+.code set-form
+in an environment in which these symbol bindings are visible. The task of
+these forms is to insert the values of the symbols from
+.meta params
+and
+.meta new-val-sym
+into suitable code templates that will perform the access and store actions.
+
+If
+.meta params
+list contains optional parameters, the default value expressions of those
+parameters shall be evaluated in the scope of the
+.code defset
+definition.
+
+The
+.meta params
+list may specify a rest parameter. In the expansion, this parameter will
+capture a list of temporary symbols, corresponding to the list of variadic
+argument expressions. For instance if the
+.code defset
+parameter list for a place
+.code g
+is
+.codn "(a b . c)" ,
+featuring the rest parameter
+.codn c ,
+and its
+.meta set-form
+is
+.code "^(s ,a ,b ,*c)"
+and the place is invoked as
+.code "(g (i) (j) (k) (l))"
+then parameter
+.code c
+will be bound to a list of gensyms such as
+.code "(#:g0123 #:g0124)"
+so that the evaluation of
+.meta set-form
+will yield syntax resembling
+.codn "(s #:g0121 #:g0122 #:g0123 #:g0124)" .
+Here, gensyms
+.code #:g0123
+and
+.code #:g0124
+are understood to be bound to the values of the expressions
+.code (k)
+and
+.codn (l) ,
+the two trailing parameters corresponding to the rest parameter
+.codn c .
+
+Syntactic places defined by
+.code defset
+may not use improper syntax such as
+.codn "(set (g 1 2 . 3) v)" .
+
+The short, two-argument form of
+.code defset
+simply specifies the names of two functions or operators:
+.code get-fun-sym
+names the operator which accesses the place, and
+.code set-fun-sym
+names the operator which stores a new value into the place.
+It is expected that all arguments of these operators are evaluated
+expressions, and that the store operator takes one argument more
+than the access operator. The operators are otherwise assumed to be
+variadic: each instance of a place based on
+.code get-fun-sym
+individually determines how many arguments are passed to that operator
+and to the one named by
+.codn set-fun-sym .
+
+The definition
+.code "(defset g s)"
+means that
+.code "(inc (g x y))"
+will generate code which ensures that
+.code x
+and
+.code y
+are evaluated exactly once, and then those two values are passed as
+arguments to
+.code g
+which returns the current value of the place. That value is then incremented
+by one, and stored into the place by calling the
+.code s
+function/operator with three arguments: the two values that were passed to
+.code g
+and the new value.  The exact number of arguments is determined by each
+individual use of
+.code g
+as a place; the
+.code defset
+form doesn't specify the arity of
+.code g
+and
+.codn s ,
+only that
+.code s
+must accept one more argument relative to
+.codn g .
+
+The following equivalence holds between the short and long forms:
+
+.cblk
+   (defset g s)  <-->  (defset g (. r) n ^(g ,*r) ^(s ,*r ,n))
+.cble
+
+.TP* "Example:"
+
+Implementation of
+.code car
+as a syntactic place using a long form
+.codn defset :
+
+.cblk
+  (defset car (cell) new
+    ^(car ,cell)
+    (let ((n (gensym)))
+      ^(rlet ((,n ,new))
+         (progn (rplaca ,cell ,n) ,n))))
+.cble
+
+Given such a definition, the expression
+.code "(inc (car abc))"
+expands to code closely resembling:
+
+.cblk
+  (let ((#:g0014 (abc)))
+    (let ((#:g0028 (succ (car #:g0014))))
+        (rplaca #:g0014 #:g0028)
+            #:g0028))
+.cble
+
+The
+.code defset
+macro has arranged for the argument expression
+.code (abc)
+of
+.code car
+to be evaluated to a temporary variable
+.codn #:g0014 ,
+a
+.codn gensym .
+This, then, holds the
+.code cons
+cell being operated on.
+At macro-expansion time, the variable
+.code cell
+from the parameter list specified by the
+.code defset
+is bound to this symbol. The subexpression
+.code "(car #:0014)"
+is derived from the
+.meta get-form
+.code "^(car ,cell)"
+which inserted the value of
+.code cell
+into a backquote template, that value being the symbol
+.codn #:g0014 .
+The
+.code new
+variable was bound to the expression giving the new value, namely
+.codn "(succ (car #:g0014))" .
+The
+.meta set-form
+is careful to evaluate this only one time, storing its value into
+the temporary variable
+.codn #:g0028 ,
+referenced by the variable
+.codn n .
+The
+.metn set-form 's
+.code "(rplaca ,cell ,n)"
+fragment thus turned into
+.code "(rplaca #:g0014 #:g0028)"
+where
+.code #:g0014
+references the cons cell being operated on, and
+.code #:g0028
+the calculated new value to be stored into its
+.code car
+field.
+
 .coNP Macro @ define-place-macro
 .synb
 .mets (define-place-macro < name < macro-style-params