Adding "implementations" command, along with impl version checks where needed.

lib/chibi/snow/commands.scm

@@ -4,19 +4,52 @@
 ;; Public Domain.  All warranties are disclaimed.
 
 (define known-implementations
-  '((chibi "chibi-scheme")
-    (chicken "chicken")
+  '((chibi "chibi-scheme" (chibi-scheme -V) "0.7.3")
+    (chicken "chicken" (csi -p "(chicken-version)") "4.9.0")
     (foment "foment")
-    (gauche "gosh")
-    (guile "guile")
-    (kawa "kawa")
-    (larceny "larceny")
+    (gauche "gosh" (gosh -E "print (gauche-version)" -E exit) "0.9.4")
+    (kawa "kawa" (kawa --version) "2.0")
+    (larceny "larceny" (larceny --version) "v0.98")
     (sagittarius "sagittarius")))
 
+(define (impl->version impl cmd)
+  (let* ((lines (process->string-list cmd))
+         (line (and (pair? lines) (string-split (car lines)))))
+    (and (pair? line)
+         (if (and (pair? (cdr line))
+                  (let ((x (string-downcase (car line)))
+                        (name (symbol->string impl)))
+                    (or (equal? x name)
+                        (equal? x (string-append name "-scheme")))))
+             (cadr line)
+             (car line)))))
+
+(define (impl-available? cfg spec confirm?)
+  (if (find-in-path (cadr spec))
+      (or (null? (cddr spec))
+          (conf-get cfg 'skip-version-checks?)
+          (let ((version (impl->version (car spec) (third spec))))
+            (or (and version (version>=? version (fourth spec)))
+                (let ((msg
+                       (string-append
+                        "Implementation " (symbol->string (car spec))
+                        " is an unsupported version, " version ", but"
+                        " at least " (fourth spec) " is required.")))
+                  (cond
+                   (confirm?
+                    (yes-or-no? cfg msg " Install anyway?"))
+                   (else
+                    (warn msg)
+                    #f))))))
+      (and confirm?
+           (yes-or-no? cfg "Implementation " (car spec) " does not "
+                       " seem to be available, install anyway?"))))
+
 (define (conf-selected-implementations cfg)
   (let ((requested (conf-get-list cfg 'implementations '(chibi))))
     (let lp ((ls (if (memq 'all requested)
-                     (append (map car known-implementations) requested)
+                     (append (map car known-implementations)
+                             (delete 'all requested))
                      requested))
              (res '()))
       (cond
@@ -30,12 +63,10 @@
         => (lambda (x)
              (cond
               ((or (cond-expand (chibi (eq? 'chibi (car ls))) (else #f))
-                   (find-in-path (cadr x))
-                   (yes-or-no? cfg "Implementation " (car ls) " does not "
-                               " seem to be available, install anyway?"))
+                   (impl-available? cfg x #t))
                (lp (cdr ls) (cons (car ls) res)))
               (else
-               (warn "ignoring unavailable implementation: " (car ls))
+               (warn "ignoring unavailable implementation" (car ls))
                (lp (cdr ls) res)))))
        ((yes-or-no? cfg "Unknown implementation: " (car ls)
                     " - try to install anyway?")
@@ -1903,3 +1934,12 @@
      impls
      impl-cfgs)
     (if sexp? (display ")\n"))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; Implementations - show the currently available implementations.
+
+(define (command/implementations cfg spec . args)
+  (for-each
+   (lambda (impl) (write (car impl)) (newline))
+   (filter (lambda (x) (impl-available? cfg x #f))
+           known-implementations)))

lib/chibi/snow/commands.sld

@@ -6,6 +6,7 @@
           command/sign
           command/verify
           command/upload
+          command/implementations
           command/index
           command/install
           command/remove
@@ -15,6 +16,7 @@
           command/update
           command/upgrade)
   (import (scheme base)
+          (scheme char)
           (scheme eval)
           (scheme file)
           (scheme load)

lib/chibi/snow/interface.scm

@@ -13,7 +13,7 @@
   (let ((err (current-error-port)))
     (display "WARNING: " err)
     (display msg err)
-    (display ": " err)
+    (if (pair? args) (display ": " err))
     (if (and (pair? args) (null? (cdr args)))
         (write (car args) err)
         (for-each (lambda (x) (display "\n  " err) (write x err)) args))

lib/chibi/snow/utils.scm

@@ -40,7 +40,7 @@
   (let lp ((as (version-split a))
            (bs (version-split b)))
     (cond
-     ((null? as) (if (null? bs) -1 0))
+     ((null? as) (if (null? bs) 0 -1))
      ((null? bs) 1)
      ((less? (car as) (car bs)) -1)
      ((less? (car bs) (car as)) 1)

tools/snow-chibi

@@ -62,6 +62,8 @@
     (ignore-signature? boolean ("ignore-sig" "ignore-signature")
                        "don't verify package signatures")
     (ignore-digest? boolean ("ignore-digest") "don't verify package checksums")
+    (skip-version-checks? boolean ("skip-version-checks")
+                          "don't verify implementation versions")
     (host string "base uri of snow repository")
     (repository-uri string "uri of snow repository file")
     (local-root-repository dirname "repository cache dir for root")
@@ -140,6 +142,8 @@
   '())
 (define update-spec
   '())
+(define implementations-spec
+  '())
 
 (define app-spec
   `(snow
@@ -190,6 +194,9 @@
      (update
       "force an update of available package status"
       (@ ,update-spec) (,command/update))
+     (implementations
+      "print currently available scheme implementations"
+      (@ ,implementations-spec) (,command/implementations))
      (help
       "print help"
       (,app-help-command args ...))