diff --git a/lib/chibi/snow/commands.scm b/lib/chibi/snow/commands.scm index 988f632f..fa6890d4 100644 --- a/lib/chibi/snow/commands.scm +++ b/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))) diff --git a/lib/chibi/snow/commands.sld b/lib/chibi/snow/commands.sld index 5f4c7698..f8134bc4 100644 --- a/lib/chibi/snow/commands.sld +++ b/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) diff --git a/lib/chibi/snow/interface.scm b/lib/chibi/snow/interface.scm index 3b5440a8..e0866648 100644 --- a/lib/chibi/snow/interface.scm +++ b/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)) diff --git a/lib/chibi/snow/utils.scm b/lib/chibi/snow/utils.scm index 576e1ea7..1ba1126d 100644 --- a/lib/chibi/snow/utils.scm +++ b/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) diff --git a/tools/snow-chibi b/tools/snow-chibi index 218f04f8..df6b2e95 100755 --- a/tools/snow-chibi +++ b/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 ...))