add ffi support for movable parameters

tools/chibi-ffi

@@ -31,7 +31,7 @@
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; globals
 
-(define *ffi-version* "0.4")
+(define *ffi-version* "0.5")
 (define *types* '())
 (define *type-getters* '())
 (define *type-setters* '())
@@ -53,7 +53,7 @@
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; type objects
 
-(define (make-type) (make-vector 19 #f))
+(define (make-type) (make-vector 20 #f))
 
 (define (type-base type) (vector-ref type 0))
 (define (type-free? type) (vector-ref type 1))
@@ -73,8 +73,9 @@
 (define (type-address-of? type) (vector-ref type 15))
 (define (type-no-free? type) (vector-ref type 16))
 (define (type-as-sexp type) (vector-ref type 17))
-(define (type-index type) (vector-ref type 18))
+(define (type-move? type) (vector-ref type 18))
-(define (type-index-set! type i) (vector-set! type 18 i))
+(define (type-index type) (vector-ref type 19))
+(define (type-index-set! type i) (vector-set! type 19 i))
 
 (define (spec->type type . o)
   (let ((res (make-type)))
@@ -136,6 +137,9 @@
         ((as-sexp)
          (vector-set! res 17 #t)
          (lp (next)))
+        ((move)
+         (vector-set! res 18 #t)
+         (lp (next)))
         (else
          (let ((base (if (and (pair? type) (null? (cdr type)))
                          (car type)
@@ -686,6 +690,12 @@
      (ensure-c++ 'c++-using)
      `(,(rename 'cat) "using " ',(cadr expr) ";\n"))))
 
+(define-syntax c++-using-namespace
+  (er-macro-transformer
+   (lambda (expr rename compare)
+     (ensure-c++ 'c++-using-namespace)
+     `(,(rename 'cat) "using namespace " ',(cadr expr) ";\n"))))
+
 (define-syntax define-c++-method
   (er-macro-transformer
    (lambda (expr rename compare)
@@ -1496,7 +1506,8 @@
 (define (write-call func)
   (let ((ret-type (func-ret-type func))
         (c-name (func-c-name func))
-        (c-args (func-c-args func)))
+        (c-args (func-c-args func))
+        (link (find type-link? (func-c-args func))))
     (if (any type-auto-expand? (func-c-args func))
         (cat " loop:\n"))
     (cat (cond ;;((void-type? ret-type) "")
@@ -1523,11 +1534,10 @@
           (write-actual-parameter func arg))
         (if (func-method? func) (cdr c-args) c-args))
        (cat ")"))
-     (cond
+     (and link (string-append "arg" (type-index-string link))))
-      ((find type-link? (func-c-args func))
-       => (lambda (a) (string-append "arg" (type-index-string a))))
-      (else #f)))
     (cat ";\n")
+    ;; (if (and *c++?* (type-new? ret-type) link)
+    ;;     (cat "  sexp_preserve_object(ctx, arg" (type-index-string link) ");\n"))
     (if (type-array ret-type)
         (write-result ret-type)
         (write-result-adjustment ret-type))))
@@ -1716,7 +1726,10 @@
             (or (not (type-array a))
                 (not (integer? (get-array-length func a)))))
        ;; the above is hairy - basically this frees temporary strings
-       (cat "  free(tmp" (type-index a) ");\n"))))
+       (cat "  free(tmp" (type-index a) ");\n"))
+      ((and (type-move? a) (or (type-pointer? a) (not (basic-type? a))))
+       (cat "  sexp_cpointer_value(arg" (type-index a) ") = NULL;  /* moved */\n"
+            "  sexp_cpointer_freep(arg" (type-index a) ") = 0;\n"))))
    (func-c-args func))
   (let* ((results (func-results func))
          (return-res? (not (error-type? (func-ret-type func))))
@@ -1866,8 +1879,9 @@
                (cat (cond ((not default) 0)
                           ((parameter-default? (type-value default)) 3)
                           (else 1))
-                    ", "))
+                    ", \"" (func-stub-name func) "\", "))
              "")
+         "(sexp_proc1)"
          (func-stub-name func)
          (cond
           (default (lambda () (cat ", " (write-default default))))
@@ -1971,8 +1985,10 @@
                       (memq 'finalizer-method: type))
                   => (lambda (x)
                        (let ((name (cadr x)))
+                         (if name
                              (generate-stub-name
-                          (if (pair? name) (car name) name)))))
+                              (if (pair? name) (car name) name))
+                             'NULL))))
                  (*c++?*
                   (type-finalizer-name name))
                  (else
@@ -2121,6 +2137,8 @@
                 (scheme-name (if (pair? y) (car y) y))
                 (cname (if (pair? y) (cadr y) y))
                 (method? (not (memq 'finalizer: type))))
+           (cond
+            (y
              (cat "sexp " (generate-stub-name scheme-name)
                   " (sexp ctx, sexp self, sexp_sint_t n, sexp x) {\n"
                   "  if (sexp_cpointer_freep(x)) {\n"
@@ -2139,7 +2157,7 @@
                   "}\n\n")
              ;; make the finalizer available
              (set! *funcs*
-                 (cons (parse-func `(void ,y (,name))) *funcs*))))))
+                   (cons (parse-func `(void ,y (,name))) *funcs*))))))))
   ;; maybe write constructor
   (cond
    ((memq 'constructor: type)
@@ -2289,10 +2307,12 @@
            (cat
             "sexp " finalizer-name " ("
             "sexp ctx, sexp self, sexp_sint_t n, sexp obj) {\n"
-            "  if (sexp_cpointer_freep(obj))\n"
+            "  if (sexp_cpointer_value(obj) && sexp_cpointer_freep(obj))\n"
             "    delete static_cast<" name "*>"
             "(sexp_cpointer_value(obj));\n"
             "  sexp_cpointer_value(obj) = NULL;\n"
+            ;; "  if (sexp_cpointer_parent(obj) && sexp_pointerp(sexp_cpointer_parent(obj)))\n"
+            ;; "    sexp_release_object(ctx, sexp_cpointer_parent(obj));\n"
             "  return SEXP_VOID;\n"
             "}\n\n")))))
      *types*)))