merge

include/chibi/sexp.h

@@ -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)

lib/chibi/app.scm

@@ -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))
+      (let ((res (map (lambda (x) (parse-value (cadr type) x))
-           (string-split str #\,)))
+                      (string-split str #\,))))
+        (list (map car res) (any string? (map cdr res)))))
      (else
       (case type
-        ((boolean) (not (member str '("#f" "#false" "#F" "#FALSE"))))
+        ((boolean)
-        ((number) (string->number str))
+         (list (not (member str '("#f" "#false" "#F" "#FALSE" "false" "FALSE")))
-        ((symbol) (string->symbol str))
+               #f))
-        ((char) (string-ref str 0))
+        ((number integer real)
-        (else str)))))
+         (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)
+  (define (parse-long-option str args fail)
-    (let* ((strs (string-split str #\.))
+    (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)))
+        (let ((val+err (parse-value (cadr spec) (car args))))
-              (cdr args))))))
+          (if (cadr val+err)
-  (define (parse-long-option str args)
+              (fail prefix conf-spec (car args) args (cadr val+err))
-    (let* ((str+val (string-split str #\= 2))
+              (cons (cons (append prefix syms) (car val+err))
-           (str (car str+val))
+                    (cdr args))))))))
-           (args2 (if (pair? (cdr str+val)) (cons (cadr str+val) args) args)))
+  (define (parse-short-option str args fail)
-      (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* ((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)))
+        (let ((val+err (parse-value (cadr x) (substring str 1))))
-                    (parse-value (cadr x) (substring str 1)))
+          (if (cadr val+err)
-              args))
+              (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))
+  (if (eqv? #\- (string-ref (car args) 1))
-          (parse-long-option (substring (car args) 2) (cdr args))
+      (parse-long-option (substring (car args) 2) (cdr args) fail)
-          (parse-short-option (substring (car args) 1) (cdr args)))
+      (parse-short-option (substring (car args) 1) (cdr args) fail)))
-      (fail prefix conf-spec (car args) args)))
 
 (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)
+                  (lambda (prefix spec opt args reason)
-                    ;; TODO: search for closest option
+                    ;; TODO: search for closest option in "unknown" case
-                    (error "unknown option: " opt)))))
+                    (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))

lib/meta-7.scm

@@ -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)
 

tools/chibi-ffi

@@ -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])"))

tools/chibi-genstatic

@@ -270,42 +270,11 @@
        (else
         (lp modules))))))
 
-(define (find-c-libs args)
+(define (find-c-libs includes excludes cfiles)
-  (define (split-mod-names str)
+  (cons (if includes
-    (map (lambda (m)
+            (find-c-libs-from-module-names includes)
-           (map (lambda (x) (or (string->number x) (string->symbol x)))
+            (find-c-libs-from-file-names excludes))
-                (string-split m #\.)))
+        cfiles))
-         (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))))))))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
@@ -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))