New slet macro.

* lisplib.c (place_set_entries): Add slet symbol to autoload
list for place.tl.

* share/txr/stdlib/place.tl (sys:r-s-let-expander): New
function.
(rlet): Replace body with call to sys:r-s-let-expander.
(slet): New macro.

* txr.1: Clarification and corrections in rlet description
and example. rlet will in fact handle the three-variable
rotation case because, since a is not a constant expression,
(rlet ((temp a)) ...) reduces to let.
Documented new slet.

3 files changed, 40 insertions, 12 deletions

diff --git a/lisplib.c b/lisplib.c
index bc664683..49e4841e 100644
--- a/lisplib.c
+++ b/lisplib.c
@@ -62,7 +62,7 @@ static val place_set_entries(val dlt, val fun)
     lit("get-update-expander"), lit("get-clobber-expander"),
     lit("get-delete-expander"),
     lit("place-form-p"),
-    lit("rlet"), lit("with-gensyms"),
+    lit("rlet"), lit("slet"), lit("with-gensyms"),
     lit("call-update-expander"), lit("call-clobber-expander"),
     lit("call-delete-expander)"),
     lit("with-update-expander"), lit("with-clobber-expander"),
diff --git a/share/txr/stdlib/place.tl b/share/txr/stdlib/place.tl
index bd2f47de..b0e1958f 100644
--- a/share/txr/stdlib/place.tl
+++ b/share/txr/stdlib/place.tl
@@ -115,16 +115,23 @@
                          (sys:eval-err "~s is not a deletable place" place)))
       (t (sys:eval-err "form ~s is not syntax denoting a deletable place" place)))))
 
-(defmacro rlet (bindings :env e . body)
-  (let ((exp-bindings (mapcar (aret ^(,@1 ,(macroexpand @2 e))) bindings)))
-    (let ((renames [keep-if constantp exp-bindings second])
-          (regular [remove-if constantp exp-bindings second]))
+(macro-time
+  (defun sys:r-s-let-expander (bindings body e pred)
+    (let ((exp-bindings (mapcar (aret ^(,@1 ,(macroexpand @2 e))) bindings)))
+      (let ((renames [keep-if pred exp-bindings second])
+            (regular [remove-if pred exp-bindings second]))
       (cond ((and renames regular)
               ^(symacrolet ,renames
                  (let ,regular ,*body)))
             (renames ^(symacrolet ,renames ,*body))
             (regular ^(let ,regular ,*body))
-            (t ^(progn ,*body))))))
+            (t ^(progn ,*body)))))))
+
+(defmacro rlet (bindings :env e . body)
+  [sys:r-s-let-expander bindings body e constantp])
+
+(defmacro slet (bindings :env e . body)
+  (sys:r-s-let-expander bindings body e [orf constantp bindable]))
 
 (defmacro with-gensyms (syms . body)
   ^(let ,(zip syms (repeat '((gensym)))) ,*body))
diff --git a/txr.1 b/txr.1
index c07bc174..109081bb 100644
--- a/txr.1
+++ b/txr.1
@@ -27738,8 +27738,10 @@ in that
 .code rlet
 assumes that those
 .metn sym -s
-which have constant
-.metn init-form -s
+whose
+.metn init-form -s,
+after macro expansion,
+are constant expressions
 (according to the
 .code constantp
 function) may be safely implemented as a symbol macro rather than a lexical
@@ -27753,16 +27755,16 @@ code with fewer temporary variables.
 
 On the other hand,
 .code rlet
-is not suitable in situations when true variables are required, which
+is not suitable in some situations when true variables are required, which
 are assignable, and provide temporary storage.
 
 .TP* "Example:"
 
 .cblk
   ;; WRONG! Exchange two variables, a and b:
-  (rlet ((temp a))
-    (set a b)
-    (set b temp))
+  (rlet ((flag nil))
+    ;; code which mutates flag
+    (flip flag)) ;; error: flag macro-expands to nil
 
   ;; Demonstration of constant-propagation
   (let ((a 42))
@@ -27791,6 +27793,25 @@ turning the expression
 into
 .codn "(+ 1 y)" .
 
+.coNP Macro @ slet
+.synb
+.mets (slet >> ({( sym << init-form )}*) << body-form *)
+.syne
+.desc
+The macro
+.code slet
+a weaker form of the
+.code rlet
+macro. Just like
+.codn rlet ,
+.code slet
+reduces bindings initialized by constant expressions
+to symbol macros. In addition, unlike
+.codn rlet ,
+.code slet
+also reduces to symbol macros those bindings which
+are initialized by symbol expressions (values of variables).
+
 .coNP Macro @ define-accessor
 .synb
 .mets (define-accessor < get-function << set-function )