Adding proper program installation for chicken, plus tests.

lib/chibi/snow/commands.scm

@@ -62,6 +62,13 @@
         (warn "ignoring unknown implementation: " (car ls))
         (lp (cdr ls) res))))))
 
+(define (conf-program-implementation? impl cfg)
+  (cond ((conf-get cfg 'program-implementation)
+         => (lambda (x) (eq? impl x)))
+        (else
+         (let ((ls (conf-selected-implementations cfg)))
+           (or (null? ls) (eq? impl (car ls)))))))
+
 (define (conf-for-implementation cfg impl)
   (conf-specialize cfg 'implementation impl))
 
@@ -248,8 +255,9 @@
         (append (if (pair? deps) (list (cons depends (reverse deps))) '())
                 (if (pair? cond-deps) (reverse cond-deps) '())))))))
 
-(define (make-package-name cfg libs . o)
+(define (make-package-name cfg pkg libs . o)
-  (let ((name (any (lambda (x) (or (library-name x) (program-name x))) libs))
+  (let ((name (or (assoc-get pkg 'name)
+                  (any (lambda (x) (or (library-name x) (program-name x))) libs)))
         (version (and (pair? o) (car o))))
     (cond
      ((not (and (pair? name) (list? name)))
@@ -384,6 +392,7 @@
        (conf-get cfg '(command package output-dir) ".")
        (make-package-name
         cfg
+        package-spec
         (filter (lambda (x) (and (pair? x) (memq (car x) '(library program))))
                 package-spec)
         (package-output-version cfg)))))
@@ -436,6 +445,7 @@
 (define (package-spec+files cfg spec libs)
   (let* ((recursive? (conf-get cfg '(command package recursive?)))
          (programs (conf-get-list cfg '(command package programs)))
+         (name (conf-get cfg '(command package name)))
          (authors (conf-get-list cfg '(command package authors)))
          (test (package-test cfg))
          (version (package-output-version cfg))
@@ -447,7 +457,8 @@
               `(,@(if license `((license ,license)) '())
                 ,@(if version `((version ,version)) '())
                 ,@(if (pair? authors) `((authors ,@authors)) '())
-                ,@(if (pair? maintainers) `((maintainers ,@maintainers)) '())))
+                ,@(if (pair? maintainers) `((maintainers ,@maintainers)) '())
+                ,@(if name `((name ,name)) '())))
              (files '())
              (lib-dirs '())
              (test test)
@@ -838,11 +849,13 @@
   (for-each warn-delete-file (package-installed-files pkg))
   (warn-delete-file (make-path (get-install-source-dir impl cfg)
                                (get-package-meta-file cfg pkg)))
-  (let ((dir (make-path (get-install-source-dir impl cfg)
+  (cond
-                        (package->path cfg pkg))))
+   ((package->path cfg pkg)
-    (if (and (file-directory? dir)
+    => (lambda (path)
-             (= 2 (length (directory-files dir))))
+         (let ((dir (make-path (get-install-source-dir impl cfg) path)))
-        (delete-directory dir))))
+           (if (and (file-directory? dir)
+                    (= 2 (length (directory-files dir))))
+               (delete-directory dir)))))))
 
 (define (command/remove cfg spec . args)
   (let* ((impls (conf-selected-implementations cfg))
@@ -1077,6 +1090,20 @@
     (else
      (list (make-path "/usr/local/share/snow" impl)))))
 
+(define (scheme-script-command impl cfg)
+  (or (and (eq? impl 'chibi) (conf-get cfg 'chibi-path))
+      (let* ((prog (cond ((assq impl known-implementations) => cadr)
+                         (else "scheme-script")))
+             (path (or (find-in-path prog) prog))
+             (arg (case impl
+                    ((chicken) "-s")
+                    ((gauche) "-b")
+                    ((larceny) "-program")
+                    (else #f))))
+        (if (and path arg)
+            (string-append path " " arg)
+            path))))
+
 (define (scheme-program-command impl cfg file . o)
   (let ((lib-path (and (pair? o) (car o)))
         (install-dir (get-install-source-dir impl cfg)))
@@ -1130,8 +1157,11 @@
            dirs
            (lambda (x)
              (and (package? x)
-                  (any (lambda (y) (equal? name (library-name y)))
+                  (or (equal? name (package-name x))
-                       (package-libraries x)))))
+                      (any (lambda (y) (equal? name (library-name y)))
+                           (package-libraries x))
+                      (any (lambda (y) (equal? name (program-name y)))
+                           (package-programs x))))))
           (and (pair? (cdr subname))
                (lp (drop-right subname 1)))))))
 
@@ -1250,7 +1280,7 @@
 (define (install-file cfg source dest)
   (if (install-with-sudo? cfg dest)
       (system "sudo" "cp" source dest)
-      (copy-file source dest)))
+      (system "cp" source dest)))
 
 (define (install-sexp-file cfg obj dest)
   (if (install-with-sudo? cfg dest)
@@ -1334,14 +1364,6 @@
     (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))
-         (install-dir (get-install-binary-dir impl cfg)))
-    (let ((path (make-path install-dir dest-program-file)))
-      (install-directory cfg (path-directory path))
-      (install-file cfg (make-path dir program-file) path))))
-
 ;; installers should return the list of installed files
 (define (lookup-installer installer)
   (case installer
@@ -1443,8 +1465,65 @@
                                      (builder-for-implementation impl cfg)))))
     (builder impl cfg library dir)))
 
+;; strip extension, add #! if needed, copy and chmod
+(define (default-program-builder impl cfg prog dir)
+  (let* ((path (make-path dir (get-program-file cfg prog)))
+         (dest (path-strip-extension path))
+         (src-lines (call-with-input-file path port->string-list))
+         (script (scheme-script-command impl cfg)))
+    (if (equal? path dest)
+        (system "cp" path (string-append path ".bak")))
+    (call-with-output-file dest
+      (lambda (out)
+        (when script
+          (display "#! " out)
+          (display script out)
+          (newline out)) 
+        (for-each
+         (lambda (line) (display line out) (newline out))
+         (if (and (pair? src-lines) (string-prefix? "#!" (car src-lines)))
+             (cdr src-lines)
+             src-lines))))
+    (chmod dest #o755)
+    (system 'ls '-l dest)
+    prog))
+
+(define (chicken-program-builder impl cfg prog dir)
+  (let ((path (get-program-file cfg prog)))
+    (with-directory
+     dir
+     (lambda ()
+       (let ((res (system 'csc '-R 'r7rs '-X 'r7rs
+                          '-I (path-directory path) path)))
+         (and (or (and (pair? res) (zero? (cadr res)))
+                  (yes-or-no? cfg "chicken failed to build: "
+                              path " - install anyway?"))
+              prog))))))
+
+(define (lookup-program-builder builder)
+  (case builder
+    ((chicken) chicken-program-builder)
+    (else default-program-builder)))
+
+(define (program-builder-for-implementation impl cfg)
+  (case impl
+    ((chicken) 'chicken)
+    (else 'default)))
+
 (define (build-program impl cfg prog dir)
-  #t)
+  (let ((builder (lookup-program-builder
+                  (or (conf-get cfg 'program-builder)
+                      (program-builder-for-implementation impl cfg)))))
+    (builder impl cfg prog dir)))
+
+(define (default-program-installer impl cfg prog dir)
+  (let* ((program-file (path-strip-extension (get-program-file cfg prog)))
+         (dest-program-file (program-install-name prog))
+         (install-dir (get-install-binary-dir impl cfg)))
+    (let ((path (make-path install-dir dest-program-file)))
+      (install-directory cfg (path-directory path))
+      (install-file cfg (make-path dir program-file) path)
+      (list path))))
 
 (define (lookup-program-installer installer)
   (case installer
@@ -1516,11 +1595,13 @@
                       (lambda (lib)
                         (install-library impl cfg lib dir))
                       libs)
-                     (append-map
+                     (if (conf-program-implementation? impl cfg)
-                      (lambda (prog)
+                         (append-map
-                        (build-program impl cfg prog dir)
+                          (lambda (prog)
-                        (install-program impl cfg prog dir))
+                            (build-program impl cfg prog dir)
-                      (package-programs pkg)))))
+                            (install-program impl cfg prog dir))
+                          (package-programs pkg))
+                         '()))))
                (install-package-meta-info
                 impl cfg
                 `(,@(remove (lambda (x)

lib/chibi/snow/package.scm

@@ -167,6 +167,16 @@
 (define (valid-library? lib)
   (not (invalid-library-reason lib)))
 
+(define (invalid-program-reason prog)
+  (cond
+   ((not (list? prog)) "program must be a list")
+   ((not (or (assoc-get prog 'path) (assoc-get prog 'name)))
+    "program must have a path")
+   (else #f)))
+
+(define (valid-program? prog)
+  (not (invalid-program-reason prog)))
+
 (define (invalid-package-reason pkg)
   (cond
    ((not (list? pkg))
@@ -174,10 +184,13 @@
    ((not (string? (package-version pkg)))
     (failure "package-version is not a string" (package-version pkg)))
    (else
-    (let ((libs (package-libraries pkg)))
+    (let ((libs (package-libraries pkg))
+          (progs (package-programs pkg)))
       (cond
-       ((not (pair? libs)) "package must contain at least one library")
+       ((and (not (pair? libs)) (not (pair? progs)))
+        "package must contain at least one library or program")
        ((any invalid-library-reason libs))
+       ((any invalid-program-reason progs))
        (else #f))))))
 
 (define (valid-package? pkg)
@@ -213,7 +226,8 @@
 
 (define (package-dependencies impl cfg package)
   (append-map (lambda (lib) (library-dependencies cfg impl lib))
-              (package-libraries package)))
+              (append (package-libraries package)
+                      (package-programs package))))
 
 (define (package-test-dependencies impl cfg package)
   (let ((pkg (package-for-impl impl cfg package)))

lib/chibi/snow/package.sld

@@ -18,6 +18,7 @@
           get-program-file program-name program-install-name
           invalid-package-reason valid-package?
           invalid-library-reason valid-library?
+          invalid-program-reason valid-program?
           repo-find-publisher lookup-digest rsa-identity=?
           extract-rsa-private-key extract-rsa-public-key)
   (import (scheme base)

tests/snow/repo3/pingala/triangle.scm

@@ -0,0 +1,16 @@
+(import (scheme base)
+        (scheme write)
+        (scheme process-context)
+        (pingala binomial))
+
+(let* ((args (command-line))
+       (rows (or (and (pair? args) (pair? (cdr args))
+                      (string->number (cadr args)))
+                 5)))
+  (do ((i 0 (+ i 1)))
+      ((> i rows))
+    (do ((j 0 (+ j 1)))
+        ((> j i) (newline))
+      (if (not (zero? j))
+          (write-char #\space))
+      (write (binomial i j)))))

tests/snow/snow-tests.scm

@@ -43,7 +43,7 @@
   `(,chibi-path -A ,install-libdir "tools/snow-chibi"
                 --always-no
                 --implementations "chibi"
-                --chibi-path ,(string-append chibi-path " -A " install-libdir)
+                --chibi-path ,(string-append chibi-path " -A" install-libdir)
                 --install-prefix ,install-prefix
                 --local-user-repository "tests/snow/repo-cache"
                 ,@args))
@@ -163,6 +163,10 @@
       --version 1.0 --authors "Pingala"
       --description "Pingala's test framework"
       tests/snow/repo3/pingala/test-map.scm)
+(snow package --output-dir tests/snow/repo3/
+      --version 1.0 --authors "Pingala" --name "(pingala triangle)"
+      --description "Program to print a Sierpinski Triangle"
+      --programs tests/snow/repo3/pingala/triangle.scm)
 (snow index ,(cadr repo3))
 (snow ,@repo3 update)
 (snow ,@repo3 install pingala.binomial)
@@ -170,14 +174,37 @@
   (test-assert (installed-version status '(pingala binomial)))
   (test-assert (installed-version status '(pingala factorial))))
 
+(snow ,@repo3 install pingala.triangle)
+(test-assert (file-exists? "tests/snow/tmp-root/bin/triangle"))
+(test "1
+1 1
+1 2 1
+1 3 3 1
+1 4 6 4 1
+1 5 10 10 5 1
+"
+    (process->string "tests/snow/tmp-root/bin/triangle"))
+(test "1
+1 1
+1 2 1
+1 3 3 1
+"
+    (process->string '("tests/snow/tmp-root/bin/triangle" "3")))
+
+(snow ,@repo3 remove pingala.triangle)
+(test-not (file-exists? "tests/snow/tmp-root/bin/triangle"))
+
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; other implementations
 
 (snow ,@repo3 update)
-(snow ,@repo3 --implementations "chicken" install pingala.binomial)
+(snow ,@repo3 --implementations "chicken" --program-implementation "chicken"
+      install pingala.triangle)
 (let ((status (snow-status --implementations "chicken")))
   (test-assert (installed-version status '(pingala binomial) 'chicken))
-  (test-assert (installed-version status '(pingala factorial) 'chicken)))
+  (test-assert (installed-version status '(pingala factorial) 'chicken))
+  (test "1\n1 1\n1 2 1\n1 3 3 1\n"
+      (process->string '("tests/snow/tmp-root/bin/triangle" "3"))))
 
 (snow ,@repo3 update)
 (snow ,@repo3 --implementations "foment" install pingala.binomial)

tools/snow-chibi

@@ -74,7 +74,10 @@
     (library-separator string "the separator to use for library components")
     (library-path (list string) "the path to search for local libraries")
     (installer symbol "name of installer to use")
+    (builder symbol "name of builder to use")
+    (program-builder symbol "name of program builder to use")
     (implementations (list symbol) "impls to install for, or 'all'")
+    (program-implementation symbol "impl to install programs for")
     (chibi-path filename "path to chibi-scheme executable")
     (sexp? boolean ("sexp") "output information in sexp format")
     ))
@@ -110,7 +113,8 @@
 (define verify-spec
   '())
 (define package-spec
-  '((programs (list existing-filename))
+  '((name sexp)
+    (programs (list existing-filename))
     (authors (list string))
     (maintainers (list string))
     (recursive? boolean (#\r "recursive") "...")