supporting explicit module list with -i/--include

tools/chibi-genstatic

@@ -1,4 +1,4 @@
-#! /usr/bin/env chibi-scheme
+#!/usr/bin/env chibi-scheme
 
 ;; This is a build-only tool (not installed) used to generate the
 ;; clibs.c file used by Chibi for a SEXP_USE_STATIC_LIBS=1 build,
@@ -6,9 +6,24 @@
 ;; dynamically included statically into libchibi-scheme (though not
 ;; necessarily statically linked).
 ;;
-;; usage: find <dir> -name \*.sld | chibi-genstatic [-x <mods> ...] > clibs.c
+;; Usage:
+;;   find <dir> -name \*.sld | chibi-genstatic [-x <mods> ...] > clibs.c
+;;   chibi-genstatic -i <mods> > clibs.c
 ;;
-;; where <mods> is a list of modules _not_ to generate static bindings for.
+;; In the first form, chibi-genstatic takes a list of module file
+;; names on stdin to generate static bindings for, excluding any
+;; modules specified with -x (or --exclude).
+;;
+;; In the second form, we take an explicit list of module names as
+;; options with -i or --include (-x is still honored and takes
+;; precedence).
+;;
+;; Both -i and -x may be specified multiple times, or multiple module
+;; names can be separated with commas.
+;;
+;; Examples:
+;;  find lib -name \*.sld | chibi-genstatic -x chibi.net -x srfi.18 > clibs.c
+;;  chibi-genstatic -i chibi.ast,srfi.69 > clibs.c
 ;;
 ;; This is only intended for libraries in the core distribution, and
 ;; currently makes the assumption that the .sld files contain a
@@ -16,16 +31,14 @@
 ;; your own libraries included statically, be sure to follow this
 ;; convention.
 ;;
-;; This relies on an external find, instead of one from (chibi
+;; Note: This relies on an external find, instead of one from (chibi
 ;; filesystem), because the latter is a dynamically loaded library
 ;; which presents a bootstrapping issue on platforms with no dynamic
 ;; loading.
 
 (import (scheme)
-        (chibi pathname)
+        (only (chibi pathname) path-directory)
-        (only (meta) find-module))
+        (only (meta) find-module module-name->file))
-
-(define c-libs '())
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
@@ -45,13 +58,6 @@
        ((eqv? c (string-ref str i)) (lp (+ i 1) (+ i 1) (collect)))
        (else (lp from (+ i 1) res))))))
 
-(define (string-scan c str . o)
-  (let ((limit (string-length str)))
-    (let lp ((i (if (pair? o) (car o) 0)))
-      (cond ((>= i limit) #f)
-            ((eqv? c (string-ref str i)) i)
-            (else (lp (+ i 1)))))))
-
 (define (string-replace str c r)
   (let ((len (string-length str)))
     (let lp ((from 0) (i 0) (res '()))
@@ -65,13 +71,19 @@
   (or (char-alphabetic? c) (char-numeric? c) (memv c '(#\_ #\- #\! #\?))))
 
 (define (c-escape str)
+  (define (hex ch) (number->string (char->integer ch) 16))
   (let ((len (string-length str)))
     (let lp ((from 0) (i 0) (res '()))
       (define (collect) (if (= i from) res (cons (substring str from i) res)))
       (cond
-       ((>= i len) (string-concatenate (reverse (collect))))
+       ((>= i len)
-       ((not (c-char? (string-ref str i))) (lp (+ i 1) (+ i 1) (cons "_" (cons (number->string (char->integer (string-ref str i)) 16) (collect)))))
+        (string-concatenate (reverse (collect))))
-       (else (lp from (+ i 1) res))))))
+       ((not (c-char? (string-ref str i)))
+        (lp (+ i 1)
+            (+ i 1)
+            (cons "_" (cons (hex (string-ref str i)) (collect)))))
+       (else
+        (lp from (+ i 1) res))))))
 
 (define (mangle x)
   (string-replace
@@ -88,11 +100,39 @@
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
-(define (init-name mod)
+(define (find-c-libs-from-module-names modules)
-  (string-append "sexp_init_lib_"
+  (define (strip-dot-slash path)
-                 (string-concatenate (map mangle mod) "_")))
+    (if (and (>= (string-length path) 2)
+             (eq? #\. (string-ref path 0))
+             (eq? #\/ (string-ref path 1)))
+        (substring path 2)
+        path))
+  (define (shared-file-name mod-name name)
+    (string-append
+     (path-directory
+      (strip-dot-slash (find-module-file (module-name->file mod-name))))
+     "/" name))
+  (define (find-c-lib mod-name)
+    (cond
+     ((find-module mod-name)
+      => (lambda (mod)
+           (cond
+            ((assq 'include-shared (vector-ref mod 2))
+             => (lambda (x)
+                  (cons (shared-file-name mod-name (cadr x)) mod-name)))
+            (else #f))))
+     (else #f)))
+  (let lp ((ls modules)
+           (c-libs '()))
+    (cond
+     ((null? ls)
+      c-libs)
+     ((find-c-lib (car ls))
+      => (lambda (x) (lp (cdr ls) (cons x c-libs))))
+     (else
+      (lp (cdr ls) c-libs)))))
 
-(define (find-c-libs excluded-c-libs)
+(define (find-c-libs-from-file-names excluded)
   (define (extract-module-name file)
     (call-with-input-file file
       (lambda (in)
@@ -106,29 +146,49 @@
                          '(define-library define-module library module)))
               (cadr expr))
              (else (lp))))))))
-  (define (process file)
+  (let lp ((modules '()))
-    (let ((mod-name (extract-module-name file)))
-      (cond
-       ((and mod-name
-             (not (member mod-name excluded-c-libs))
-             (find-module mod-name))
-        => (lambda (mod)
-             (cond
-              ((assq 'include-shared (vector-ref mod 2))
-               => (lambda (x)
-                    (set! c-libs
-                          (cons (cons (string-append
-                                       (path-directory file)
-                                       "/"
-                                       (cadr x))
-                                      mod-name)
-                                c-libs))))))))))
-  (let lp ()
     (let ((file (read-line)))
       (cond
-       ((not (or (eof-object? file) (equal? "" file)))
+       ((or (eof-object? file) (equal? "" file))
-        (process file)
+        (find-c-libs-from-module-names modules))
-        (lp))))))
+       ((extract-module-name file)
+        => (lambda (name)
+             (lp (if (member name excluded) modules (cons name modules)))))
+       (else
+        (lp modules))))))
+
+(define (find-c-libs args)
+  (define (split-mod-names str)
+    (map (lambda (m)
+           (map (lambda (x) (or (string->number x) (string->symbol x)))
+                (string-split m #\.)))
+         (string-split str #\,)))
+  (let lp ((ls args)
+           (includes #f)
+           (excludes '()))
+    (cond
+     ((null? ls)
+      (if includes
+          (find-c-libs-from-module-names includes)
+          (find-c-libs-from-file-names excludes)))
+     (else
+      (cond
+       ((member (car ls) '("-i" "--include"))
+        (lp (cddr ls)
+            (append (or includes '()) (split-mod-names (cadr ls)))
+            excludes))
+       ((member (car ls) '("-x" "--exclude"))
+        (lp (cddr ls)
+            includes
+            (append excludes (split-mod-names (cadr ls)))))
+       (else
+        (error "unknown arg" (car ls))))))))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (init-name mod)
+  (string-append "sexp_init_lib_"
+                 (string-concatenate (map mangle mod) "_")))
 
 (define (include-c-lib lib)
   (display "#define sexp_init_library ")
@@ -150,23 +210,16 @@
   (display " },\n"))
 
 (define (main args)
-  (if (not (null? args)) (set! args (cdr args)))
+  (let ((c-libs (find-c-libs (if (pair? args) (cdr args) args))))
-  (find-c-libs
+    (newline)
-   (if (and (pair? args) (member (car args) '("-x" "--exclude")))
+    (for-each include-c-lib c-libs)
-       (map (lambda (m)
+    (newline)
-              (map (lambda (x) (or (string->number x) (string->symbol x)))
+    (display "typedef struct {\n")
-                   (string-split m #\.)))
+    (display "  const char *name;\n")
-            (cdr args))
+    (display "  sexp_init_proc init;\n")
-       '()))
+    (display "} sexp_library_entry_t;\n")
-  (newline)
+    (newline)
-  (for-each include-c-lib c-libs)
+    (display "static sexp_library_entry_t sexp_static_libraries[] = {\n")
-  (newline)
+    (for-each init-c-lib c-libs)
-  (display "typedef struct {\n")
+    (display "  { NULL, NULL }\n")
-  (display "  const char *name;\n")
+    (display "};\n\n")))
-  (display "  sexp_init_proc init;\n")
-  (display "} sexp_library_entry_t;\n")
-  (newline)
-  (display "static sexp_library_entry_t sexp_static_libraries[] = {\n")
-  (for-each init-c-lib c-libs)
-  (display "  { NULL, NULL }\n")
-  (display "};\n\n"))