From 920b5eb02b1e1fd1c6c28395cade04e81fbee2bb Mon Sep 17 00:00:00 2001
From: Paul Khuong <pvk@pvk.ca>
Date: Thu, 14 Nov 2013 16:51:18 -0500
Subject: [PATCH] New function SB-EXT:ASSERT-VERSION->=

Executing (sb-ext:assert-version->= 1 1 13) signals a continuable
error if the running SBCL is older than 1.1.13 (and an undefined
function error before that).

Based on a patch by Philip Munksgaard.

Closes lp#674372.
---
 NEWS                           |    4 ++++
 doc/manual/beyond-ansi.texinfo |    1 +
 package-data-list.lisp-expr    |    5 ++++-
 src/code/late-extensions.lisp  |   48 ++++++++++++++++++++++++++++++++++++++++
 tests/interface.pure.lisp      |    7 ++++++
 5 files changed, 64 insertions(+), 1 deletion(-)

diff --git a/NEWS b/NEWS
index ff74987..c9f52c7 100644
--- a/NEWS
+++ b/NEWS
@@ -13,6 +13,10 @@ changes relative to sbcl-1.1.13:
     include error messages instead of error codes.
   * enhancement: run-sbcl.sh is usefully handled by rlwrap.  Thanks to William
     Cushing. (lp#1249183)
+  * enhancement: new function SB-EXT:ASSERT-VERSION->= accepts a version
+    specification (multiple integer arguments) and signals a continuable error
+    if the current SBCL version is lower (older) than the specification.
+    (lp#674372)
   * bug fix: EQUALP now compares correctly structures with raw slots larger
     than a single word.
   * bug fix: contribs couldn't be built on Windows with MinGW.
diff --git a/doc/manual/beyond-ansi.texinfo b/doc/manual/beyond-ansi.texinfo
index 75b1433..9825343 100644
--- a/doc/manual/beyond-ansi.texinfo
+++ b/doc/manual/beyond-ansi.texinfo
@@ -795,6 +795,7 @@ different type of generator.
 @include fun-sb-ext-delete-directory.texinfo
 @include fun-sb-ext-get-time-of-day.texinfo
 @include macro-sb-ext-wait-for.texinfo
+@include fun-sb-ext-version-assert.texinfo
 
 @node Stale Extensions
 @comment  node-name,  next,  previous,  up
diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr
index 94fe875..ca67d02 100644
--- a/package-data-list.lisp-expr
+++ b/package-data-list.lisp-expr
@@ -871,7 +871,10 @@ like *STACK-TOP-HINT* and unsupported stuff like *TRACED-FUN-LIST*."
                #!+sb-simd-pack "%SIMD-PACK-UB32S"
                #!+sb-simd-pack "%SIMD-PACK-UB64S"
                #!+sb-simd-pack "%SIMD-PACK-DOUBLES"
-               #!+sb-simd-pack "%SIMD-PACK-SINGLES"))
+               #!+sb-simd-pack "%SIMD-PACK-SINGLES"
+
+               ;; versioning utility
+               "ASSERT-VERSION->="))
 
    #s(sb-cold:package-data
       :name "SB!FORMAT"
diff --git a/src/code/late-extensions.lisp b/src/code/late-extensions.lisp
index 48ee190..bcfaafe 100644
--- a/src/code/late-extensions.lisp
+++ b/src/code/late-extensions.lisp
@@ -436,3 +436,51 @@ Works on all CASable places."
              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))))
diff --git a/tests/interface.pure.lisp b/tests/interface.pure.lisp
index 7e43f97..824c25e 100644
--- a/tests/interface.pure.lisp
+++ b/tests/interface.pure.lisp
@@ -168,3 +168,10 @@
     (funcall fun1 1/7)
     (funcall fun1 1/100000000000000000000000000)
     (assert (< (- (get-universal-time) start-time) 2))))
+
+(with-test (:name :version-assert-ok)
+  (sb-ext:assert-version->= 1 1 13))
+
+(with-test (:name :version-assert-fails)
+  (assert (raises-error?
+           (sb-ext:assert-version->= most-positive-fixnum))))
-- 
1.7.10.4