diff --git a/tools/chibi-genstatic b/tools/chibi-genstatic index c786ed8c..55f46186 100755 --- a/tools/chibi-genstatic +++ b/tools/chibi-genstatic @@ -36,9 +36,76 @@ ;; which presents a bootstrapping issue on platforms with no dynamic ;; loading. -(import (chibi) - (only (chibi pathname) path-directory) - (only (meta) find-module module-name->file)) +(import (chibi)) + +;; inlined from (meta) and (chibi string) + +(define (find-module name) + #f) + +(define (module-name->strings ls res) + (if (null? ls) + res + (let ((str (cond ((symbol? (car ls)) (symbol->string (car ls))) + ((number? (car ls)) (number->string (car ls))) + ((string? (car ls)) (car ls)) + (else (error "invalid module name" (car ls)))))) + (module-name->strings (cdr ls) (cons "/" (cons str res)))))) + +(define (module-name->file name) + (string-concatenate + (reverse (cons ".sld" (cdr (module-name->strings name '())))))) + +(define (make-char-predicate x) + (cond ((procedure? x) x) + ((char? x) (lambda (ch) (eq? ch x))) + (else (error "invalid character predicate" x)))) + +(define (complement pred) (lambda (x) (not (pred x)))) + +(define (string-find str x . o) + (let ((pred (make-char-predicate x)) + (end (if (and (pair? o) (pair? (cdr o))) + (cadr o) + (string-cursor-end str)))) + (let lp ((i (if (pair? o) (car o) (string-cursor-start str)))) + (cond ((string-cursor>=? i end) end) + ((pred (string-cursor-ref str i)) i) + (else (lp (string-cursor-next str i))))))) + +(define (string-find-right str x . o) + (let ((pred (make-char-predicate x)) + (start (if (pair? o) (car o) (string-cursor-start str)))) + (let lp ((i (if (and (pair? o) (pair? (cdr o))) + (cadr o) + (string-cursor-end str)))) + (let ((i2 (string-cursor-prev str i))) + (cond ((string-cursorstring (reverse res)) - (lp (cons c res))))))) + (cond + ((eof-object? c) + (if (null? res) c (list->string (reverse res)))) + ((eqv? c #\newline) + (list->string (reverse res))) + (else + (lp (cons c res)))))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(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-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) @@ -133,6 +206,14 @@ (lp (cdr ls) c-libs))))) (define (find-c-libs-from-file-names excluded) + (define (check-cond-expand x) + (if (pair? x) + (case (car x) + ((and) (every check-cond-expand (cdr x))) + ((or) (any check-cond-expand (cdr x))) + ((not) (not (check-cond-expand (cadr x)))) + (else (error "cond-expand: bad feature" x))) + (memq (identifier->symbol x) *features*))) (define (extract-module-name file) (call-with-input-file file (lambda (in) @@ -146,14 +227,46 @@ '(define-library define-module library module))) (cadr expr)) (else (lp)))))))) + (define (extract-module-shares mod-name file) + (call-with-input-file file + (lambda (in) + (let lp () + (let ((expr (read in))) + (cond + ((eof-object? expr) '()) + ((and (pair? expr) + (pair? (cdr expr)) + (memq (car expr) + '(define-library define-module library module))) + (let lp ((ls (cdr expr)) (c-libs '())) + (cond + ((null? ls) c-libs) + ((not (pair? (car ls))) (lp (cdr ls) c-libs)) + ((eq? 'include-shared (caar ls)) + (lp (cdr ls) + (cons (cons (shared-file-name mod-name (cadr (car ls))) + mod-name) + c-libs))) + ((eq? 'cond-expand (caar ls)) + ;;(lp (append (cdar ls) (cdr ls)) c-libs) + (let expand ((ls2 (cdar ls)) (res (cdr ls))) + (cond + ((null? ls2) (lp res c-libs)) + ((check-cond-expand (caar ls2)) + (expand (cdr ls2) (append (cdar ls2) res))) + (else (expand (cdr ls2) res))))) + (else (lp (cdr ls) c-libs))))) + (else (lp)))))))) (let lp ((modules '())) (let ((file (read-line))) (cond ((or (eof-object? file) (equal? "" file)) - (find-c-libs-from-module-names modules)) + modules) ((extract-module-name file) => (lambda (name) - (lp (if (member name excluded) modules (cons name modules))))) + (lp (if (member name excluded) + modules + (append (extract-module-shares name file) modules))))) (else (lp modules)))))) @@ -165,39 +278,75 @@ (string-split str #\,))) (let lp ((ls args) (includes #f) - (excludes '())) + (excludes '()) + (cfiles '())) (cond ((null? ls) - (if includes - (find-c-libs-from-module-names includes) - (find-c-libs-from-file-names excludes))) + (cons + (if includes + (find-c-libs-from-module-names includes) + (find-c-libs-from-file-names excludes)) + cfiles)) (else (cond ((member (car ls) '("-i" "--include")) (lp (cddr ls) (append (or includes '()) (split-mod-names (cadr ls))) - excludes)) + excludes + cfiles)) ((member (car ls) '("-x" "--exclude")) (lp (cddr ls) includes - (append excludes (split-mod-names (cadr ls))))) + (append excludes (split-mod-names (cadr ls))) + cfiles)) + ((member (car ls) '("-c" "--cfiles")) + (lp (cddr ls) + includes + excludes + (append cfiles (string-split (cadr ls) #\,)))) (else (error "unknown arg" (car ls)))))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +(define wdir "") + (define (init-name mod) (string-append "sexp_init_lib_" (string-concatenate (map mangle mod) "_"))) -(define (include-c-lib lib) +(define (include-c-lib lib c-files . o) (display "#define sexp_init_library ") (display (init-name (cdr lib))) (newline) - (display "#include \"") - (display (string-append (car lib) ".c")) - (display "\"") - (newline) + (cond + ((and (pair? o) (car o)) ; inline + (let* ((base (string-append (car lib) ".c")) + (in (protect + (exn + (else + (let lp ((ls c-files)) + (cond + ((null? ls) (error "couldn't find c file" base c-files)) + ((equal? (path-strip-directory (car ls)) + (path-strip-directory base)) + (open-input-file (car ls))) + (else (lp (cdr ls))))))) + (open-input-file base)))) + (let lp () + (let ((line (read-line in))) + (cond + ((eof-object? line) + (close-input-port in)) + (else + (display line) + (newline) + (lp))))))) + (else + (display "#include \"") + (display (string-append (car lib) ".c")) + (display "\"") + (newline))) (display "#undef sexp_init_library") (newline) (newline)) @@ -210,9 +359,14 @@ (display " },\n")) (let* ((args (command-line)) - (c-libs (find-c-libs (if (pair? args) (cdr args) args)))) + (_ (if (pair? args) + (set! wdir (path-directory (path-directory (car args)))))) + (c-libs+c-files (find-c-libs (if (pair? args) (cdr args) args))) + (c-libs (car c-libs+c-files)) + (c-files (cdr c-libs+c-files)) + (inline? #t)) (newline) - (for-each include-c-lib c-libs) + (for-each (lambda (x) (include-c-lib x c-files inline?)) c-libs) (newline) ;; (display "typedef struct {\n") ;; (display " const char *name;\n")