Adding pset operator.

* place.tl (pset): New macro.

* lisplib.c (set_place_dlt_entries): Add pset.

3 files changed, 29 insertions, 1 deletions

diff --git a/ChangeLog b/ChangeLog
index 96c1bc29..9ba23553 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,5 +1,13 @@
 2015-05-09  Kaz Kylheku  <kaz@kylheku.com>
 
+	Adding pset operator.
+
+	* place.tl (pset): New macro.
+
+	* lisplib.c (set_place_dlt_entries): Add pset.
+
+2015-05-09  Kaz Kylheku  <kaz@kylheku.com>
+
 	* place.tl (set): Take multiple place/value pairs. Allow zero
 	arguments.
 
diff --git a/lisplib.c b/lisplib.c
index 1be90260..73b739ee 100644
--- a/lisplib.c
+++ b/lisplib.c
@@ -53,7 +53,7 @@ static void set_place_dlt_entries(val dlt, val fun)
     lit("call-delete-expander)"),
     lit("with-update-expander"), lit("with-clobber-expander"),
     lit("with-delete-expander"),
-    lit("set"), lit("zap"), lit("flip"), lit("inc"), lit("dec"),
+    lit("set"), lit("pset"), lit("zap"), lit("flip"), lit("inc"), lit("dec"),
     lit("push"), lit("pop"), lit("swap"), lit("shift"), lit("rotate"),
     lit("del"),
     nil
diff --git a/place.tl b/place.tl
index 750e0c6c..a948f07b 100644
--- a/place.tl
+++ b/place.tl
@@ -119,6 +119,26 @@
         ^(progn ,*assign-forms)
         (car assign-forms))))
 
+  (defmacro pset (:env env . place-value-pairs)
+    (let ((len (length place-value-pairs)))
+      (cond
+        ((oddp len) (sys:eval-err "pset: arguments must be pairs"))
+        ((<= len 2) ^(set ,*place-value-pairs))
+        (t (let* ((pvtgs (mapcar (tb ((a b))
+                                   (list a b (gensym) (gensym) (gensym)))
+                                 (tuples 2 place-value-pairs)))
+                  (ls (reduce-left (tb ((lets stores) (place value temp getter setter))
+                                       (list ^((,temp ,value) ,*lets)
+                                             ^((,setter ,temp) ,*stores)))
+                                   pvtgs '(nil nil)))
+                  (lets (first ls))
+                  (stores (second ls))
+                  (body-form ^(let (,*lets) ,*stores)))
+             (reduce-left (tb (accum-form (place value temp getter setter))
+                            (call-update-expander getter setter
+                                                  place env accum-form))
+                          pvtgs body-form))))))
+
   (defmacro zap (place :env env)
     (with-update-expander (getter setter) place env
       ^(prog1 (,getter) (,setter nil))))