Merge pull request #691 from pclouds/snow-impl-features

snow: extract feature list for cond-expand

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)))

lib/chibi/snow/package.scm

@@ -443,8 +443,10 @@
     #t)
   (cond
    ((symbol? test)
-    (or (eq? 'else test) (eq? impl test)
+    (or (eq? test 'else)
-        (memq test (conf-get-list config 'features))))
+        (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))))

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)

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)

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)