X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Flate-extensions.lisp;h=48ee19018a5a4bb5293aed29a97caf77fa574ac0;hb=41791073db3aa668ad5699598edcb567d4eed966;hp=72288977d3e53ca6436ac4de5e25db92dd9f7f6b;hpb=126b9cfb25799ca41210c1a1658de30e1ff372e7;p=sbcl.git

diff --git a/src/code/late-extensions.lisp b/src/code/late-extensions.lisp
index 7228897..48ee190 100644
--- a/src/code/late-extensions.lisp
+++ b/src/code/late-extensions.lisp
@@ -405,3 +405,34 @@ Examples:
        (loop for ,new = (funcall ,update-fn ,@arguments ,old)
              until (eq ,old (setf ,old ,cas-form))
              finally (return ,new)))))
+
+(defmacro atomic-push (obj place &environment env)
+  #!+sb-doc
+  "Like PUSH, but atomic. PLACE may be read multiple times before
+the operation completes -- the write does not occur until such time
+that no other thread modified PLACE between the read and the write.
+
+Works on all CASable places."
+  (multiple-value-bind (vars vals old new cas-form read-form)
+      (get-cas-expansion place env)
+    `(let* (,@(mapcar 'list vars vals)
+            (,old ,read-form)
+            (,new (cons ,obj ,old)))
+       (loop until (eq ,old (setf ,old ,cas-form))
+             do (setf (cdr ,new) ,old)
+             finally (return ,new)))))
+
+(defmacro atomic-pop (place &environment env)
+  #!+sb-doc
+  "Like POP, but atomic. PLACE may be read multiple times before
+the operation completes -- the write does not occur until such time
+that no other thread modified PLACE between the read and the write.
+
+Works on all CASable places."
+  (multiple-value-bind (vars vals old new cas-form read-form)
+      (get-cas-expansion place env)
+    `(let* (,@(mapcar 'list vars vals))
+       (loop for ,old = ,read-form
+             for ,new = (cdr ,old)
+             until (eq ,old (setf ,old ,cas-form))
+             finally (return (car ,old))))))