diff --git a/lib/chibi/snow/commands.scm b/lib/chibi/snow/commands.scm index 5e66c20d..971ee6a7 100644 --- a/lib/chibi/snow/commands.scm +++ b/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)) - (eqv? #\/ (string-ref dir 0)) - dir)))) + (or (and (string? dir) (> (string-length dir) 0) + (eqv? #\/ (string-ref dir 0)) + 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) - (list x (string-append x ".mv.scm")))) - include-files))) + (and (equal? x (make-path dir dest-library-file)) + (list x (string-append x ".renamed.scm")))) + 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)) - rewrite-include-files))) - (install-sexp-file cfg library (make-path dir dest-library-file)))) + (library-rewrite-includes + (car (file->sexp-list src-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))))))) diff --git a/tests/snow/repo1/leonardo/fibonacci-test.scm b/tests/snow/repo1/leonardo/fibonacci-test.scm index 31537274..5c84da2f 100644 --- a/tests/snow/repo1/leonardo/fibonacci-test.scm +++ b/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) diff --git a/tests/snow/repo2/leonardo/fibonacci-test.scm b/tests/snow/repo2/leonardo/fibonacci-test.scm index 31537274..5c84da2f 100644 --- a/tests/snow/repo2/leonardo/fibonacci-test.scm +++ b/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) diff --git a/tests/snow/repo3/pingala/test-map.scm b/tests/snow/repo3/pingala/test-map.scm index e45c21b8..e2e38c7f 100644 --- a/tests/snow/repo3/pingala/test-map.scm +++ b/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 - ((not (equal? res 'expected)) - (set! failed? #t) - (display "FAIL: expected ") - (write 'expected) - (display " but got ") - (write res) - (newline))))))))) + (if (not (equal? res 'expected)) + (fail 'expected res)))))))) diff --git a/tests/snow/snow-tests.scm b/tests/snow/snow-tests.scm index 30342bf0..a1ece344 100644 --- a/tests/snow/snow-tests.scm +++ b/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)))