mirror of
https://github.com/ashinn/chibi-scheme.git
synced 2025-05-20 14:19:18 +02:00
8b5eb68238
They can be close()d explicitly with close-file-descriptor, and will close() on gc, but only explicitly closing the last port on them will close the fileno. Notably needed for network sockets where we open separate input and output ports on the same socket.
225 lines
7.3 KiB
Text
Executable file
225 lines
7.3 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)
|
|
(only (chibi pathname) path-directory)
|
|
(only (meta) find-module module-name->file))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(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)))
|
|
(if (or (eof-object? c) (eqv? c #\newline))
|
|
(list->string (reverse res))
|
|
(lp (cons c res)))))))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(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-from-file-names excluded)
|
|
(define (extract-module-name file)
|
|
(call-with-input-file file
|
|
(lambda (in)
|
|
(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))))))))
|
|
(let lp ((modules '()))
|
|
(let ((file (read-line)))
|
|
(cond
|
|
((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 ")
|
|
(display (init-name (cdr lib)))
|
|
(newline)
|
|
(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"))
|
|
|
|
(let* ((args (command-line))
|
|
(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 "struct sexp_library_entry_t sexp_static_libraries[] = {\n")
|
|
(for-each init-c-lib c-libs)
|
|
(display " { NULL, NULL }\n")
|
|
(display "};\n\n"))
|