From 1fb6f6691d5b6fb6b037bb14073694f651f2b9fc Mon Sep 17 00:00:00 2001
From: Kaz Kylheku <kaz@kylheku.com>
Date: Fri, 28 Jun 2019 21:25:43 -0700
Subject: defset: bind new-val-sym to temporary variable.

Users of defset no longer have to ensure that in the store
form, the symbol which gives the new value to be stored is
inserted only once.

* share/txr/stdlib/defset.tl (defset-expander): Transform the
store form by inserting a temporary variable using alet.
(sub-list, sub-vec, sub-str): These place forms no longer
require a local gensym.

* txr.1: Updated doc.

* tests/012/defset.tl: The expected output for the inc case
now incorporates a gensym that comes from the compiled
defset macro. Since we can't control that by means of the
gensym counter, we resort to extracting it from the expansion
itself, then check the test case against a template which
incorporates that gensym. We check that the extracted item
really is a gensym: it's a symbol with no home package whose
name starts with "g".
---
 share/txr/stdlib/defset.tl | 22 +++++++++++-----------
 tests/012/defset.tl        | 14 ++++++++++++--
 txr.1                      | 10 ----------
 3 files changed, 23 insertions(+), 23 deletions(-)

diff --git a/share/txr/stdlib/defset.tl b/share/txr/stdlib/defset.tl
index d666f199..5312d5dd 100644
--- a/share/txr/stdlib/defset.tl
+++ b/share/txr/stdlib/defset.tl
@@ -63,7 +63,12 @@
          (fixpars (append fp.req fp.(opt-syms)))
          (restpar (if (symbol-package fp.rest) fp.rest))
          (extsyms [keep-if symbol-package
-                           (diff total-syms (cons restpar fixpars))]))
+                           (diff total-syms (cons restpar fixpars))])
+         (nvsym (gensym))
+         (xsetform ^^(alet ((,',nvsym ,,newval))
+                       ,,(expand ^(symacrolet ((,newval ',nvsym))
+                                    ,setform)
+                                 env))))
     (with-gensyms (getter setter args gpf-pairs gpr-pairs ext-pairs
                    pgens rgens egens all-pairs agens)
       ^(defplace (,name . ,args) body
@@ -94,7 +99,8 @@
                                                ^((,',restpar ',,rgens))
                                                ^((,',restpar ',(car ,rgens))))))
                               (macrolet ((,,getter () ^(,',',name ,',*,agens))
-                                         (,,setter (,',newval) ,',setform))
+                                         (,,setter (,',newval)
+                                            ,',xsetform))
                                 ,body))
                            ,env)))))))))
 
@@ -107,16 +113,10 @@
     (x (compile-error mf "invalid syntax"))))
 
 (defset sub-list (list : (from 0) (to t)) items
-  (let ((it (gensym)))
-    ^(alet ((,it ,items))
-       (progn (set ,list (replace-list ,list ,it ,from ,to)) ,it))))
+  ^(progn (set ,list (replace-list ,list ,items ,from ,to)) ,items))
 
 (defset sub-vec (vec : (from 0) (to t)) items
-  (let ((it (gensym)))
-    ^(alet ((,it ,items))
-       (progn (replace-vec ,vec ,it ,from ,to) ,it))))
+  ^(progn (replace-vec ,vec ,items ,from ,to) ,items))
 
 (defset sub-str (str : (from 0) (to t)) items
-  (let ((it (gensym)))
-    ^(alet ((,it ,items))
-       (progn (replace-str ,str ,it ,from ,to) ,it))))
+  ^(progn (replace-str ,str ,items ,from ,to) ,items))
diff --git a/tests/012/defset.tl b/tests/012/defset.tl
index 601be292..110f3c64 100644
--- a/tests/012/defset.tl
+++ b/tests/012/defset.tl
@@ -2,10 +2,20 @@
 
 (defset foo (:key x y -- a b c (d 4)) n ^(bar ,x ,y, a, b, c ,d ,n))
 
+;; obtain identity of new-val gensym: this is baked into defset
+(defvarl %new-val-sym% (caar (last (cadr (expand '(inc (foo 1 2)))))))
+
+(test
+  (and (symbolp %new-val-sym%)
+       (null (symbol-package %new-val-sym%))
+       (starts-with "g" (symbol-name %new-val-sym%)))
+  t)
+
 (test
   (expand '(set (foo 1 2 :a 3 :b 4) 5))
   (bar 1 2 3 4 nil 4 5))
 
-(test
+(vtest
   (expand '(inc (foo 1 2 :a 3 :b 4) 5))
-  (bar 1 2 3 4 nil 4 (+ (foo 1 2 :a 3 :b 4) 5)))
+  ^(let ((,%new-val-sym% (+ (foo 1 2 :a 3 :b 4) 5)))
+    (bar 1 2 3 4 () 4 ,%new-val-sym%)))
diff --git a/txr.1 b/txr.1
index 5377e3b4..1ae61d78 100644
--- a/txr.1
+++ b/txr.1
@@ -36203,16 +36203,6 @@ 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 set-form
 argument specifies an expression which generates the code for storing a new
-- 
cgit v1.2.3