Enabling chicken snow installs, and adding to tests.

Smarter handling of requested vs. available impl installs.

lib/chibi/snow/commands.scm

@@ -21,24 +21,46 @@
                       (and (pred x) x))))))
          dirs)))
 
-(define (available-implementations cfg)
+(define known-implementations
-  (define (find prog name) (if (find-in-path prog) (list name) '()))
+  '((chibi "chibi-scheme")
-  (append (cond-expand
+    (chicken "chicken")
-           (chibi (list 'chibi))
+    (foment "foment")
-           (else (find "chibi-scheme" 'chibi)))
+    (gauche "gosh")
-          (find "foment" 'foment)
+    (guile "guile")
-          (find "gosh" 'gauche)
+    (kawa "kawa")
-          (find "guile" 'guile)
+    (larceny "larceny")
-          (find "kawa" 'kawa)
+    (sagittarius "sagittarius")))
-          (find "larceny" 'larceny)
-          (find "sagittarius" 'sagittarius)))
 
 (define (conf-selected-implementations cfg)
-  (let ((requested (conf-get-list cfg 'implementations '(chibi)))
+  (let ((requested (conf-get-list cfg 'implementations '(chibi))))
-        (available (available-implementations cfg)))
+    (let lp ((ls (if (memq 'all requested)
-    (if (memq 'all requested)
+                     (append (map car known-implementations) requested)
-        available
+                     requested))
-        (lset-intersection eq? requested available))))
+             (res '()))
+      (cond
+       ((null? ls)
+        (if (null? res)
+            (warn "no implementations available"))
+        (reverse res))
+       ((memq (car ls) res)
+        (lp (cdr ls) res))
+       ((assq (car ls) known-implementations)
+        => (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?"))
+               (lp (cdr ls) (cons (car ls) res)))
+              (else
+               (warn "ignoring unavailable implementation: " (car ls))
+               (lp (cdr ls) res)))))
+       ((yes-or-no? cfg "Unknown implementation: " (car ls)
+                    " - try to install anyway?")
+        (lp (cdr ls) (cons (car ls) res)))
+       (else
+        (warn "ignoring unknown implementation: " (car ls))
+        (lp (cdr ls) res))))))
 
 (define (conf-for-implementation cfg impl)
   (conf-specialize cfg 'implementation impl))
@@ -1012,6 +1034,10 @@
          (if lib-path
              `(,@chibi -A ,install-dir -A ,lib-path ,file)
              `(,@chibi -A ,install-dir ,file))))
+      ((chicken)
+       (if lib-path
+           `(csi -R r7rs -I ,install-dir -I ,lib-path -s ,file)
+           `(csi -R r7rs -I ,install-dir -s ,file)))
       ((foment)
        (if lib-path
            `(foment -A ,install-dir -A ,lib-path ,file)
@@ -1065,7 +1091,13 @@
      ((and test-file command
            (not (or (conf-get cfg '(command install skip-tests?))
                     (conf-get cfg '(command upgrade skip-tests?)))))
-      (or (match (process->output+error+status command)
+      ;; For chicken we need to run the tests from within the package
+      ;; directory to be able to locate the libraries (see chicken
+      ;; trac #736).
+      (or (match ((if (eq? impl 'chicken)
+                      (lambda (f) (with-directory dir f))
+                      (lambda (f) (f)))
+                  (lambda () (process->output+error+status command)))
             ((output error status)
              (cond
               ((or (not (zero? status))
@@ -1131,6 +1163,14 @@
     => (lambda (prefix) (make-path prefix "share/snow" impl)))
    (else (car (get-install-dirs impl cfg)))))
 
+(define (get-install-library-dir impl cfg)
+  (cond
+   ((conf-get cfg 'install-library-dir))
+   ((conf-get cfg 'install-prefix)
+    => (lambda (prefix) (make-path prefix "share/snow" impl)))
+   ((eq? impl 'chicken) (make-path "/usr/local/lib" impl 7))
+   (else (make-path "/usr/local/lib" impl))))
+
 (define (get-install-binary-dir impl cfg)
   (cond
    ((conf-get cfg 'install-binary-dir))
@@ -1225,6 +1265,23 @@
             dest-file))
         include-files)))))
 
+(define (chicken-installer impl cfg library dir)
+  (let* ((library-file (get-library-file cfg library))
+         (library-base (string-join (map x->string (library-name library)) "."))
+         (install-dir (get-install-library-dir impl cfg))
+         (so-path (string-append library-base ".so"))
+         (imp-path (string-append library-base ".import.scm"))
+         (dest-so-path (make-path install-dir so-path))
+         (dest-imp-path (make-path install-dir imp-path)))
+    (install-directory cfg install-dir)
+    (let ((meta-dir
+           (string-join (map x->string (drop-right (library-name library) 1))
+                        "/")))
+      (install-directory cfg (make-path install-dir meta-dir)))
+    (install-file cfg (make-path dir so-path) dest-so-path)
+    (install-file cfg (make-path dir imp-path) dest-imp-path)
+    (list dest-so-path dest-imp-path)))
+
 (define (default-program-installer impl cfg prog dir)
   (let* ((program-file (get-program-file cfg prog))
          (dest-program-file (program-install-name prog))
@@ -1236,10 +1293,18 @@
 ;; installers should return the list of installed files
 (define (lookup-installer installer)
   (case installer
+    ((chicken) chicken-installer)
     (else default-installer)))
 
+(define (installer-for-implementation impl cfg)
+  (case impl
+    ((chicken) 'chicken)
+    (else 'default)))
+
 (define (install-library impl cfg library dir)
-  (let ((installer (lookup-installer (conf-get cfg 'installer))))
+  (let ((installer
+         (lookup-installer (or (conf-get cfg 'installer)
+                               (installer-for-implementation impl cfg)))))
     (installer impl cfg library dir)))
 
 ;; The default builder just renames files per implementation.
@@ -1294,12 +1359,36 @@
                  '()
                  (list (list library-file dest-library-file)))))))
 
+(define (chicken-builder impl cfg library dir)
+  (let* ((library-file (make-path dir (get-library-file cfg library)))
+         (library-base (string-join (map x->string (library-name library)) "."))
+         (module-name (string-join (map x->string (library-name library)) "."))
+         (so-path (make-path dir (string-append library-base ".so")))
+         (imp-path (string-append library-base ".import.scm")))
+    (with-directory
+     dir
+     (lambda ()
+       (let ((res (system 'csc '-R 'r7rs '-X 'r7rs '-s '-J '-o so-path
+                          '-I (path-directory library-file) library-file)))
+         (and (or (and (pair? res) (zero? (cadr res)))
+                  (yes-or-no? cfg "chicken failed to build: "
+                              (library-name library-name)
+                              " - install anyway?"))
+              library))))))
+
 (define (lookup-builder builder)
   (case builder
+    ((chicken) chicken-builder)
     (else default-builder)))
 
+(define (builder-for-implementation impl cfg)
+  (case impl
+    ((chicken) 'chicken)
+    (else 'default)))
+
 (define (build-library impl cfg library dir)
-  (let ((builder (lookup-builder (conf-get cfg 'builder))))
+  (let ((builder (lookup-builder (or (conf-get cfg 'builder)
+                                     (builder-for-implementation impl cfg)))))
     (builder impl cfg library dir)))
 
 (define (build-program impl cfg prog dir)
@@ -1366,7 +1455,7 @@
      "pkg"
      (lambda (dir)
        (tar-extract snowball (lambda (f) (make-path dir (path-strip-top f))))
-       (let ((libs (map (lambda (lib) (build-library impl cfg lib dir))
+       (let ((libs (filter-map (lambda (lib) (build-library impl cfg lib dir))
                                (package-libraries pkg))))
          (if (test-package impl cfg pkg dir)
              (let ((installed-files
@@ -1409,10 +1498,14 @@
    (lambda (pkg) (install-package repo impl cfg pkg))
    pkgs))
 
+;; --always-yes implies first candidate, --always-no implies none
 (define (select-best-candidate impl cfg repo candidates)
   (cond
-   ((null? (cdr candidates))
+   ((or (null? (cdr candidates))
+        (conf-get cfg 'always-yes?))
     (car candidates))
+   ((conf-get cfg 'always-no?)
+    #f)
    (else
     (display "Select a package:\n")
     (let lp ((ls candidates) (i 1))
@@ -1457,7 +1550,7 @@
             (lp (cdr ls) res ignored))
            ((and (null? candidates) (assoc (car ls) current))
             (if (member (car ls) lib-names)
-                (warn "skipping already installed library" (car ls)))
+                (warn "skipping already installed library: " (car ls)))
             (lp (cdr ls) res (cons (car ls) ignored)))
            ((and (null? candidates)
                  (not (assoc (car ls) current))
@@ -1468,7 +1561,8 @@
                         (memq (caar ls) (cons impl '(scheme))))
                        (else (eq? (caar ls) 'scheme)))))
             ;; assume certain core libraries already installed
-            (lp (cdr ls) res ignored))
+            ;; (info "assuming core library installed: " (car ls))
+            (lp (cdr ls) res (cons (car ls) ignored)))
            ((and (null? candidates) (member (car ls) lib-names))
             (die 2 "Can't find package: " (car ls)))
            ((null? candidates)
@@ -1478,13 +1572,16 @@
               (lp (cdr ls) res (cons (car ls) ignored)))
              (else
               (die 2 "No candidates, not installing: " (car ls)))))
-           (else
+           ((select-best-candidate impl cfg repo candidates)
-            (let ((pkg (select-best-candidate impl cfg repo candidates)))
+            => (lambda (pkg)
                  (lp (append (package-dependencies impl cfg pkg)
                              (package-test-dependencies impl cfg pkg)
                              (cdr ls))
                      (cons pkg res)
-                  ignored))))))))))
+                     ignored)))
+           (else
+            (warn "no candidate selected")
+            (lp (cdr ls) res ignored)))))))))
 
 ;; First lookup dependencies for all implementations so we can
 ;; download in a single batch.  Then perform the installations a

tests/snow/snow-tests.scm

@@ -1,16 +1,37 @@
 (import (scheme base) (scheme write) (scheme process-context) (srfi 1)
         (chibi ast) (chibi filesystem) (chibi match) (chibi pathname)
-        (chibi process) (chibi string) (chibi test))
+        (chibi process) (chibi regexp) (chibi string) (chibi test))
 
 (test-begin "snow")
 
 ;; setup a temp root to install packages
-(define install-prefix "tests/snow/tmp-root")
+(define install-prefix (make-path (current-directory) "tests/snow/tmp-root"))
 (define install-libdir (make-path install-prefix "/share/snow/chibi"))
 (if (file-exists? install-prefix)
     (delete-file-hierarchy install-prefix))
 (create-directory install-prefix)
 
+;; setup chicken install directory with minimum required modules
+(define chicken-lib-dir "/usr/local/lib/chicken/7")
+(define chicken-install-dir (make-path install-prefix "/share/snow/chicken"))
+(create-directory* chicken-install-dir)
+(if (file-exists? chicken-lib-dir)
+    (let ((rx-required
+           '(: (or "chicken" "csi" "data-structures" "extras" "files"
+                   "foreign" "irregex" "lolevel" "make" "matchable"
+                   "modules" "numbers" "ports" "posix" "r7rs" "scheme"
+                   "srfi" "tcp" "types" "utils")
+               (or "." "-")
+               (* any))))
+      (for-each
+      (lambda (file)
+        (if (regexp-matches? rx-required file)
+            (system 'cp
+                    (make-path chicken-lib-dir file)
+                    chicken-install-dir)))
+      (directory-files chicken-lib-dir))))
+(setenv "CHICKEN_REPOSITORY" chicken-install-dir)
+
 ;; ignore any personal config settings
 (setenv "SNOW_CHIBI_CONFIG" "no-such-file")
 
@@ -143,6 +164,12 @@
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; other implementations
 
+(snow ,@repo3 update)
+(snow ,@repo3 --implementations "chicken" install pingala.binomial)
+(let ((status (snow-status --implementations "chicken")))
+  (test-assert (installed-version status '(pingala binomial) 'chicken))
+  (test-assert (installed-version status '(pingala factorial) 'chicken)))
+
 (snow ,@repo3 update)
 (snow ,@repo3 --implementations "foment" install pingala.binomial)
 (let ((status (snow-status --implementations "foment")))

tools/snow-chibi

@@ -68,6 +68,8 @@
     (local-user-repository dirname "repository cache dir for non-root users")
     (install-prefix string "prefix directory for installation")
     (install-source-dir dirname "directory to install library source in")
+    (install-library-dir dirname "directory to install shared libraries in")
+    (install-binary-dir dirname "directory to install programs in")
     (library-extension string "the extension to use for library files")
     (installer symbol "name of installer to use")
     (implementations (list symbol) "impls to install for, or 'all'")