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 initial chibi-ffi support to snow-chibi.

Browse source
This commit is contained in:
Alex Shinn 2015-04-24 14:10:37 +09:00
parent 74ed34b4a3
commit ac53193e5d
5 changed files with 117 additions and 11 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

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

@ -183,6 +183,28 @@
(define (resolve file)
(let ((dest-path (make-path lib-dir file)))
(list 'rename (make-path dir dest-path) dest-path)))
(define (ffi-file-includes file)
(let lp ((forms (guard (exn (else '()))
(call-with-input-file file port->sexp-list)))
(res '()))
(cond ((null? forms) (reverse res))
((and (pair? (car forms))
(eq? 'c-include-verbatim (caar forms)))
(lp (cdr forms) (append (cdar forms) res)))
(else (lp (cdr forms) res)))))
(define (ffi-files base)
(let* ((path (path-resolve base (path-directory file)))
(stub-file (string-append path ".stub"))
(c-file (string-append path ".c")))
(cond
((file-exists? stub-file)
(cons (string-append base ".stub")
(ffi-file-includes stub-file)))
((file-exists? c-file)
(list c-file))
(else
(warn "couldn't find ffi stub or c source" base)
'()))))
(let lp ((ls declarations)
(info `(,@(cond
((conf-get cfg '(command package author))
@ -191,36 +213,58 @@
(path ,lib-file)
(name ,name)
library))
(files `((rename ,file ,lib-file))))
(deps '())
(files `((rename ,file ,lib-file)))
(chibi-ffi? #f))
(cond
((null? ls)
(cons (reverse info) files))
;; Force a fake dependency on (chibi) if the chibi ffi is
;; used so this isn't available to other implementations.
(let* ((deps (if (and chibi-ffi? (not (member '(chibi) deps)))
(cons '(chibi) deps)
deps))
(info (reverse (cons `(depends ,@deps) info))))
(cons info files)))
(else
(match (car ls)
(((or 'include 'include-ci) includes ...)
(lp (cdr ls)
info
(append (map resolve includes) files)))
deps
(append (map resolve includes) files)
chibi-ffi?))
(('include-library-declarations includes ...)
(lp (append (append-map file->sexp-list includes) (cdr ls))
info
(append (map resolve includes) files)))
deps
(append (map resolve includes) files)
chibi-ffi?))
(('include-shared includes ...)
(lp (cdr ls)
info
deps
(append (map resolve (append-map ffi-files includes))
files)
#t))
(('import libs ...)
(lp (cdr ls)
(cons (cons 'depends (map import-name libs)) info)
files))
info
(append (map import-name libs) deps)
files
chibi-ffi?))
(('cond-expand clauses ...)
;;(lp (append (append-map cdr clauses) (cdr ls)) info files)
(let ((libs+files (map (lambda (c) (lp c '() '())) clauses)))
(let ((libs+files (map (lambda (c) (lp c '() '() '() #f)) clauses)))
(lp (cdr ls)
(cons (cons 'cond-expand
(map cons
(map car clauses)
(map car libs+files)))
info)
(append files (append-map cdr libs+files)))))
deps
(append files (append-map cdr libs+files))
chibi-ffi?)))
(else
(lp (cdr ls) info files))))))))
(lp (cdr ls) info deps files chibi-ffi?))))))))
(else
(die 2 "not a valid library declaration " lib " in file " file)))))
@ -1504,6 +1548,47 @@
'()
(list (list library-file dest-library-file)))))))
;; first call the default builder to fix paths, then compile any ffi files
(define (chibi-builder impl cfg library dir)
(let* ((library (default-builder impl cfg library dir))
(library-file (make-path dir (get-library-file cfg library)))
(shared-includes
(library-shared-include-files impl cfg library-file))
(local-test? (file-exists? "tools/chibi-ffi"))
(chibi-ffi
(if local-test?
(scheme-program-command impl cfg "tools/chibi-ffi")
'("chibi-ffi")))
(cc (string-split (or (conf-get cfg 'cc)
(get-environment-variable "CC")
"cc")))
(cflags (string-split (or (get-environment-variable "CFLAGS") ""))))
(let lp ((ls shared-includes))
(if (null? ls)
library
(let* ((base (car ls))
(stub-file (string-append base ".stub"))
(c-file (string-append base ".c"))
(so-file (string-append base (cond-expand (macosx ".dylib")
(else ".so"))))
(so-flags (cond-expand (macosx '("-dynamiclib" "-Oz"))
(else '("-fPIC" "-shared" "-Os"))))
(cc-cmd (append cc cflags so-flags
(if local-test? '("-Iinclude" "-L.") '())
`("-o" ,so-file ,c-file "-lchibi-scheme"))))
(and (or (file-exists? c-file)
(and (file-exists? stub-file)
(or (and (system? (append chibi-ffi (list stub-file)))
(file-exists? c-file))
(yes-or-no? cfg "couldn't generate c from stub: "
stub-file " - install anyway?")))
(yes-or-no? cfg "can't find ffi stub or c source for: "
base " - install anyway?"))
(or (system? cc-cmd)
(yes-or-no? cfg "couldn't compile chibi ffi c code: "
c-file " - install anyway?"))
(lp (cdr ls))))))))
(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)) "."))
@ -1523,12 +1608,13 @@
(define (lookup-builder builder)
(case builder
((chibi) chibi-builder)
((chicken) chicken-builder)
(else default-builder)))
(define (builder-for-implementation impl cfg)
(case impl
((chicken) 'chicken)
((chibi chicken) impl)
(else 'default)))
(define (build-library impl cfg library dir)

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

@ -435,6 +435,14 @@
(filter (lambda (x) (and (pair? x) (memq (car x) '(include include-ci))))
lib))))
(define (library-shared-include-files impl config file)
(let ((lib (library-analyze impl config file))
(dir (path-directory file)))
(append-map
(lambda (x) (map (lambda (y) (make-path dir y)) (cdr x)))
(filter (lambda (x) (and (pair? x) (eq? (car x) 'include-shared)))
lib))))
(define (library-rewrite-includes x rules)
(define (recurse x) (library-rewrite-includes x rules))
(define (rewrite x)

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

@ -14,6 +14,7 @@
library-name->path library->path get-library-file find-library-file
library-url library-name parse-library-name library-name->path
library-analyze library-include-files library-dependencies
library-shared-include-files
library-rewrite-includes library-file-name
get-program-file program-name program-install-name
invalid-package-reason valid-package?

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

@ -180,6 +180,11 @@
--description "Equality implementation"
--test-library "tests/snow/repo3/recorde/equal-test.sld"
tests/snow/repo3/recorde/equal.sld)
(snow package --output-dir tests/snow/repo3/
--version 1.0 --authors "Pythagoras"
--description "Pythagoran Theorem"
--test "tests/snow/repo3/pythagoras/hypotenuse-test.sch"
tests/snow/repo3/pythagoras/hypotenuse.sch)
(snow index ,(cadr repo3))
(snow ,@repo3 update)
(snow ,@repo3 install pingala.binomial)
@ -187,6 +192,7 @@
(test-assert (installed-version status '(pingala binomial)))
(test-assert (installed-version status '(pingala factorial))))
;; programs
(snow ,@repo3 install pingala.triangle)
(test-assert (file-exists? "tests/snow/tmp-root/bin/triangle"))
(test "1
@ -213,6 +219,10 @@
(test-assert
(file-exists? "tests/snow/tmp-root/share/snow/chibi/pingala/ganas.txt"))
;; chibi ffi
(snow ,@repo3 install pythagoras.hypotenuse)
(test-assert (installed-version (snow-status) '(pythagoras hypotenuse)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; other implementations

1
tools/snow-chibi
View file

@ -80,6 +80,7 @@
(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")
(cc string "path to c compiler")
(sexp? boolean ("sexp") "output information in sexp format")
))