Adding initial chibi-ffi support to snow-chibi.

lib/chibi/snow/commands.scm

@@ -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)
+                    info
-                    files))
+                    (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 '() '() '() #f)) clauses)))
-                (let ((libs+files (map (lambda (c) (lp c '() '())) 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)

lib/chibi/snow/package.scm

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

lib/chibi/snow/package.sld

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

tests/snow/snow-tests.scm

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

tools/snow-chibi

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