snow: extract feature list for cond-expand

Currently a package's cond-expand contains the symbol of the target
implementation and optionally more from config file. Execute a
command (once) on target implementation to add their full feature list,
making it available for each package to use.

All of these Schemes are tested. Larceny is just too annoying to get the
feature list (no one-liner, and it could take a while) so Larceny stays
the current behavior.

There is a small unrelated change here: the gosh command to get
version. We don't need to call (exit), if stdin is closed properly (it
should) then gosh should exit regardless.

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)