From 8f699618322a282737fc2de4a7112c443c923d51 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sat, 24 Mar 2012 20:42:49 +0900 Subject: [PATCH] initial c++ ffi support --- include/chibi/sexp.h | 3 +- opcodes.c | 4 +- sexp.c | 2 +- tools/chibi-ffi | 411 +++++++++++++++++++++++++++++++++---------- 4 files changed, 323 insertions(+), 97 deletions(-) diff --git a/include/chibi/sexp.h b/include/chibi/sexp.h index cd579132..bd6af2e8 100755 --- a/include/chibi/sexp.h +++ b/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) diff --git a/opcodes.c b/opcodes.c index 0b487d3d..32e35a5a 100644 --- a/opcodes.c +++ b/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 diff --git a/sexp.c b/sexp.c index a8bfdbf4..3aea0479 100644 --- a/sexp.c +++ b/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}, diff --git a/tools/chibi-ffi b/tools/chibi-ffi index 6e2bb1f3..f9997a68 100755 --- a/tools/chibi-ffi +++ b/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*) - (string-append "sexp_make_fixnum(sexp_type_tag(" (type-id-name (type-base type)) "))")) + ((lookup-type (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) #\- " ") - (if struct-type "*" "") + (base-type-c-name base) + (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,54 +1257,88 @@ (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)))))) - (cat " op = " - (if default - (if (parameter-default? (type-value default)) - "sexp_define_foreign_param(ctx, env, " - "sexp_define_foreign_opt(ctx, env, ") - "sexp_define_foreign(ctx, env, ") + (car (reverse (func-scheme-args func))))) + (no-bind? (and (pair? o) (car o)))) + (cat " " var " = " + (cond + (no-bind? + "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)" "") - (func-stub-name func) - (if default ", " "") - (if default (write-default default) "") - ");\n" + (if no-bind? + (lambda () + (cat (cond ((not default) 0) + ((parameter-default? (type-value default)) 3) + (else 1)) + ", ")) + "") + "(sexp_proc1)" (func-stub-name 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" - " sexp_opcode_return_type(op) = " - (type-id-init-value (func-ret-type func)) ";\n" - (lambda () - (do ((ls (func-c-args func) (cdr ls)) - (i 1 (+ i 1))) - ((null? ls)) - (cond - ((eq? 'sexp (type-base (car ls)))) - ((<= i 3) - (cat " sexp_opcode_arg" i "_type(op) = " - (type-id-init-value (car ls)) ";\n")) - (else - (if (= i 4) - (cat " sexp_opcode_argn_type(op) = " - "sexp_make_vector(ctx, sexp_make_fixnum(" - (- (length (func-c-args func)) 3) ")," - " sexp_make_fixnum(SEXP_OBJECT));\n")) - (cat " sexp_vector_set(sexp_opcode_argn_type(op), " - "sexp_make_fixnum(" (- i 4) "), " - (type-id-init-value (car ls)) ");\n"))))) - " }\n"))) + (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)))) + (cat + " if (sexp_opcodep(" var ")) {\n" + " sexp_opcode_return_type(" var ") = " + (type-id-init-value (func-ret-type func)) ";\n" + (lambda () + (do ((ls (func-c-args func) (cdr ls)) + (i 1 (+ i 1))) + ((null? ls)) + (cond + ((eq? 'sexp (type-base (car ls)))) + ((<= i 3) + (cat " sexp_opcode_arg" i "_type(" var ") = " + (type-id-init-value (car ls)) ";\n")) (else - ""))))) + (if (= i 4) + (cat " sexp_opcode_argn_type(" var ") = " + "sexp_make_vector(ctx, " + (make-integer (- (length (func-c-args func)) 3)) ", " + (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"))))) + " }\n")))) + +(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-name name) " *r;\n" + " " (type-c-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(" - (or (type-struct-type name) "") " " (type-name name) "));\n" + " sexp_cpointer_value(res) = calloc(1, sizeof(" + (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))))))