diff --git a/tools/chibi-genstatic b/tools/chibi-genstatic index 9420a34b..ef941126 100755 --- a/tools/chibi-genstatic +++ b/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 -name \*.sld | chibi-genstatic [-x ...] > clibs.c +;; Usage: +;; find -name \*.sld | chibi-genstatic [-x ...] > clibs.c +;; chibi-genstatic -i > clibs.c ;; -;; where 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 (meta) find-module)) - -(define c-libs '()) + (only (chibi pathname) path-directory) + (only (meta) find-module module-name->file)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -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)))) - ((not (c-char? (string-ref str i))) (lp (+ i 1) (+ i 1) (cons "_" (cons (number->string (char->integer (string-ref str i)) 16) (collect))))) - (else (lp from (+ i 1) res)))))) + ((>= i len) + (string-concatenate (reverse (collect)))) + ((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) - (string-append "sexp_init_lib_" - (string-concatenate (map mangle mod) "_"))) +(define (find-c-libs-from-module-names modules) + (define (strip-dot-slash path) + (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 ((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 lp ((modules '())) (let ((file (read-line))) (cond - ((not (or (eof-object? file) (equal? "" file))) - (process file) - (lp)))))) + ((or (eof-object? file) (equal? "" file)) + (find-c-libs-from-module-names modules)) + ((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))) - (find-c-libs - (if (and (pair? args) (member (car args) '("-x" "--exclude"))) - (map (lambda (m) - (map (lambda (x) (or (string->number x) (string->symbol x))) - (string-split m #\.))) - (cdr args)) - '())) - (newline) - (for-each include-c-lib c-libs) - (newline) - (display "typedef struct {\n") - (display " const char *name;\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")) + (let ((c-libs (find-c-libs (if (pair? args) (cdr args) args)))) + (newline) + (for-each include-c-lib c-libs) + (newline) + (display "typedef struct {\n") + (display " const char *name;\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")))