Fixing library rewriting and test-depends bug.

lib/chibi/snow/commands.scm

@@ -229,13 +229,15 @@
        (die 2 "not a valid library declaration " lib " in file " file)))))
 
 (define (extract-program-dependencies file . o)
-  (let ((depends (or (and (pair? o) (car o) 'depends))))
+  (let ((depends (or (and (pair? o) (car o)) 'depends)))
     (let lp ((ls (guard (exn (else '())) (file->sexp-list file)))
              (deps '())
              (cond-deps '()))
       (cond
        ((and (pair? ls) (pair? (car ls)) (eq? 'import (caar ls)))
-        (lp (cdr ls) (append (reverse (map import-name (cdar ls))) deps)))
+        (lp (cdr ls)
+            (append (reverse (map import-name (cdar ls))) deps)
+            cond-deps))
        ((and (pair? ls) (pair? (car ls)) (eq? 'cond-expand (caar ls)))
         ;; flatten all imports, but maintain cond-expand's separately
         (let ((res (filter-map
@@ -251,7 +253,7 @@
               (lp (cdr ls) deps `((cond-expand ,@res) ,@cond-deps))
               (lp deps cond-deps))))
        (else
-        (append (if (pair? deps) (cons depends (reverse deps)) '())
+        (append (if (pair? deps) (list (cons depends (reverse deps))) '())
                 (if (pair? cond-deps) (reverse cond-deps) '())))))))
 
 (define (make-package-name cfg libs . o)
@@ -964,7 +966,12 @@
       (process->sexp `(guile -c ,(write-to-string `(write ,expr))))))
   (case impl
     ((chibi)
-     (let* ((dirs (reverse (fast-eval '(current-module-path) '((chibi)))))
+     (let* ((dirs
+             (reverse
+              (cond-expand
+               (chibi (eval '(current-module-path) (environment '(chibi))))
+               (else (process->sexp
+                      '(chibi-scheme -q -p "(current-module-path)"))))))
             (share-dir (find (lambda (d) (string-contains d "/share/")) dirs)))
        (if share-dir
            (cons share-dir (delete share-dir dirs))
@@ -972,9 +979,10 @@
     ((gauche)
      (list
       (let ((dir (process->string '(gauche-config "--sitelibdir"))))
-        (and (string? dir) (> 0 (string-length dir))
+        (or (and (string? dir) (> (string-length dir) 0)
-             (eqv? #\/ (string-ref dir 0))
+                 (eqv? #\/ (string-ref dir 0))
-             dir))))
+                 dir)
+            "/usr/local/share/gauche/"))))
     ((guile)
      (let ((path
             (guile-eval
@@ -997,7 +1005,7 @@
 
 (define (scheme-program-command impl cfg file . o)
   (let ((lib-path (and (pair? o) (car o)))
-        (install-dir (car (get-install-dirs impl cfg))))
+        (install-dir (get-install-source-dir impl cfg)))
     (case impl
       ((chibi)
        (let ((chibi (string-split (conf-get cfg 'chibi-path "chibi-scheme"))))
@@ -1020,7 +1028,8 @@
        `(kawa --script ,file))
       ((larceny)
        (if lib-path
-           `(larceny -r7rs -path ,install-dir -path ,lib-path -program ,file)
+           `(larceny -r7rs -path ,(string-append install-dir ":" lib-path)
+                     -program ,file)
            `(larceny -r7rs -path ,install-dir -program ,file)))
       (else
        #f))))
@@ -1234,6 +1243,7 @@
   (let* ((library-file (get-library-file cfg library))
          (ext (get-library-extension impl cfg))
          (src-library-file (make-path dir library-file))
+         (library-dir (path-directory src-library-file))
          (dest-library-file (path-replace-extension library-file ext))
          (include-files
           (library-include-files impl cfg (make-path dir library-file)))
@@ -1246,27 +1256,35 @@
           ;; For now we assume libraries with the same prefix cooperate.
           (filter-map
            (lambda (x)
-             (and (equal? x dest-library-file)
+             (and (equal? x (make-path dir dest-library-file))
-                  (list x (string-append x ".mv.scm"))))
+                  (list x (string-append x ".renamed.scm"))))
-           include-files)))
+           include-files))
+         (relative-rewrite-include-files
+          (map (lambda (x)
+                 (list (path-relative-to (car x) library-dir)
+                       (path-relative-to (cadr x) library-dir)))
+               rewrite-include-files)))
     ;; rename
     (for-each
      (lambda (x)
-       (rename-file (make-path dir (car x)) (make-path dir (cadr x))))
+       (rename-file (car x) (cadr x)))
      rewrite-include-files)
     (cond
      ((pair? rewrite-include-files)
-      (info `(rewrite: ,library-file -> ,dest-library-file))
+      ;; TODO: rewrite with a structural editor to preserve formatting
       (let ((library
-             (library-rewrite-includes (car (file->sexp-list src-library-file))
+             (library-rewrite-includes
-                                       rewrite-include-files)))
+              (car (file->sexp-list src-library-file))
-        (install-sexp-file cfg library (make-path dir dest-library-file))))
+              relative-rewrite-include-files)))
+        (install-sexp-file cfg library (make-path dir dest-library-file))
+        (if (not (equal? library-file dest-library-file))
+            (delete-file src-library-file))))
      ((not (equal? library-file dest-library-file))
       (rename-file src-library-file (make-path dir dest-library-file))))
     ;; return the rewritten library
     (library-rewrite-includes
      library
-     (append rewrite-include-files
+     (append relative-rewrite-include-files
              (if (equal? library-file dest-library-file)
                  '()
                  (list (list library-file dest-library-file)))))))

tests/snow/repo1/leonardo/fibonacci-test.scm

@@ -1,6 +1,10 @@
-(import (scheme base) (chibi test) (leonardo fibonacci))
+(import (scheme base) (scheme process-context) (leonardo fibonacci))
 
-(test-begin "fibonacci")
+(define (test expect expr)
+  (cond
+   ((not (equal? expect expr))
+    (write-string "FAIL\n")
+    (exit 1))))
 
 (test 1 (fib 0))
 (test 1 (fib 1))
@@ -9,6 +13,3 @@
 (test 5 (fib 4))
 (test 8 (fib 5))
 (test 13 (fib 6))
-
-(test-end)
-(test-exit)

tests/snow/repo2/leonardo/fibonacci-test.scm

@@ -1,6 +1,10 @@
-(import (scheme base) (chibi test) (leonardo fibonacci))
+(import (scheme base) (scheme process-context) (leonardo fibonacci))
 
-(test-begin "fibonacci")
+(define (test expect expr)
+  (cond
+   ((not (equal? expect expr))
+    (write-string "FAIL\n")
+    (exit 1))))
 
 (test 1 (fib 0))
 (test 1 (fib 1))
@@ -9,6 +13,3 @@
 (test 5 (fib 4))
 (test 8 (fib 5))
 (test 13 (fib 6))
-
-(test-end)
-(test-exit)

tests/snow/repo3/pingala/test-map.scm

@@ -1,18 +1,19 @@
 (define-library (pingala test-map)
   (export test-map test-exit)
-  (import (scheme base) (scheme process-context))
+  (import (scheme base) (scheme write) (scheme process-context))
   (begin
     (define failed? #f)
+    (define (fail expected res)
+      (set! failed? #t)
+      (display "FAIL: expected ")
+      (write expected)
+      (display " but got ")
+      (write res)
+      (newline))
     (define (test-exit) (exit (if failed? 1 0)))
     (define-syntax test-map
       (syntax-rules ()
         ((test-map expected proc values)
          (let ((res (map proc 'values)))
-           (cond
+           (if (not (equal? res 'expected))
-            ((not (equal? res 'expected))
+               (fail 'expected res))))))))
-             (set! failed? #t)
-             (display "FAIL: expected ")
-             (write 'expected)
-             (display " but got ")
-             (write res)
-             (newline)))))))))

tests/snow/snow-tests.scm

@@ -17,7 +17,7 @@
 ;; run snow-chibi command as a separate process with test defaults
 (define chibi-path "./chibi-scheme")
 (define (snow-command . args)
-  `(,chibi-path "tools/snow-chibi"
+  `(,chibi-path -A ,install-libdir "tools/snow-chibi"
                 --always-no
                 --implementations "chibi"
                 --chibi-path ,(string-append chibi-path " -A " install-libdir)
@@ -101,6 +101,7 @@
 (snow package --output-dir tests/snow/repo1/
       --version 1.0 --authors "Leonardo Fibonacci"
       --description "Fibonacci recurrence relation"
+      --test tests/snow/repo1/leonardo/fibonacci-test.scm
       tests/snow/repo1/leonardo/fibonacci.sld)
 (snow index ,(cadr repo1) tests/snow/repo1/leonardo-fibonacci-1.0.tgz)
 (snow ,@repo1 update)
@@ -111,6 +112,7 @@
 (snow package --output-dir tests/snow/repo2/
       --version 1.1 --authors "Leonardo Fibonacci"
       --description "Fibonacci recurrence relation"
+      --test tests/snow/repo2/leonardo/fibonacci-test.scm
       tests/snow/repo2/leonardo/fibonacci.sld)
 (snow index ,(cadr repo2))
 (snow ,@repo2 update)
@@ -125,6 +127,7 @@
 (snow package --output-dir tests/snow/repo3/
       --version 1.0 --authors "Pingala"
       --description "Binomial Coefficients"
+      --test tests/snow/repo3/pingala/binomial-test.scm
       tests/snow/repo3/pingala/binomial.scm)
 (snow package --output-dir tests/snow/repo3/
       --version 1.0 --authors "Pingala"
@@ -140,12 +143,6 @@
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; other implementations
 
-(snow ,@repo2 update)
-(snow ,@repo2 --implementations "foment" install leonardo.fibonacci)
-(test "1.1" (installed-version (snow-status  --implementations "foment")
-                               '(leonardo fibonacci)
-                               'foment))
-
 (snow ,@repo3 update)
 (snow ,@repo3 --implementations "foment" install pingala.binomial)
 (let ((status (snow-status --implementations "foment")))
@@ -153,21 +150,18 @@
   (test-assert (installed-version status '(pingala factorial) 'foment)))
 
 (snow ,@repo2 update)
-(snow ,@repo2 --implementations "gauche,guile,larceny"
+(snow ,@repo2 --implementations "gauche,larceny"
       install leonardo.fibonacci)
-(let ((status (snow-status  --implementations "gauche,guile,larceny")))
+(let ((status (snow-status  --implementations "gauche,larceny")))
   (test "1.1" (installed-version status '(leonardo fibonacci) 'gauche))
-  (test "1.1" (installed-version status '(leonardo fibonacci) 'guile))
   (test "1.1" (installed-version status '(leonardo fibonacci) 'larceny)))
 
 (snow ,@repo3 update)
-(snow ,@repo3 --implementations "gauche,guile,larceny"
+(snow ,@repo3 --implementations "gauche,larceny"
       install pingala.binomial)
-(let ((status (snow-status --implementations "gauche,guile,larceny")))
+(let ((status (snow-status --implementations "gauche,larceny")))
   (test-assert (installed-version status '(pingala binomial) 'gauche))
   (test-assert (installed-version status '(pingala factorial) 'gauche))
-  (test-assert (installed-version status '(pingala binomial) 'guile))
-  (test-assert (installed-version status '(pingala factorial) 'guile))
   (test-assert (installed-version status '(pingala binomial) 'larceny))
   (test-assert (installed-version status '(pingala factorial) 'larceny)))