New function SB-EXT:ASSERT-VERSION->=

[sbcl.git] / src / code / late-extensions.lisp

diff --git a/src/code/late-extensions.lisp b/src/code/late-extensions.lisp
index 7228897..bcfaafe 100644 (file)
--- a/src/code/late-extensions.lisp
+++ b/src/code/late-extensions.lisp
@@ -405,3 +405,82 @@ 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))))))
+
+(defun split-version-string (string)
+  (loop
+    with start = 0
+    and end = (length string)
+    while (and start (< start end))
+    for subversion = (multiple-value-bind (subversion next)
+                         (parse-integer string :start start
+                                               :junk-allowed t)
+                       (setf start
+                             (and subversion
+                                  next
+                                  (< next end)
+                                  (eql #\. (aref string next))
+                                  (1+ next)))
+                       subversion)
+    when subversion
+      collect subversion))
+
+(defun version>= (x y)
+  (unless (or x y)
+    (return-from version>= t))
+  (let ((head-x (or (first x) 0))
+        (head-y (or (first y) 0)))
+    (or (> head-x head-y)
+        (and (= head-x head-y)
+             (version>= (rest x) (rest y))))))
+
+(defun assert-version->= (&rest subversions)
+  #!+sb-doc
+  "Asserts that the current SBCL is of version equal to or greater than
+the version specified in the arguments.  A continuable error is signaled
+otherwise.
+
+The arguments specify a sequence of subversion numbers in big endian order.
+They are compared lexicographically with the runtime version, and versions
+are treated as though trailed by an unbounded number of 0s.
+
+For example, (assert-version->= 1 1 4) asserts that the current SBCL is
+version 1.1.4[.0.0...] or greater, and (assert-version->= 1) that it is
+version 1[.0.0...] or greater."
+  (let ((version (split-version-string (lisp-implementation-version))))
+    (unless (version>= version subversions)
+      (cerror "Disregard this version requirement."
+              "SBCL ~A is too old for this program (version ~{~A~^.~} ~
+               or later is required)."
+              (lisp-implementation-version)
+              subversions))))