Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-05-19 05:39:18 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

Inlining utils to make chibi-genstatic work without modules.

Browse source
This commit is contained in:
Alex Shinn 2014-12-22 18:24:47 +09:00
parent b3f794568e
commit ad66b05837
1 changed files with 186 additions and 32 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

192
tools/chibi-genstatic
View file

@ -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-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 (path-strip-directory path)
(substring-cursor path (string-find-right path #\/)))
(define (path-directory path)
(if (string=? path "")
"."
(let ((end (string-skip-right path #\/)))
(if (zero? end)
"/"
(let ((start (string-find-right path #\/ 0 end)))
(if (zero? start)
"."
(let ((start2 (string-skip-right path #\/ 0 start)))
(if (zero? start2)
"/"
(substring-cursor path 0 start2)))))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -94,24 +161,30 @@
(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)))))))
(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 (find-c-libs-from-module-names modules)
(define (strip-dot-slash path)
(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)
(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)
@ -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)
(cons
(if includes
(find-c-libs-from-module-names includes)
(find-c-libs-from-file-names excludes)))
(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)
(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)
(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")