mirror of
https://github.com/ashinn/chibi-scheme.git
synced 2025-05-18 21:29:19 +02:00
439 lines
15 KiB
Text
Executable file
439 lines
15 KiB
Text
Executable file
#!/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,
|
|
;; i.e. a build of Chibi with all libraries that would be loaded
|
|
;; dynamically included statically into libchibi-scheme (though not
|
|
;; necessarily statically linked).
|
|
;;
|
|
;; Usage:
|
|
;; find <dir> -name \*.sld | chibi-genstatic [-x <mods> ...] > clibs.c
|
|
;; chibi-genstatic -i <mods> > clibs.c
|
|
;;
|
|
;; 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
|
|
;; `define-library' form. If you want to make a custom build with
|
|
;; your own libraries included statically, be sure to follow this
|
|
;; convention.
|
|
;;
|
|
;; 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 (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-cursor<? i2 start) start)
|
|
((pred (string-cursor-ref str i2)) i)
|
|
(else (lp i2)))))))
|
|
|
|
(define (string-skip str x . o)
|
|
(apply string-find str (complement (make-char-predicate x)) o))
|
|
|
|
(define (string-skip-right str x . o)
|
|
(apply string-find-right str (complement (make-char-predicate x)) o))
|
|
|
|
(define (string-suffix? suffix str)
|
|
(let ((suf-len (string-length suffix))
|
|
(str-len (string-length str)))
|
|
(and (>= str-len suf-len)
|
|
(equal? suffix (substring str (- str-len suf-len))))))
|
|
|
|
(define (path-strip-directory path)
|
|
(substring-cursor path (string-find-right path #\/)))
|
|
|
|
(define (path-directory path)
|
|
(if (string=? path "")
|
|
"."
|
|
(let ((zero (string-cursor-start path))
|
|
(end (string-skip-right path #\/)))
|
|
(if (string-cursor<=? end zero)
|
|
"/"
|
|
(let ((start (string-find-right path #\/ zero end)))
|
|
(if (string-cursor<=? start zero)
|
|
"."
|
|
(let ((start2 (string-skip-right path #\/ zero start)))
|
|
(if (string-cursor<=? start2 zero)
|
|
"/"
|
|
(substring-cursor path zero start2)))))))))
|
|
|
|
(define (path-extension-pos path)
|
|
(let ((start (string-cursor-start path))
|
|
(end (string-cursor-end path)))
|
|
(let lp ((i end) (dot #f))
|
|
(if (string-cursor<=? i start)
|
|
#f
|
|
(let* ((i2 (string-cursor-prev path i))
|
|
(ch (string-cursor-ref path i2)))
|
|
(cond ((eqv? #\. ch)
|
|
(and (string-cursor<? i end) (lp i2 (or dot i))))
|
|
((eqv? #\/ ch) #f)
|
|
(dot)
|
|
(else (lp i2 #f))))))))
|
|
|
|
(define (path-extension path)
|
|
(let ((i (path-extension-pos path)))
|
|
(and i
|
|
(substring-cursor path i))))
|
|
|
|
(define (path-strip-extension path)
|
|
(let ((i (path-extension-pos path)))
|
|
(if i
|
|
(substring-cursor path
|
|
(string-cursor-start path)
|
|
(string-cursor-prev path i))
|
|
path)))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define (x->string x)
|
|
(cond ((string? x) x)
|
|
((symbol? x) (symbol->string x))
|
|
((number? x) (number->string x))
|
|
(else (error "non-stringable object" x))))
|
|
|
|
(define (string-split str c . o)
|
|
(let ((start (if (pair? o) (car o) 0))
|
|
(end (string-length str)))
|
|
(let lp ((from start) (i start) (res '()))
|
|
(define (collect) (if (= i from) res (cons (substring str from i) res)))
|
|
(cond
|
|
((>= i end) (reverse (collect)))
|
|
((eqv? c (string-ref str i)) (lp (+ i 1) (+ i 1) (collect)))
|
|
(else (lp from (+ i 1) res))))))
|
|
|
|
(define (string-replace str c r)
|
|
(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))))
|
|
((eqv? c (string-ref str i)) (lp (+ i 1) (+ i 1) (cons r (collect))))
|
|
(else (lp from (+ i 1) res))))))
|
|
|
|
(define (c-char? c)
|
|
(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 (hex (string-ref str i)) (collect)))))
|
|
(else
|
|
(lp from (+ i 1) res))))))
|
|
|
|
(define (mangle x)
|
|
(string-replace
|
|
(string-replace (string-replace (c-escape (x->string x)) #\- "_") #\? "_p")
|
|
#\! "_x"))
|
|
|
|
(define (read-line . o)
|
|
(let ((in (if (pair? o) (car o) (current-input-port))))
|
|
(let lp ((res '()))
|
|
(let ((c (read-char in)))
|
|
(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 (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-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))))
|
|
((library) (eval `(find-module ',(cadr x)) (%meta-env)))
|
|
(else (error "cond-expand: bad feature" x)))
|
|
(memq (identifier->symbol x) *features*)))
|
|
(define (extract-module-name file)
|
|
(call-with-input-file file
|
|
(lambda (in)
|
|
(protect
|
|
(exn (else #f))
|
|
(let lp ()
|
|
(let ((expr (read in)))
|
|
(cond
|
|
((eof-object? expr) #f)
|
|
((and (pair? expr)
|
|
(pair? (cdr expr))
|
|
(memq (car expr)
|
|
'(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))
|
|
(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))
|
|
modules)
|
|
((extract-module-name file)
|
|
=> (lambda (name)
|
|
(lp (if (member name excluded)
|
|
modules
|
|
(append (extract-module-shares name file) modules)))))
|
|
(else
|
|
(lp modules))))))
|
|
|
|
(define (find-c-libs includes excludes cfiles)
|
|
(cons (if includes
|
|
(find-c-libs-from-module-names includes)
|
|
(find-c-libs-from-file-names excludes))
|
|
cfiles))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define wdir "")
|
|
|
|
(define (init-name mod)
|
|
(string-append "sexp_init_lib_"
|
|
(string-concatenate (map mangle mod) "_")))
|
|
|
|
(define (include-c-lib lib c-files . o)
|
|
(display "#define sexp_init_library ")
|
|
(display (init-name (cdr lib)))
|
|
(newline)
|
|
(cond
|
|
((and (pair? o) (car o)) ; inline
|
|
(let* ((mod-strings (cdr (module-name->strings (cdr lib) '())))
|
|
(share-file (path-strip-directory (car lib)))
|
|
;; ugly hack allowing include-shared of files only up to
|
|
;; one subdirectory beneath
|
|
(base0 (string-concatenate
|
|
(reverse (cons share-file (cons "/" mod-strings)))))
|
|
(base1 (string-concatenate
|
|
(reverse (cons share-file (cdr mod-strings)))))
|
|
(in (protect
|
|
(exn
|
|
(else
|
|
(let lp ((ls c-files))
|
|
(cond
|
|
((null? ls)
|
|
(error "couldn't find c file" base0 base1 c-files))
|
|
((and (member (path-extension (car ls)) '("c" "cc"))
|
|
(let ((f (path-strip-extension (car ls))))
|
|
(or (string-suffix? base0 f)
|
|
(string-suffix? base1 f))))
|
|
(open-input-file (car ls)))
|
|
(else (lp (cdr ls)))))))
|
|
(protect
|
|
(exn
|
|
(else
|
|
(protect
|
|
(exn (else (open-input-file (string-append base1 ".c"))))
|
|
(open-input-file (string-append base0 ".c")))))
|
|
(open-input-file (string-append (car lib) ".c"))))))
|
|
(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))
|
|
|
|
(define (init-c-lib lib)
|
|
(display " { \"")
|
|
(display (car lib))
|
|
(display "\", ")
|
|
(display (init-name (cdr lib)))
|
|
(display " },\n"))
|
|
|
|
(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 ((args (command-line)))
|
|
(if (pair? args)
|
|
(set! wdir (path-directory (path-directory (car args)))))
|
|
(let lp ((args (if (pair? args) (cdr args) args))
|
|
(features '())
|
|
(includes #f)
|
|
(excludes '())
|
|
(cfiles '())
|
|
(inline? #t))
|
|
(cond
|
|
((and (pair? args) (not (equal? "" (car args)))
|
|
(eqv? #\- (string-ref (car args) 0)))
|
|
(case (string->symbol (car args))
|
|
((--inline)
|
|
(lp (cdr args) features includes excludes cfiles #t))
|
|
((--no-inline)
|
|
(lp (cdr args) features includes excludes cfiles #f))
|
|
((--features)
|
|
(if (null? (cdr args))
|
|
(error "--features requires an argument"))
|
|
(lp (cddr args) (append features (string-split (cadr args) #\,))
|
|
includes excludes cfiles inline?))
|
|
((-i --include)
|
|
(lp (cddr args) features
|
|
(append (or includes '()) (split-mod-names (cadr args)))
|
|
excludes cfiles inline?))
|
|
((-x --exclude)
|
|
(lp (cddr args) features includes
|
|
(append excludes (split-mod-names (cadr args)))
|
|
cfiles inline?))
|
|
((-c --cfiles)
|
|
(lp (cddr args) features includes excludes
|
|
(append cfiles (string-split (cadr args) #\,)) inline?))
|
|
((-C --all-cfiles)
|
|
(lp '() features includes excludes (append cfiles (cdr args)) inline?))
|
|
(else
|
|
(error "unknown option" (car args)))))
|
|
(else
|
|
(if (pair? features)
|
|
(set! *features* features))
|
|
(let* ((c-libs+c-files (find-c-libs includes excludes cfiles))
|
|
(c-libs (car c-libs+c-files))
|
|
(c-files (cdr c-libs+c-files)))
|
|
(display "#include \"chibi/eval.h\"\n")
|
|
(newline)
|
|
(for-each (lambda (x) (include-c-lib x c-files inline?)) c-libs)
|
|
(newline)
|
|
(display "struct sexp_library_entry_t sexp_static_libraries_array[] = {\n")
|
|
(for-each init-c-lib c-libs)
|
|
(display " { NULL, NULL }\n")
|
|
(display "};\n\n")
|
|
(display "struct sexp_library_entry_t* sexp_static_libraries = sexp_static_libraries_array;\n"))))))
|