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

merge

Browse source
This commit is contained in:
Alex Shinn 2015-02-13 19:04:59 +09:00
commit 692a231091
5 changed files with 110 additions and 86 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

1
include/chibi/sexp.h
View file

@ -1539,6 +1539,7 @@ SEXP_API sexp sexp_finalize_c_type (sexp ctx, sexp self, sexp_sint_t n, sexp obj
#define sexp_equalp(ctx, a, b) sexp_equalp_op(ctx, NULL, 2, a, b)
#define sexp_listp(ctx, x) sexp_listp_op(ctx, NULL, 1, x)
#define sexp_length(ctx, x) sexp_length_op(ctx, NULL, 1, x)
#define sexp_length_unboxed(x) sexp_unbox_fixnum(sexp_length(NULL, x))
#define sexp_reverse(ctx, x) sexp_reverse_op(ctx, NULL, 1, x)
#define sexp_nreverse(ctx, x) sexp_nreverse_op(ctx, NULL, 1, x)
#define sexp_copy_list(ctx, x) sexp_copy_list_op(ctx, NULL, 1, x)

108
lib/chibi/app.scm
View file

@ -1,5 +1,5 @@
;; app.scm -- unified option parsing and config
;; Copyright (c) 2012-2013 Alex Shinn. All rights reserved.
;; Copyright (c) 2012-2015 Alex Shinn. All rights reserved.
;; BSD-style license: http://synthcode.com/license.txt
;;> Parses command-line options into a config object.
@ -8,17 +8,33 @@
(define (parse-value type str)
(cond
((not (string? str))
str)
(list str #f))
((and (pair? type) (eq? 'list (car type)))
(map (lambda (x) (parse-value (cadr type) x))
(string-split str #\,)))
(let ((res (map (lambda (x) (parse-value (cadr type) x))
(string-split str #\,))))
(list (map car res) (any string? (map cdr res)))))
(else
(case type
((boolean) (not (member str '("#f" "#false" "#F" "#FALSE"))))
((number) (string->number str))
((symbol) (string->symbol str))
((char) (string-ref str 0))
(else str)))))
((boolean)
(list (not (member str '("#f" "#false" "#F" "#FALSE" "false" "FALSE")))
#f))
((number integer real)
(let ((n (string->number str)))
(cond
((and (eq? type 'integer) (not (integer? n)))
(list n "expected an integer"))
((and (eq? type 'real) (not (real? n)))
(list n "expected a real number"))
(else
(list n #f)))))
((symbol)
(list (string->symbol str) #f))
((char)
(if (not (= 1 (string-length str)))
(list #f "expected a single character")
(list (string-ref str 0) #f)))
(else
(list str #f))))))
(define (lookup-conf-spec conf-spec syms strs)
(let ((sym (car syms))
(str (car strs)))
@ -55,43 +71,44 @@
((and (pair? (cddr x)) (member `(not ,ch) (car (cddr x))))
`(not ,x))
(else (lp (cdr ls))))))))
(define (parse-conf-spec str args)
(let* ((strs (string-split str #\.))
(define (parse-long-option str args fail)
(let* ((str+val (string-split str #\= 2))
(str (car str+val))
(args (if (pair? (cdr str+val)) (cons (cadr str+val) args) args))
(strs (string-split str #\.))
(syms (map string->symbol strs))
(spec (lookup-conf-spec conf-spec syms strs)))
(cond
((not spec)
#f)
;; check for 'no' prefix on boolean
(if (not (string-prefix? "no" str))
(fail prefix conf-spec (car args) args "unknown option")
(let ((res (parse-long-option (substring str 2) args (lambda args #f))))
(cond
((not res)
(fail prefix conf-spec (car args) args "unknown option"))
((not (boolean? (cdar res)))
(error "'no' prefix only valid on boolean options"))
(else
`((,(caar res) . #f) ,@(cdr res)))))))
((and (pair? spec) (eq? 'not (car spec)))
(cons (cons (append prefix (list (car spec))) #f) args))
((eq? 'boolean (cadr spec))
((and (eq? 'boolean (cadr spec)) (null? (cdr str+val)))
(cons (cons (append prefix (list (car spec))) #t) args))
((null? args)
(error "missing argument to option " str))
(fail prefix conf-spec (car args) args "missing argument to option"))
(else
(cons (cons (append prefix syms) (parse-value (cadr spec) (car args)))
(cdr args))))))
(define (parse-long-option str args)
(let* ((str+val (string-split str #\= 2))
(str (car str+val))
(args2 (if (pair? (cdr str+val)) (cons (cadr str+val) args) args)))
(or (parse-conf-spec str args2)
(and (string-prefix? "no-" str)
(let ((res (parse-long-option (substring str 3) args)))
(cond
((not res)
#f)
((not (boolean? (cdar res)))
(error "'no-' prefix only valid on boolean options"))
(else
`(((,@prefix ,(caar res)) . ,(not (cdar res)))
,@(cdr res)))))))))
(define (parse-short-option str args)
(let ((val+err (parse-value (cadr spec) (car args))))
(if (cadr val+err)
(fail prefix conf-spec (car args) args (cadr val+err))
(cons (cons (append prefix syms) (car val+err))
(cdr args))))))))
(define (parse-short-option str args fail)
(let* ((ch (string-ref str 0))
(x (lookup-short-option ch conf-spec)))
(cond
((not x)
#f)
(fail prefix conf-spec (car args) args "unknown option"))
((and (pair? x) (eq? 'not (car x)))
(cons (cons (append prefix (list (car (cadr x)))) #f)
(if (= 1 (string-length str))
@ -103,17 +120,18 @@
args
(cons (string-append "-" (substring str 1)) args))))
((> (string-length str) 1)
(cons (cons (append prefix (list (car x)))
(parse-value (cadr x) (substring str 1)))
args))
(let ((val+err (parse-value (cadr x) (substring str 1))))
(if (cadr val+err)
(fail prefix conf-spec (car args) args (cadr val+err))
(cons (cons (append prefix (list (car x))) (car val+err))
args))))
((null? args)
(error "missing argument to option " x))
(fail prefix conf-spec (car args) args "missing argument to option"))
(else
(cons (cons (append prefix (list (car x))) (car args)) (cdr args))))))
(or (if (eqv? #\- (string-ref (car args) 1))
(parse-long-option (substring (car args) 2) (cdr args))
(parse-short-option (substring (car args) 1) (cdr args)))
(fail prefix conf-spec (car args) args)))
(if (eqv? #\- (string-ref (car args) 1))
(parse-long-option (substring (car args) 2) (cdr args) fail)
(parse-short-option (substring (car args) 1) (cdr args) fail)))
(define (parse-options prefix conf-spec orig-args fail)
(let lp ((args orig-args)
@ -138,9 +156,9 @@
(else (reverse (cdr (reverse prefix))))))
(let ((fail (if (pair? o)
(car o)
(lambda (prefix spec opt args)
;; TODO: search for closest option
(error "unknown option: " opt)))))
(lambda (prefix spec opt args reason)
;; TODO: search for closest option in "unknown" case
(error reason opt)))))
(cond
((null? spec)
(error "no procedure in application spec"))
@ -149,7 +167,7 @@
((@)
(let* ((new-opt-spec (cadr (car spec)))
(new-fail
(lambda (new-prefix new-spec opt args)
(lambda (new-prefix new-spec opt args reason)
(parse-option (prev-prefix prefix) opt-spec args fail)))
(cfg+args (parse-options prefix new-opt-spec args new-fail))
(config (conf-append (car cfg+args) config))

7
lib/meta-7.scm
View file

@ -141,7 +141,7 @@
(let ((env (if (pair? o) (car o) (make-environment)))
(meta (module-meta-data mod))
(dir (module-name-prefix name)))
(define (load-modules files extension fold?)
(define (load-modules files extension fold? . o)
(for-each
(lambda (f)
(let ((f (string-append dir f extension)))
@ -154,6 +154,7 @@
(load in env)))
(else
(load path env)))))
((and (pair? o) (car o)) ((car o)))
(else (error "couldn't find include" f)))))
files))
;; catch cyclic references
@ -193,6 +194,9 @@
(load-modules (cdr x) "" #t))
((include-shared)
(load-modules (cdr x) *shared-object-extension* #f))
((include-shared-optionally)
(load-modules (list (cadr x)) *shared-object-extension* #f
(lambda () (load-modules (cddr x) "" #f))))
((body begin)
(for-each (lambda (expr) (eval expr env)) (cdr x)))
((error)
@ -366,6 +370,7 @@
(define-meta-primitive include)
(define-meta-primitive include-ci)
(define-meta-primitive include-shared)
(define-meta-primitive include-shared-optionally)
(define-meta-primitive body)
(define-meta-primitive begin)

12
tools/chibi-ffi
View file

@ -402,6 +402,9 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; .stub file interface
(define (ffi-include file)
(load file (current-environment)))
(define (c-declare . args)
(apply cat args)
(newline))
@ -1054,6 +1057,7 @@
(define (scheme-procedure->c name)
(cond
((eq? name 'length) 'sexp_length_unboxed)
((eq? name 'string-length) 'sexp_string_length)
((eq? name 'string-size) 'sexp_string_size)
((eq? name 'bytevector-length) 'sexp_bytes_length)
@ -1136,7 +1140,13 @@
(if (and *c++?* (type-new? a))
(cat " tmp" (type-index a)
" = new " (type-c-name-derefed (type-base a)) "();\n")
(cat " tmp" (type-index a) " = calloc(1, 1 + "
(cat " tmp" (type-index a) " = "
(if (type-struct-type a)
(lambda () (cat "(" (type-c-name (type-base a))
(if (type-pointer? a) "*" "")
")"))
"")
" calloc(1, 1 + "
(if (and (symbol? len) (not (eq? len 'null)))
(lambda () (cat (lambda () (scheme->c-converter 'unsigned-int len))
"*sizeof(tmp" (type-index a) "[0])"))

68
tools/chibi-genstatic
View file

@ -270,42 +270,11 @@
(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 '())
(cfiles '()))
(cond
((null? ls)
(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
cfiles))
((member (car ls) '("-x" "--exclude"))
(lp (cddr ls)
includes
(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 (find-c-libs includes excludes cfiles)
(cons (if includes
(find-c-libs-from-module-names includes)
(find-c-libs-from-file-names excludes))
cfiles))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -358,11 +327,20 @@
(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 '()))
(features '())
(includes #f)
(excludes '())
(cfiles '()))
(cond
((and (pair? args) (not (equal? "" (car args)))
(eqv? #\- (string-ref (car args) 0)))
@ -370,13 +348,25 @@
((--features)
(if (null? (cdr args))
(error "--features requires an argument"))
(lp (cddr args) (append features (string-split (cadr args) #\,))))
(lp (cddr args) (append features (string-split (cadr args) #\,))
includes excludes cfiles))
((-i --include)
(lp (cddr args) features
(append (or includes '()) (split-mod-names (cadr args)))
excludes cfiles))
((-x --exclude)
(lp (cddr args) features includes
(append excludes (split-mod-names (cadr args)))
cfiles))
((-c --cfiles)
(lp (cddr args) features includes excludes
(append cfiles (string-split (cadr args) #\,))))
(else
(error "unknown option" (car args)))))
(else
(if (pair? features)
(set! *features* features))
(let* ((c-libs+c-files (find-c-libs (if (pair? args) (cdr args) args)))
(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))
(inline? #t))