New place-mutating operators.

* share/txr/stdlib/place.tl (pinc, pdec, test-set, test-clear,
compare-swap, test-inc, test-dec): New macros.

* txr.1: Documented.

2 files changed, 277 insertions, 0 deletions

diff --git a/share/txr/stdlib/place.tl b/share/txr/stdlib/place.tl
index 0fdbfcc8..bd2f47de 100644
--- a/share/txr/stdlib/place.tl
+++ b/share/txr/stdlib/place.tl
@@ -244,6 +244,26 @@
       (3 ^(,setter (pppred (,getter))))
       (t ^(,setter (- (,getter) ,delta))))))
 
+(defmacro pinc (place : (delta 1) :env env)
+  (with-gensyms (oldval)
+    (with-update-expander (getter setter) place env
+      (caseql delta
+        (0 place)
+        (1 ^(let ((,oldval (,getter))) (,setter (succ ,oldval)) ,oldval))
+        (2 ^(let ((,oldval (,getter))) (,setter (ssucc ,oldval)) ,oldval))
+        (3 ^(let ((,oldval (,getter))) (,setter (sssucc ,oldval)) ,oldval))
+        (t ^(let ((,oldval (,getter))) (,setter (+ ,oldval, delta)) ,oldval))))))
+
+(defmacro pdec (place : (delta 1) :env env)
+  (with-gensyms (oldval)
+    (with-update-expander (getter setter) place env
+      (caseql delta
+        (0 place)
+        (1 ^(let ((,oldval (,getter))) (,setter (pred ,oldval)) ,oldval))
+        (2 ^(let ((,oldval (,getter))) (,setter (ppred ,oldval)) ,oldval))
+        (3 ^(let ((,oldval (,getter))) (,setter (pppred ,oldval)) ,oldval))
+        (t ^(let ((,oldval (,getter))) (,setter (- ,oldval, delta)) ,oldval))))))
+
 (defmacro swap (place-0 place-1 :env env)
   (with-gensyms (tmp)
     (with-update-expander (getter-0 setter-0) place-0 env
@@ -298,6 +318,29 @@
             (,setter-f (shift ,*rplaces ,tmp))
             ,tmp))))))
 
+(defmacro test-set (:env env place)
+  (with-update-expander (getter setter) place env
+    ^(unless (,getter)
+       (,setter t))))
+
+(defmacro test-clear (:env env place)
+  (with-update-expander (getter setter) place env
+    ^(when (,getter)
+       (,setter nil)
+       t)))
+
+(defmacro compare-swap (:env env comp-fun place comp-val store-val)
+  (with-update-expander (getter setter) place env
+    ^(when (,comp-fun (,getter) ,comp-val)
+       (,setter ,store-val)
+       t)))
+
+(defmacro test-inc (place : (delta 1) (upfrom-val 0))
+  ^(eql (pinc ,place ,delta) ,above-val))
+
+(defmacro test-dec (place : (delta 1) (downto-val 0))
+  ^(eql (dec ,place ,delta) ,downto-val))
+
 (defmacro del (place :env env)
   (with-delete-expander (deleter) place env
     ^(,deleter)))
diff --git a/txr.1 b/txr.1
index eeb8cf56..c07bc174 100644
--- a/txr.1
+++ b/txr.1
@@ -11230,6 +11230,46 @@ Logically toggles the Boolean value of
 .metn place ,
 and returns the new value.
 
+.meIP (test-set << place )
+If
+.meta place
+contains
+.codn nil ,
+stores
+.code t
+into the place and returns
+.code t
+to indicate that the store took place.
+Otherwise does nothing and returns
+.codn nil .
+
+.meIP (test-clear << place )
+If
+.meta place
+contains a Boolean true value, stores
+.code nil
+into the place and returns
+.code t
+to indicate that the store took place.
+Otherwise does nothing and returns
+.codn nil .
+
+.meIP (compare-swap < place < cmp-fun < cmp-val << store-val )
+Examines the value of
+.meta place
+and compares it to
+.meta cmp-val
+using the comparison function given by the function name
+.metn cmp-fun .
+If the comparison is false, returns
+.codn nil .
+Otherwise, stores the
+.meta store-val
+value into
+.meta place
+and returns
+.codn t .
+
 .meIP (inc < place <> [ delta ])
 Increments
 .meta place
@@ -11244,6 +11284,56 @@ by
 .metn delta ,
 which defaults to 1, and returns the new value.
 
+.meIP (pinc < place <> [ delta ])
+Increments
+.meta place
+by
+.metn delta ,
+which defaults to 1, and returns the old value.
+
+.meIP (pdec < place <> [ delta ])
+Decrements
+.meta place
+by
+.metn delta ,
+which defaults to 1, and returns the old value.
+
+.meIP (test-inc < place >> [ delta <> [ from-val ]])
+Increments
+.meta place
+by
+.meta delta
+and returns
+.code t
+if the previous value was
+.code eql
+to
+.metn from-val ,
+where
+.meta delta
+defaults to 1
+and
+.meta from-val
+defaults to zero.
+
+.meIP (test-dec < place >> [ delta <> [ to-val ]])
+Decrements
+.meta place
+by
+.meta delta
+and returns
+.code t
+if the new value is
+.code eql
+to
+.metn to-val ,
+where
+.meta delta
+defaults to 1
+and
+.meta to-val
+defaults to 0.
+
 .meIP (swap < left-place << right-place )
 Exchanges the values of
 .meta left-place
@@ -25981,6 +26071,79 @@ and if it previously held a value other than
 it is set to
 .codn nil .
 
+.coNP Macros @ test-set and @ test-clear
+.synb
+.mets (test-set << place )
+.mets (test-clear << place )
+.syne
+.desc
+The
+.code test-set
+macro examines the value of
+.metn place .
+If it is
+.code nil
+then it stores
+.code t
+into the place, and returns
+.codn t .
+Otherwise it leaves
+.meta place
+unchanged and returns
+.codn nil .
+
+The
+.code test-clear
+macro examines the value of
+.metn place .
+If it is Boolean true (any value except
+.codn nil )
+then it stores
+.code nil
+into the place, and returns
+.codn t .
+Otherwise it leaves
+.meta place
+unchanged and returns
+.codn nil .
+
+.coNP Macro @ compare-swap
+.synb
+.mets (compare-swap < place < cmp-fun < cmp-val << store-val )
+.syne
+.desc
+The
+.code compare-swap
+macro examines the value of
+.meta place
+and compares it to
+.meta cmp-val
+using the comparison function given by the function name
+.metn cmp-fun .
+
+This comparison takes places as if by evaluating the expression
+.meti >> ( cmp-fun < value << cmp-val )
+where
+.meta value
+denotes the current value of
+.metn place .
+
+If the comparison is false,
+.meta place
+is not modified, the
+.meta store-val
+expression is not evaluated, and the macro returns
+.codn nil .
+
+If the comparison is true, then
+.code compare-swap
+evaluates the
+.meta store-val
+expression, stores the resulting value into
+.meta place
+and returns
+.codn t .
+
 .coNP Macros @ inc and @ dec
 .synb
 .mets (inc < place <> [ delta ])
@@ -26017,6 +26180,77 @@ except that addition is replaced by subtraction. The similarly defaulted
 .meta delta
 value is subtracted from the previous value of the place.
 
+.coNP Macros @ pinc and @ pdec
+.synb
+.mets (pinc < place <> [ delta ])
+.mets (pdec < place <> [ delta ])
+.syne
+.desc
+The macros
+.code pinc
+and
+.code pdec
+are very similar to
+.code inc
+and
+.codn dec .
+
+The only difference is that they return the previous value of
+.meta place
+rather than the incremented value.
+
+.coNP Macros @ test-inc and @ test-dec
+.synb
+.mets (test-inc < place >> [ delta <> [ from-val ]])
+.mets (test-dec < place >> [ delta <> [ to-val ]])
+.syne
+.desc
+The
+.code test-inc
+and
+.code test-dec
+macros provide combined operations which change the value of a place and
+provide a test whether, respectively, a certain previous value was
+overwritten, or a certain new value was attained. By default, this tested
+value is zero.
+
+The
+.code test-inc
+macro notes the prior value of
+.meta place
+and then updates it with that value, plus
+.metn delta ,
+which defaults to 1. If the prior value is
+.code eql
+to
+.meta from-val
+then it returns
+.codn t ,
+otherwise
+.codn nil .
+The default value of
+.meta from-val
+is zero.
+
+The
+.code test-dec
+macro produces a new value by subtracting
+.meta delta
+from the value of
+.metn place .
+The argument
+.meta delta
+defaults to 1. The new value is stored into
+.metn place .
+If the new value is
+.code eql
+to
+.meta to-val
+then
+.code t
+is returned, otherwise
+.codn nil .
+
 .coNP Macro @ swap
 .synb
 .mets (swap < left-place << right-place )