adding inline ffi stubs and assertions

tools/chibi-ffi

@@ -304,7 +304,7 @@
 ;; function objects
 
 (define (parse-func func . o)
-  (if (not (and (= 3 (length func))
+  (if (not (and (>= (length func) 3)
                 (or (identifier? (cadr func))
                     (and (list? (cadr func))
                          (<= 1 (length (cadr func)) 3)
@@ -320,7 +320,13 @@
                      (mangle scheme-name)))
          (stub-name (if (and (pair? (cadr func)) (pair? (cddr (cadr func))))
                         (car (cddr (cadr func)))
-                        (generate-stub-name scheme-name))))
+                        (generate-stub-name scheme-name)))
+         (inline (and (> (length func) 3)
+                      (cond ((assq 'inline (cdr (cddr func))) => cadr)
+                            (else #f))))
+         (assert (and (> (length func) 3)
+                      (cond ((assq 'assert (cdr (cddr func))) => cdr)
+                            (else '())))))
     (let lp ((ls (if (equal? (car (cddr func)) '(void)) '() (car (cddr func))))
              (i 0)
              (results '())
@@ -330,7 +336,7 @@
        ((null? ls)
         (vector scheme-name c-name stub-name ret-type
                 (reverse results) (reverse c-args) (reverse s-args)
-                method?))
+                method? inline assert))
        (else
         (let ((type (parse-type (car ls) i)))
           (cond
@@ -350,6 +356,8 @@
 (define (func-c-args func) (vector-ref func 5))
 (define (func-scheme-args func) (vector-ref func 6))
 (define (func-method? func) (vector-ref func 7))
+(define (func-inline func) (vector-ref func 8))
+(define (func-assert func) (vector-ref func 9))
 
 (define (func-stub-name-set! func x) (vector-set! func 2 x))
 
@@ -843,7 +851,7 @@
           (cat "sexp_string_to_bytes(ctx, sexp_c_string(ctx, "
                val ".data(), " val ".size()))")
           (cat "sexp_string_to_bytes(ctx, sexp_c_string(ctx, " val ", "
-               (c-array-length type val) "))")))
+               (c-array-length type) "))")))
      ((eq? 'input-port base)
       (cat "sexp_make_non_null_input_port(ctx, " val ", SEXP_FALSE)"))
      ((eq? 'output-port base)
@@ -1063,6 +1071,18 @@
 (define (write-parameters args)
   (lambda () (for-each (lambda (a) (cat ", sexp arg" (type-index a))) args)))
 
+(define (write-c-parameters args)
+  (lambda ()
+    (let lp ((ls args) (i 0))
+      (cond
+       ((pair? ls)
+        (if (> i 0)
+            (cat ", "))
+        (cat (type-c-name (car ls)))
+        (cat " arg")
+        (cat i)
+        (lp (cdr ls) (+ i 1)))))))
+
 (define (take ls n)
   (let lp ((ls ls) (n n) (res '()))
     (if (zero? n) (reverse res) (lp (cdr ls) (- n 1) (cons (car ls) res)))))
@@ -1215,6 +1235,7 @@
     ;; Shortcut returns should come before preserving.
     (write-validators (func-scheme-args func))
     (write-additional-checks (func-c-args func))
+    (write-assertions func (func-assert func))
     ;; Preserve the gc vars.
     (write-gc-preserves gc-vars)))
 
@@ -1238,6 +1259,54 @@
          (cat "  sexp_check_block_port(ctx, arg" (type-index a) ", 0);\n")))
    args))
 
+(define (write-scheme->c expr)
+  (define (write-numeric-arg x)
+    (if (symbol? x)
+        (cat "sexp_unbox_fixnum(" x ")")
+        (write-scheme->c x)))
+  (if (pair? expr)
+      (case (car expr)
+        ((+ - * / %)
+         (write-scheme->c (cadr expr))
+         (for-each
+          (lambda (x)
+            (cat " " (car expr) " ")
+            (write-numeric-arg x))
+          (cddr expr)))
+        ((< <= == != >= >)
+         (let lp ((ls (cdr expr)))
+           (cat "(" (lambda () (write-numeric-arg (car ls))) " " (car expr)
+                " " (lambda () (write-numeric-arg (cadr ls)))
+                ")")
+           (cond
+            ((pair? (cddr ls))
+             (display " && ")
+             (lp (cdr ls))))))
+        (else
+         (write (scheme-procedure->c (car expr)))
+         (display "(")
+         (cond
+          ((pair? (cdr expr))
+           (write-scheme->c (cadr expr))
+           (for-each
+            (lambda (x) (cat ", " (lambda () (write-scheme->c x))))
+            (cddr expr))))
+         (display ")")))
+      (write expr)))
+
+(define (write-assertions func asserts)
+  (for-each
+   (lambda (assert)
+     (cat "  if (!(" (lambda () (write-scheme->c assert)) ")) {\n"
+          "    return sexp_user_exception(ctx, self, \"assertion failed: \" "
+          (call-with-output-string
+            (lambda (out)
+              (write (call-with-output-string
+                       (lambda (out) (write assert out))) out)))
+          ", SEXP_NULL);\n"
+          "  }\n"))
+   asserts))
+
 (define (scheme-procedure->c name)
   (cond
    ((eq? name 'length) 'sexp_length_unboxed)
@@ -1608,6 +1677,13 @@
        (write-parameters (func-scheme-args func)) ")"))
 
 (define (write-func func)
+  (cond
+   ((func-inline func)
+    (cat "static "(type-c-name (func-ret-type func)) " " (func-c-name func)
+         "(" (write-c-parameters (func-c-args func)) ") {\n"
+         "   " (if (void-type? (func-ret-type func)) "" "return ")
+         (func-inline func) ";\n"
+         "}\n")))
   (write-func-declaration func)
   (cat " {\n")
   (write-locals func)
@@ -1700,6 +1776,8 @@
         (cat "\"current-output-port\""))
        ((equal? value '(current-error-port))
         (cat "\"current-error-port\""))
+       ((equal? value '(native-endianness))
+        (cat "sexp_global(ctx, SEXP_G_ENDIANNESS)"))
        ((equal? value 'NULL)
         (cat "SEXP_FALSE"))
        (else
@@ -1747,14 +1825,18 @@
      "    sexp_opcode_return_type(" var ") = "
      (type-id-init-value (func-ret-type func)) ";\n"
      (lambda ()
-       (do ((ls (func-c-args func) (cdr ls))
+       (let lp ((ls (func-c-args func))
-            (i 1 (+ i 1)))
+                (i 1))
-           ((null? ls))
          (cond
-          ((eq? 'sexp (type-base (car ls))))
+          ((null? ls))
+          ((type-value (car ls))
+           (lp (cdr ls) i))
+          ((eq? 'sexp (type-base (car ls)))
+           (lp (cdr ls) (+ i 1)))
           ((<= i 3)
            (cat "    sexp_opcode_arg" i "_type(" var ") = "
-                (type-id-init-value (car ls)) ";\n"))
+                (type-id-init-value (car ls)) ";\n")
+           (lp (cdr ls) (+ i 1)))
           (else
            (if (= i 4)
                (cat "    sexp_opcode_argn_type(" var ") = "
@@ -1763,7 +1845,8 @@
                     (make-integer "SEXP_OBJECT") ");\n"))
            (cat "    sexp_vector_set(sexp_opcode_argn_type(" var "), "
                 (make-integer (- i 4)) ", "
-                (type-id-init-value (car ls)) ");\n")))))
+                (type-id-init-value (car ls)) ");\n")
+           (lp (cdr ls) (+ i 1))))))
      ;; "  } else {\n"
      ;; "    sexp_warn(ctx, \"couldn't generated opcode\", " var ");\n"
      "  }\n")))