diff --git a/lib/chibi/snow/commands.scm b/lib/chibi/snow/commands.scm index 343b60e6..240c09a7 100644 --- a/lib/chibi/snow/commands.scm +++ b/lib/chibi/snow/commands.scm @@ -3,31 +3,10 @@ ;; This code was written by Alex Shinn in 2014 and placed in the ;; Public Domain. All warranties are disclaimed. -(define known-implementations - '((chibi "chibi-scheme" (chibi-scheme -V) "0.7.3") - (chicken "chicken" (csi -release) "4.9.0") - (cyclone "cyclone" (icyc -vn) "0.5.3") - (foment "foment") - (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)) + (not (third spec)) (conf-get cfg 'skip-version-checks?) (let ((version (impl->version (car spec) (third spec)))) (or (and version (version>=? version (fourth spec))) diff --git a/lib/chibi/snow/package.scm b/lib/chibi/snow/package.scm index 8451ca3d..c0f6d0df 100644 --- a/lib/chibi/snow/package.scm +++ b/lib/chibi/snow/package.scm @@ -443,8 +443,10 @@ #t) (cond ((symbol? test) - (or (eq? 'else test) (eq? impl test) - (memq test (conf-get-list config 'features)))) + (or (eq? test 'else) + (eq? test impl) + (memq test (conf-get-list config 'features)) + (memq test (impl->features impl)))) ((pair? test) (case (car test) ((not) (not (check-cond-expand impl config (cadr test)))) diff --git a/lib/chibi/snow/package.sld b/lib/chibi/snow/package.sld index f906bc47..111dfaf8 100644 --- a/lib/chibi/snow/package.sld +++ b/lib/chibi/snow/package.sld @@ -30,12 +30,14 @@ (srfi 1) (srfi 115) (chibi snow interface) + (chibi snow utils) (chibi bytevector) (chibi config) (chibi crypto md5) (chibi crypto rsa) (chibi crypto sha2) (chibi pathname) + (chibi process) (chibi string) (chibi tar) (chibi uri) diff --git a/lib/chibi/snow/utils.scm b/lib/chibi/snow/utils.scm index fa9c30b5..a7b3008e 100644 --- a/lib/chibi/snow/utils.scm +++ b/lib/chibi/snow/utils.scm @@ -1,3 +1,72 @@ +(define (write-to-string x) + (call-with-output-string (lambda (out) (write x out)))) + +(define known-implementations + `((chibi "chibi-scheme" (chibi-scheme -V) "0.7.3" + ,(delay + (process->sexp + '(chibi-scheme -p "(features)")))) + (chicken "chicken" (csi -release) "4.9.0" + ;; work around Chicken's write() not quoting 64bit and + ;; 32bit properly + ,(delay + (process->sexp + `(csi -R r7rs -R srfi-1 -e ,(write-to-string + '(write + (filter (lambda (x) + (not (or (eq? x '|64bit|) + (eq? x '|32bit|)))) + (features)))))))) + (cyclone "cyclone" (icyc -vn) "0.5.3" + ,(delay + (process->sexp + '(icyc -p "(features)")))) + (foment "foment" #f #f + ,(delay + (process->sexp + '(foment -e "(write (features))")))) + (gauche "gosh" (gosh -E "print (gauche-version)") "0.9.4" + ,(delay + (process->sexp + '(gosh -uscheme.base -e "(write (features))")))) + (kawa "kawa" (kawa --version) "2.0" + ,(delay + (process->sexp + '(kawa -e "(write (features))")))) + (larceny "larceny" (larceny --version) "v0.98" + ,(delay '())) + (sagittarius "sagittarius" #f #f + ,(delay + (process->sexp + '(sagittarius -I "(scheme base)" -e "(write (features))")))))) + +(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 (target-is-host? impl) + (case impl + ((chibi) (cond-expand (chibi #t) (else #f))) + ((gauche) (cond-expand (gauche #t) (else #f))) + ((sagittarius) (cond-expand (sagittarius #t) (else #f))) + (else #f))) + +(define (impl->features impl) + (cond + ((target-is-host? impl) + (features)) + ((assq impl known-implementations) + => (lambda (impl) + (force (fifth impl)))) + (else '()))) (define (find-in-path file . o) (any (lambda (dir) @@ -17,9 +86,6 @@ (and (pred x) x)))))) dirs))) -(define (write-to-string x) - (call-with-output-string (lambda (out) (write x out)))) - (define (display-to-string x) (call-with-output-string (lambda (out) diff --git a/lib/chibi/snow/utils.sld b/lib/chibi/snow/utils.sld index 06117428..e62d3cd0 100644 --- a/lib/chibi/snow/utils.sld +++ b/lib/chibi/snow/utils.sld @@ -4,9 +4,12 @@ write-to-string display-to-string resource->bytevector uri-normalize uri-directory version-split version-compare version>? version>=? - topological-sort) + topological-sort + known-implementations impl->version impl->features) (import (scheme base) + (scheme char) (scheme file) + (scheme lazy) (scheme read) (scheme write) (scheme process-context)