initial c++ ffi support

include/chibi/sexp.h

@@ -267,7 +267,7 @@ struct sexp_type_struct {
 struct sexp_opcode_struct {
   unsigned char op_class, code, num_args, flags, inverse;
   sexp name, data, data2, proc, ret_type, arg1_type, arg2_type, arg3_type,
-    argn_type, dl;
+    argn_type, methods, dl;
   sexp_proc1 func;
 };
 
@@ -927,6 +927,7 @@ SEXP_API sexp sexp_make_unsigned_integer(sexp ctx, sexp_luint_t x);
 #define sexp_opcode_arg2_type(x)   (sexp_field(x, opcode, SEXP_OPCODE, arg2_type))
 #define sexp_opcode_arg3_type(x)   (sexp_field(x, opcode, SEXP_OPCODE, arg3_type))
 #define sexp_opcode_argn_type(x)   (sexp_field(x, opcode, SEXP_OPCODE, argn_type))
+#define sexp_opcode_methods(x)     (sexp_field(x, opcode, SEXP_OPCODE, methods))
 #define sexp_opcode_func(x)        (sexp_field(x, opcode, SEXP_OPCODE, func))
 
 #define sexp_opcode_variadic_p(x)  (sexp_opcode_flags(x) & 1)

opcodes.c

@@ -1,8 +1,8 @@
 
 #define _I(n) sexp_make_fixnum(n)
-#define _OP(c,o,n,m,rt,a1,a2,a3,i,s,d,f) {c, o, n, m, i, (sexp)s, d, NULL, NULL, rt, a1, a2, a3, NULL, SEXP_FALSE, f}
+#define _OP(c,o,n,m,rt,a1,a2,a3,i,s,d,f) {c, o, n, m, i, (sexp)s, d, NULL, NULL, rt, a1, a2, a3, NULL, NULL, SEXP_FALSE, f}
 #if SEXP_USE_IMAGE_LOADING
-#define _FN(o,n,m,rt,a1,a2,a3,s,d,f) {SEXP_OPC_FOREIGN, o, n, m, 0, (sexp)s, d, (sexp)#f, NULL, rt, a1, a2, a3, NULL, SEXP_FALSE, (sexp_proc1)f}
+#define _FN(o,n,m,rt,a1,a2,a3,s,d,f) {SEXP_OPC_FOREIGN, o, n, m, 0, (sexp)s, d, (sexp)#f, NULL, rt, a1, a2, a3, NULL, NULL, SEXP_FALSE, (sexp_proc1)f}
 #else
 #define _FN(o,n,m,rt,a1,a2,a3,s,d,f) _OP(SEXP_OPC_FOREIGN, o, n, m, rt, a1, a2, a3, 0, s, d, (sexp_proc1)f)
 #endif

sexp.c

@@ -175,7 +175,7 @@ static struct sexp_type_struct _sexp_type_specs[] = {
 #if SEXP_USE_DL
   {SEXP_DL, sexp_offsetof(dl, file), 1, 1, 0, 0, sexp_sizeof(dl), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Dynamic-Library", SEXP_FALSE, SEXP_FALSE, NULL, SEXP_FALSE, NULL, SEXP_FINALIZE_DL},
 #endif
-  {SEXP_OPCODE, sexp_offsetof(opcode, name), 10, 10, 0, 0, sexp_sizeof(opcode), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Opcode", SEXP_FALSE, SEXP_FALSE, NULL, SEXP_FALSE, NULL, NULL},
+  {SEXP_OPCODE, sexp_offsetof(opcode, name), 11, 11, 0, 0, sexp_sizeof(opcode), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Opcode", SEXP_FALSE, SEXP_FALSE, NULL, SEXP_FALSE, NULL, NULL},
   {SEXP_LAMBDA, sexp_offsetof(lambda, name), 11, 11, 0, 0, sexp_sizeof(lambda), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Lambda", SEXP_FALSE, SEXP_FALSE, NULL, SEXP_FALSE, (sexp)sexp_write_simple_object, NULL},
   {SEXP_CND, sexp_offsetof(cnd, test), 4, 4, 0, 0, sexp_sizeof(cnd), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Conditional", SEXP_FALSE, SEXP_FALSE, NULL, SEXP_FALSE, (sexp)sexp_write_simple_object, NULL},
   {SEXP_REF, sexp_offsetof(ref, name), 3, 3, 0, 0, sexp_sizeof(ref), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Reference", SEXP_FALSE, SEXP_FALSE, NULL, SEXP_FALSE, (sexp)sexp_write_simple_object, NULL},

tools/chibi-ffi

@@ -25,16 +25,22 @@
 ;; several of the core modules provide C interfaces directly without
 ;; using the stubber.
 
+;; For bootstrapping purposes we depend only on the core language.
 (import (scheme))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; globals
 
+(define *ffi-version* "0.2")
 (define *types* '())
+(define *typedefs* '())
 (define *funcs* '())
+(define *methods* '())
 (define *consts* '())
 (define *inits* '())
 (define *tags* '())
+(define *open-namespaces* '())
+(define *c++?* #f)
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; type objects
@@ -46,33 +52,35 @@
    (else
     (let lp ((type type) (free? #f) (const? #f) (null-ptr? #f)
              (ptr? #f) (ref? #f) (struct? #f) (link? #f) (result? #f) (array #f)
-             (value #f) (default? #f))
+             (value #f) (default? #f) (template #f))
       (define (next) (if (null? (cddr type)) (cadr type) (cdr type)))
       (case (and (pair? type) (car type))
         ((free)
-         (lp (next) #t const? null-ptr? ptr? ref? struct? link? result? array value default?))
+         (lp (next) #t const? null-ptr? ptr? ref? struct? link? result? array value default? template))
         ((const)
-         (lp (next) free? #t null-ptr? ptr? ref? struct? link? result? array value default?))
+         (lp (next) free? #t null-ptr? ptr? ref? struct? link? result? array value default? template))
         ((maybe-null)
-         (lp (next) free? const? #t ptr? ref? struct? link? result? array value default?))
+         (lp (next) free? const? #t ptr? ref? struct? link? result? array value default? template))
         ((pointer)
-         (lp (next) free? const? null-ptr? #t ref? struct? link? result? array value default?))
+         (lp (next) free? const? null-ptr? #t ref? struct? link? result? array value default? template))
         ((reference)
-         (lp (next) free? const? null-ptr? ptr? #t struct? link? result? array value default?))
+         (lp (next) free? const? null-ptr? ptr? #t struct? link? result? array value default? template))
         ((struct)
-         (lp (next) free? const? null-ptr? ptr? ref? #t link? result? array value default?))
+         (lp (next) free? const? null-ptr? ptr? ref? #t link? result? array value default? template))
         ((link)
-         (lp (next) free? const? null-ptr? ptr? ref? struct? #t result? array value default?))
+         (lp (next) free? const? null-ptr? ptr? ref? struct? #t result? array value default? template))
         ((result)
-         (lp (next) free? const? null-ptr? ptr? ref? struct? link? #t array value default?))
+         (lp (next) free? const? null-ptr? ptr? ref? struct? link? #t array value default? template))
         ((array)
-         (lp (cadr type) free? const? null-ptr? ref? ptr? struct? link? result? (if (pair? (cddr type)) (caddr type) #t) value default?))
+         (lp (cadr type) free? const? null-ptr? ref? ptr? struct? link? result? (if (pair? (cddr type)) (caddr type) #t) value default? template))
         ((value)
-         (lp (cddr type) free? const? null-ptr? ref? ptr? struct? link? result? array (cadr type) default?))
+         (lp (cddr type) free? const? null-ptr? ref? ptr? struct? link? result? array (cadr type) default? template))
         ((default)
-         (lp (cddr type) free? const? null-ptr? ref? ptr? struct? link? result? array (cadr type) #t))
+         (lp (cddr type) free? const? null-ptr? ref? ptr? struct? link? result? array (cadr type) #t template))
+        ((template)
+         (lp (cddr type) free? const? null-ptr? ref? ptr? struct? link? result? array (cadr type) default? (cadr type)))
         (else
-         (vector (if (and (pair? type) (null? (cdr type))) (car type) type) free? const? null-ptr? ptr? ref? struct? link? result? array value default? (and (pair? o) (car o)))))))))
+         (vector (if (and (pair? type) (null? (cdr type))) (car type) type) free? const? null-ptr? ptr? ref? struct? link? result? array value default? template (and (pair? o) (car o)))))))))
 
 (define (type-base type) (vector-ref type 0))
 (define (type-free? type) (vector-ref type 1))
@@ -86,7 +94,8 @@
 (define (type-array type) (vector-ref type 9))
 (define (type-value type) (vector-ref type 10))
 (define (type-default? type) (vector-ref type 11))
-(define (type-index type) (vector-ref type 12))
+(define (type-template type) (vector-ref type 12))
+(define (type-index type) (vector-ref type 13))
 
 (define (type-auto-expand? type)
   (and (pair? (type-array type))
@@ -103,9 +112,13 @@
           ((symbol? (car ls)) (lp (cddr ls) res))
           (else (lp (cdr ls) (cons (car ls) res))))))
 
+(define (lookup-type type)
+  (or (assq type *types*)
+      (assq type *typedefs*)))
+
 (define (type-field-type type field)
   (cond
-   ((assq (type-base (parse-type type)) *types*)
+   ((lookup-type (type-base (parse-type type)))
     => (lambda (x)
          (let lp ((ls (struct-fields (cdr x))))
            (cond
@@ -161,7 +174,7 @@
   (let ((type (parse-type type)))
     (and (not (type-array type))
          (not (void-pointer-type? type))
-         (not (assq (type-base type) *types*)))))
+         (not (lookup-type (type-base type))))))
 
 (define (void-pointer-type? type)
   (or (and (eq? 'void (type-base type)) (type-pointer? type))
@@ -170,12 +183,13 @@
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; function objects
 
-(define (parse-func func)
+(define (parse-func func . o)
   (if (not (and (= 3 (length func))
                 (or (identifier? (cadr func)) (list (cadr func)))
                 (list (caddr func))))
       (error "bad function definition" func))
-  (let* ((ret-type (parse-type (car func)))
+  (let* ((method? (and (pair? o) (car o)))
+         (ret-type (parse-type (car func)))
          (scheme-name (if (pair? (cadr func)) (caadr func) (cadr func)))
          (c-name (if (pair? (cadr func))
                      (cadadr func)
@@ -191,7 +205,8 @@
       (cond
        ((null? ls)
         (vector scheme-name c-name stub-name ret-type
-                (reverse results) (reverse c-args) (reverse s-args)))
+                (reverse results) (reverse c-args) (reverse s-args)
+                method?))
        (else
         (let ((type (parse-type (car ls) i)))
           (cond
@@ -210,6 +225,9 @@
 (define (func-results func) (vector-ref func 4))
 (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-stub-name-set! func x) (vector-set! func 2 x))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; utilities
@@ -217,6 +235,14 @@
 (define (cat . args)
   (for-each (lambda (x) (if (procedure? x) (x) (display x))) args))
 
+(define (join ls . o)
+  (if (pair? ls)
+      (let ((sep (if (pair? o) (car o) " ")))
+        (let lp ((ls ls))
+          (if (pair? (cdr ls))
+              (cat (car ls) sep (lambda () (lp (cdr ls))))
+              (cat (car ls)))))))
+
 (define (x->string x)
   (cond ((string? x) x)
         ((symbol? x) (symbol->string x))
@@ -315,6 +341,14 @@
 (define (type-id-name sym)
   (string-append "sexp_" (mangle sym) "_type_tag"))
 
+(define (make-integer x)
+  (case x
+    ((-1) "SEXP_NEG_ONE")  ((0) "SEXP_ZERO")   ((1) "SEXP_ONE")
+    ((2) "SEXP_TWO")       ((3) "SEXP_THREE")  ((4) "SEXP_FOUR")
+    ((5) "SEXP_FIVE")      ((6) "SEXP_SIX")    ((7) "SEXP_SEVEN")
+    ((8) "SEXP_EIGHT")     ((9) "SEXP_NINE")   ((10) "SEXP_TEN")
+    (else (string-append "sexp_make_fixnum(" (x->string x) ")"))))
+
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; .stub file interface
 
@@ -386,6 +420,72 @@
        (for-each (lambda (x) (set! *consts* (cons (list type x) *consts*)))
                  (cddr expr))))))
 
+(define-syntax c-typedef
+  (er-macro-transformer
+   (lambda (expr rename compare)
+     (let ((type (parse-type (cadr expr)))
+           (name (caddr expr)))
+       (set! *typedefs* `((,name ,@type) ,@*typedefs*))
+       `(,(rename 'cat) "typedef " ,(type-c-name type) " " ',name ";\n")))))
+
+(define (c++)
+  (set! *c++?* #t))
+
+(define (ensure-c++ name)
+  (cond
+   ((not *c++?*)
+    (display "WARNING: assuming c++ mode from " (current-error-port))
+    (display name (current-error-port))
+    (display " - use (c++) to make this explicit\n" (current-error-port))
+    (c++))))
+
+(define-syntax c++-namespace
+  (er-macro-transformer
+   (lambda (expr rename compare)
+     (ensure-c++ 'c++-namespace)
+     (let ((namespace (cadr expr)))
+       (cond
+        ((null? (cddr expr))
+         (set! *open-namespaces* (cons namespace *open-namespaces*))
+         `(,(rename 'cat) "namespace " ',namespace " {\n"))
+        (else
+         `(,(rename 'begin)
+           (,(rename 'cat) "namespace " ',namespace " {\n")
+           ,@(cddr expr)
+           (,(rename 'cat) "}  // namespace " ',namespace "\n\n"))))))))
+
+(define-syntax c++-using
+  (er-macro-transformer
+   (lambda (expr rename compare)
+     (ensure-c++ 'c++-using)
+     `(,(rename 'cat) "using " ',(cadr expr) ";\n"))))
+
+(define-syntax define-c++-method
+  (er-macro-transformer
+   (lambda (expr rename compare)
+     (ensure-c++ 'define-c++-method)
+     (let* ((class (cadr expr))
+            (ret-type (caddr expr))
+            (name (cadddr expr))
+            (meths (map (lambda (x)
+                          (parse-func `(,ret-type ,name (,class ,@x)) #t))
+                        (cddddr expr))))
+       (set! *methods* (cons (cons name meths) *methods*))))))
+
+;; (define-syntax define-c++-constructor
+;;   (er-macro-transformer
+;;    (lambda (expr rename compare)
+;;      (ensure-c++ 'define-c++-constructor)
+;;      (set! *funcs* (cons (parse-func (cdr expr)) *funcs*))
+;;      (let* ((meth (parse-func (cdr expr) #t))
+;;             (name (func-scheme-name meth)))
+;;        (cond
+;;         ((assq name *methods*)
+;;          => (lambda (x) (set-cdr! x (cons meth (cdr x)))))
+;;         (else
+;;          (set! *methods* (cons (list name meth) *methods*)))) 
+;;        #f))))
+
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; C code generation
 
@@ -427,7 +527,7 @@
      ((eq? base 'output-port) "SEXP_OPORT")
      ((eq? base 'input-output-port) "SEXP_IPORT")
      ((void-pointer-type? type) "SEXP_CPOINTER")
-     ((assq base *types*)
+     ((lookup-type base)
       ;; (string-append "sexp_type_tag(" (type-id-name base) ")")
       (let ((i (type-index type)))
         (cond
@@ -443,7 +543,7 @@
          (else
           (string-append
            "sexp_unbox_fixnum(sexp_vector_ref(sexp_opcode_argn_type(self), "
-           "sexp_make_fixnum("(number->string (- i 3)) ")))")))))
+           (make-integer (- i 3)) "))")))))
      (else "SEXP_OBJECT"))))
 
 (define (type-id-value type . o)
@@ -451,12 +551,13 @@
    ((eq? 'void (type-base type))
     "SEXP_VOID")
    (else
-    (string-append "sexp_make_fixnum(" (apply type-id-number type o) ")"))))
+    (make-integer (apply type-id-number type o)))))
 
 (define (type-id-init-value type)
   (cond
-   ((assq (type-base type) *types*)
+   ((lookup-type (type-base type))
-    (string-append "sexp_make_fixnum(sexp_type_tag(" (type-id-name (type-base type)) "))"))
+    (make-integer
+     (string-append "sexp_type_tag(" (type-id-name (type-base type)) ")")))
    (else
     (type-id-value type))))
 
@@ -500,7 +601,7 @@
      ((eq? 'input-output-port base)
       (cat "sexp_make_non_null_input_output_port(ctx, " val ", SEXP_FALSE)"))
      (else
-      (let ((ctype (assq base *types*))
+      (let ((ctype (lookup-type base))
             (void*? (void-pointer-type? type)))
         (cond
          ((or ctype void*?)
@@ -547,7 +648,7 @@
      ((port-type? base)
       (cat "sexp_port_stream(" val ")"))
      (else
-      (let ((ctype (assq base *types*))
+      (let ((ctype (lookup-type base))
             (void*? (void-pointer-type? type)))
         (cond
          ((or ctype void*?)
@@ -561,24 +662,35 @@
 
 (define (base-type-c-name base)
   (case base
-    ((string env-string non-null-string) "char*")
+    ((string env-string non-null-string) (if *c++?* "string" "char*"))
     (else (symbol->string base))))
 
 (define (type-struct-type type)
-  (let ((type-spec (assq (if (vector? type) (type-base type) type) *types*)))
+  (let ((type-spec (lookup-type(if (vector? type) (type-base type) type))))
     (cond ((and type-spec (memq 'type: type-spec)) => cadr)
           (else #f))))
 
-(define (type-c-name type)
+(define (type-c-name-derefed type)
   (let* ((type (parse-type type))
          (base (type-base type))
-         (type-spec (assq base *types*))
+         (type-spec (lookup-type base))
          (struct-type (type-struct-type type)))
     (string-append
      (if (type-const? type) "const " "")
      (if struct-type (string-append (symbol->string struct-type) " ") "")
-     (string-replace (base-type-c-name base) #\- " ")
+     (base-type-c-name base)
-     (if struct-type "*" "")
+     (if (type-template type)
+         (string-append
+          "<"
+          (string-concatenate (map type-c-name (type-template type)) ", ")
+          ">")
+         ""))))
+
+(define (type-c-name type)
+  (let ((type (parse-type type)))
+    (string-append
+     (type-c-name-derefed type)
+     (if (type-struct-type type) "*" "")
      (if (type-pointer? type) "*" ""))))
 
 (define (check-type arg type)
@@ -591,7 +703,7 @@
      ((or (int-type? base) (float-type? base)
           (string-type? base) (port-type? base))
       (cat (type-predicate type) "(" arg ")"))
-     ((or (assq base *types*) (void-pointer-type? type))
+     ((or (lookup-type base) (void-pointer-type? type))
       (cat
        (if (type-null? type) "(" "")
        "(sexp_pointerp(" arg  ")"
@@ -614,7 +726,7 @@
       (cond
        ((number? array)
         (cat "  if (!sexp_listp(ctx, " arg ")"
-             "      || sexp_unbox_fixnum(sexp_length(" arg ")) != " array ")\n"
+             "      || sexp_unbox_fixnum(sexp_length(ctx, " arg ")) != " array ")\n"
              "    return sexp_type_exception(ctx, self, SEXP_PAIR, " arg ");\n")))
       (cat "  for (res=" arg "; sexp_pairp(res); res=sexp_cdr(res))\n"
            "    if (! " (lambda () (check-type "sexp_car(res)" type)) ")\n"
@@ -635,7 +747,7 @@
        "  if (! " (lambda () (check-type arg type)) ")\n"
        "    return sexp_type_exception(ctx, self, "
        (type-id-number type) ", " arg ");\n"))
-     ((or (assq base-type *types*) (void-pointer-type? type))
+     ((or (lookup-type base-type) (void-pointer-type? type))
       (cat
        "  if (! " (lambda () (check-type arg type)) ")\n"
        "    return sexp_type_exception(ctx, self, "
@@ -787,7 +899,7 @@
                  (eq? val (get-array-length func x))))
           (func-c-args func))
     => (lambda (x) (cat "len" (type-index x))))
-   ((assq val *types*)
+   ((lookup-type val)
     (cat (or (type-struct-type val) "") " " val))
    ((list? val)
     (write (car val))
@@ -886,12 +998,16 @@
          c->scheme-converter)
      ret-type
      (lambda ()
-       (cat c-name "(")
+       (if (func-method? func)
+           (cat "(" (lambda () (write-actual-parameter func (car c-args)))
+                ")->" c-name)
+           (cat c-name))
+       (cat "(")
        (for-each
         (lambda (arg)
-          (if (> (type-index arg) 0) (cat ", "))
+          (if (> (type-index arg) (if (func-method? func) 1 0)) (cat ", "))
           (write-actual-parameter func arg))
-        c-args)
+        (if (func-method? func) (cdr c-args) c-args))
        (cat ")"))
      (cond
       ((find type-link? (func-c-args func))
@@ -1016,7 +1132,7 @@
       ((memq (type-base a) '(input-port input-output-port))
        (cat "  sexp_maybe_unblock_port(ctx, arg" (type-index a) ");\n"))
       ((and (type-result? a) (not (basic-type? a))
-            (not (assq (type-base a) *types*))
+            (not (lookup-type (type-base a)))
             (not (type-free? a)) (not (type-pointer? a))
             (or (not (type-array a))
                 (not (integer? (get-array-length func a)))))
@@ -1040,10 +1156,14 @@
      ((pair? gc-vars)
       (cat "  sexp_gc_release" num-gc-vars "(ctx);\n")))))
 
-(define (write-func func)
+(define (write-func-declaration func)
   (cat "static sexp " (func-stub-name func)
        " (sexp ctx, sexp self, sexp_sint_t n"
-       (write-parameters (func-scheme-args func)) ") {\n")
+       (write-parameters (func-scheme-args func)) ")"))
+
+(define (write-func func)
+  (write-func-declaration func)
+  (cat " {\n")
   (write-locals func)
   (write-temporaries func)
   (write-call func)
@@ -1052,6 +1172,70 @@
   (cat "  return res;\n"
        "}\n\n"))
 
+(define (adjust-method-name! func i)
+  (func-stub-name-set!
+   func
+   (string-append (func-stub-name func) "__" (number->string i))))
+
+(define (write-primitive-call func args)
+  (cat (func-stub-name func)
+       "(" (lambda () (join (append '(ctx self n) args) ", ")) ")"))
+
+(define (write-fixed-arity-method meth)
+  (define (write-dispatch func)
+    (write-primitive-call
+     func
+     (map (lambda (a) (string-append "arg" (type-index-string a)))
+          (func-scheme-args func))))
+  (define (write-method-validators func)
+    (cond
+     ((not (pair? (cdr (func-scheme-args func))))
+      (warn "no arguments to distinguish" func)
+      (cat "1"))
+     (else
+      (let lp ((ls (cdr (func-scheme-args func))))
+        (check-type (string-append "arg" (type-index-string (car ls))) (car ls))
+        (cond
+         ((pair? (cdr ls))
+          (cat " && ")
+          (lp (cdr ls))))))))
+  (case (length meth)
+    ((0 1)
+     (error "invalid method" meth))
+    ((2)
+     (write-func (cadr meth)))
+    (else
+     (let ((orig-stub-name (func-stub-name (cadr meth))))
+       (do ((ls (cdr meth) (cdr ls)) (i 0 (+ i 1)))
+           ((null? ls))
+         (adjust-method-name! (car ls) i)
+         (write-func (car ls)))
+       (let ((new-stub-name (func-stub-name (cadr meth))))
+         (func-stub-name-set! (cadr meth) orig-stub-name)
+         (write-func-declaration (cadr meth))
+         (func-stub-name-set! (cadr meth) new-stub-name)
+         (cat " {\n"
+              "  sexp orig_self = self;\n")
+         (write-validator "arg0" (car (func-scheme-args (cadr meth))))
+         (let lp ((ls (cdr meth)) (i 0))
+           (cat "  self = sexp_vector_ref(sexp_opcode_methods(orig_self), "
+                (make-integer i) ");\n")
+           (cond
+            ((null? (cdr ls))
+             (cat "  return " (lambda () (write-dispatch (car ls))) ";\n"))
+            (else
+             (cat "  if ("
+                  (lambda () (write-method-validators (car ls))) ") {\n"
+                  "    return " (lambda () (write-dispatch (car ls))) ";\n"
+                  "  }\n" (lambda () (lp (cdr ls) (+ i 1)))))))
+         (cat "}\n\n")
+         (func-stub-name-set! (cadr meth) orig-stub-name))))))
+
+(define (write-method meth)
+  (if (not (apply = (map length (map func-scheme-args (cdr meth)))))
+      (error "methods must have the same arity"))
+  (write-fixed-arity-method meth))
+
 (define (parameter-default? x)
   (and (pair? x)
        (member x '((current-input-port)
@@ -1073,32 +1257,46 @@
        (else
         (c->scheme-converter x value))))))
 
-(define (write-func-binding func)
+(define (write-func-creation var func . o)
   (let ((default (and (pair? (func-scheme-args func))
                       (type-default? (car (reverse (func-scheme-args func))))
-                      (car (reverse (func-scheme-args func))))))
+                      (car (reverse (func-scheme-args func)))))
-    (cat "  op = "
+        (no-bind? (and (pair? o) (car o))))
-         (if default
+    (cat "  " var " = "
-             (if (parameter-default? (type-value default))
+         (cond
-                 "sexp_define_foreign_param(ctx, env, "
+          (no-bind?
-                 "sexp_define_foreign_opt(ctx, env, ")
+           "sexp_make_foreign(ctx, ")
+          ((not default)
            "sexp_define_foreign(ctx, env, ")
+          ((parameter-default? (type-value default))
+           "sexp_define_foreign_param(ctx, env, ")
+          (else
+           "sexp_define_foreign_opt(ctx, env, "))
          (lambda () (write (symbol->string (func-scheme-name func))))
          ", " (length (func-scheme-args func))  ", "
-         (if default "(sexp_proc1)" "")
+         (if no-bind?
-         (func-stub-name func)
+             (lambda ()
-         (if default ", " "")
+               (cat (cond ((not default) 0)
-         (if default (write-default default) "")
+                          ((parameter-default? (type-value default)) 3)
-         ");\n"
+                          (else 1))
+                    ", "))
+             "")
+         "(sexp_proc1)" (func-stub-name func)
+         (cond
+          (default (lambda () (cat ", " (write-default default))))
+          (no-bind? ", SEXP_VOID")
+          (else ""))
+         ");\n")))
+
+(define (write-func-types var func)
   (cond
    ((or (not (eq? 'sexp (type-base (func-ret-type func))))
         (and (pair? (func-c-args func))
              (any (lambda (a) (not (eq? 'sexp (type-base a))))
                   (func-c-args func))))
-           (lambda ()
     (cat
-              "  if (sexp_opcodep(op)) {\n"
+     "  if (sexp_opcodep(" var ")) {\n"
-              "    sexp_opcode_return_type(op) = "
+     "    sexp_opcode_return_type(" var ") = "
      (type-id-init-value (func-ret-type func)) ";\n"
      (lambda ()
        (do ((ls (func-c-args func) (cdr ls))
@@ -1107,20 +1305,40 @@
          (cond
           ((eq? 'sexp (type-base (car ls))))
           ((<= i 3)
-                    (cat "    sexp_opcode_arg" i "_type(op) = "
+           (cat "    sexp_opcode_arg" i "_type(" var ") = "
                 (type-id-init-value (car ls)) ";\n"))
           (else
            (if (= i 4)
-                        (cat "    sexp_opcode_argn_type(op) = "
+               (cat "    sexp_opcode_argn_type(" var ") = "
-                             "sexp_make_vector(ctx, sexp_make_fixnum("
+                    "sexp_make_vector(ctx, "
-                             (- (length (func-c-args func)) 3) "),"
+                    (make-integer (- (length (func-c-args func)) 3)) ", "
-                             " sexp_make_fixnum(SEXP_OBJECT));\n"))
+                    (make-integer "SEXP_OBJECT") ");\n"))
-                    (cat "    sexp_vector_set(sexp_opcode_argn_type(op), "
+           (cat "    sexp_vector_set(sexp_opcode_argn_type(" var "), "
-                         "sexp_make_fixnum(" (- i 4) "), "
+                (make-integer (- i 4)) ", "
                 (type-id-init-value (car ls)) ");\n")))))
-              "  }\n")))
+     "  }\n"))))
-          (else
+
-           "")))))
+(define (write-func-binding func . o)
+  (let ((var (if (pair? o) (car o) "op")))
+    (write-func-creation var func)
+    (write-func-types var func)))
+
+(define (write-method-binding meth)
+  (write-func-binding (cadr meth))
+  (adjust-method-name! (cadr meth) 0)
+  (cat "  if (sexp_opcodep(op)) {\n"
+       (lambda ()
+         (cat "    sexp_opcode_methods(op) = "
+              "sexp_make_vector(ctx, " (make-integer (length (cdr meth)))
+              ", SEXP_VOID);\n")
+         (do ((ls (cdr meth) (cdr ls)) (i 0 (+ i 1)))
+             ((null? ls))
+           (let ((var (string-append
+                       "sexp_vector_ref(sexp_opcode_methods(op), "
+                       (make-integer i) ")")))
+             (write-func-creation var (car ls) #t)
+             (write-func-types var (car ls)))))
+       "  }\n"))
 
 (define (write-type type)
   (let ((name (car type))
@@ -1172,7 +1390,7 @@
    ((type-struct? (car field))
     ;; assign to a nested struct - copy field-by-field
     (let ((field-type
-           (cond ((assq (type-name (car field)) *types*) => cdddr)
+           (cond ((lookup-type (type-name (car field))) => cdddr)
                  (else (cdr field)))))
       (lambda ()
         (for-each
@@ -1233,8 +1451,7 @@
                              (cat ", sexp arg" i)
                              (lp (cdr ls) (+ i 1))))))
                   ") {\n"
-                  "  " (or (type-struct-type name) "")
+                  "  " (type-c-name name) " r;\n"
-                  " " (type-name name) " *r;\n"
                   "  sexp_gc_var1(res);\n"
                   "  sexp_gc_preserve1(ctx, res);\n"
                   ;; TODO: support heap-managed allocations
@@ -1249,10 +1466,11 @@
                   ;; "));\n"
                   "  res = sexp_alloc_tagged(ctx, sexp_sizeof(cpointer), "
                   "sexp_unbox_fixnum(sexp_opcode_return_type(self)));\n"
-                  "  r = sexp_cpointer_value(res) = calloc(1, sizeof("
+                  "  sexp_cpointer_value(res) = calloc(1, sizeof("
-                  (or (type-struct-type name) "") " " (type-name name) "));\n"
+                  (type-c-name-derefed name) "));\n"
+                  "  r = (" (type-c-name name) ") sexp_cpointer_value(res);\n"
                   "  memset(r, 0, sizeof("
-                  (or (type-struct-type name) "") " " (type-name name) "));\n"
+                  (type-c-name-derefed name) "));\n"
                   "  sexp_freep(res) = 1;\n"
                   (lambda ()
                     (let lp ((ls args) (i 0))
@@ -1346,7 +1564,12 @@
   (newline)
   (write-utilities)
   (for-each write-func *funcs*)
+  (for-each write-method *methods*)
   (for-each write-type-funcs *types*)
+  (for-each (lambda (n) (cat "}  // " n "\n")) *open-namespaces*)
+  (newline)
+  (if *c++?*
+      (cat "extern \"C\" "))
   (cat "sexp sexp_init_library (sexp ctx, sexp self, sexp_sint_t n, sexp env, const char* version, sexp_abi_identifier_t abi) {\n"
        (lambda ()
          (for-each
@@ -1360,13 +1583,15 @@
   (for-each write-const *consts*)
   (for-each write-type *types*)
   (for-each write-func-binding *funcs*)
+  (for-each write-method-binding *methods*)
   (for-each (lambda (x) (cat "  " x "\n")) (reverse *inits*))
   (cat "  sexp_gc_release3(ctx);\n"
        "  return SEXP_VOID;\n"
        "}\n\n"))
 
 (define (generate file)
-  (display "/* automatically generated by chibi genstubs */\n")
+  (cat "/* Automatically generated by chibi-ffi; version: "
+       *ffi-version* " */\n")
   (c-system-include "chibi/eval.h")
   (load file)
   (write-init))
@@ -1379,7 +1604,7 @@
   (let* ((compile? (and (pair? args) (member (car args) '("-c" "--compile"))))
          (args (if compile? (cdr args) args))
          (cflags (if (and (pair? args) (member (car args) '("-f" "--flags")))
-                     (string-split (cadr args) " ")
+                     (string-split (cadr args) #\space)
                      #f))
          (args (if cflags (cddr args) args))
          (src (car args))
@@ -1403,4 +1628,4 @@
              (args (cond-expand
                     (macosx (append '("-dynamiclib" "-Oz") base-args))
                     (else (append '("-fPIC" "-shared" "-Os") base-args)))))
-        (apply system "cc" args))))))
+        (apply system (if *c++?* "c++" "cc") args))))))