Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-05-19 05:39:18 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

Adding proper program installation for chicken, plus tests.

Browse source
This commit is contained in:
Alex Shinn 2015-04-21 18:02:19 +09:00
parent 79652b8fd5
commit 882f36bccf
6 changed files with 175 additions and 32 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

117
lib/chibi/snow/commands.scm
View file

@ -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)
(let ((name (any (lambda (x) (or (library-name x) (program-name x))) libs))
(define (make-package-name cfg pkg libs . o)
(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)
(package->path cfg pkg))))
(cond
((package->path cfg pkg)
=> (lambda (path)
(let ((dir (make-path (get-install-source-dir impl cfg) path)))
(if (and (file-directory? dir)
(= 2 (length (directory-files dir))))
(delete-directory 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)
(or (equal? name (package-name x))
(any (lambda (y) (equal? name (library-name y)))
(package-libraries x)))))
(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)
(if (conf-program-implementation? impl cfg)
(append-map
(lambda (prog)
(build-program impl cfg prog dir)
(install-program impl cfg prog dir))
(package-programs pkg)))))
(package-programs pkg))
'()))))
(install-package-meta-info
impl cfg
`(,@(remove (lambda (x)

20
lib/chibi/snow/package.scm
View file

@ -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)))

1
lib/chibi/snow/package.sld
View file

@ -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)

16
tests/snow/repo3/pingala/triangle.scm Normal file
View file

@ -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)))))

31
tests/snow/snow-tests.scm
View file

@ -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)

6
tools/snow-chibi
View file

@ -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") "...")