initial c++ ffi support

This commit is contained in:
Alex Shinn 2012-03-24 20:42:49 +09:00
parent 13a498c69d
commit 8f69961832
4 changed files with 323 additions and 97 deletions

View file

@ -267,7 +267,7 @@ struct sexp_type_struct {
struct sexp_opcode_struct { struct sexp_opcode_struct {
unsigned char op_class, code, num_args, flags, inverse; unsigned char op_class, code, num_args, flags, inverse;
sexp name, data, data2, proc, ret_type, arg1_type, arg2_type, arg3_type, sexp name, data, data2, proc, ret_type, arg1_type, arg2_type, arg3_type,
argn_type, dl; argn_type, methods, dl;
sexp_proc1 func; 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_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_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_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_func(x) (sexp_field(x, opcode, SEXP_OPCODE, func))
#define sexp_opcode_variadic_p(x) (sexp_opcode_flags(x) & 1) #define sexp_opcode_variadic_p(x) (sexp_opcode_flags(x) & 1)

View file

@ -1,8 +1,8 @@
#define _I(n) sexp_make_fixnum(n) #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 #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 #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) #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 #endif

2
sexp.c
View file

@ -175,7 +175,7 @@ static struct sexp_type_struct _sexp_type_specs[] = {
#if SEXP_USE_DL #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}, {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 #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_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_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}, {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},

View file

@ -25,16 +25,22 @@
;; several of the core modules provide C interfaces directly without ;; several of the core modules provide C interfaces directly without
;; using the stubber. ;; using the stubber.
;; For bootstrapping purposes we depend only on the core language.
(import (scheme)) (import (scheme))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; globals ;; globals
(define *ffi-version* "0.2")
(define *types* '()) (define *types* '())
(define *typedefs* '())
(define *funcs* '()) (define *funcs* '())
(define *methods* '())
(define *consts* '()) (define *consts* '())
(define *inits* '()) (define *inits* '())
(define *tags* '()) (define *tags* '())
(define *open-namespaces* '())
(define *c++?* #f)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; type objects ;; type objects
@ -46,33 +52,35 @@
(else (else
(let lp ((type type) (free? #f) (const? #f) (null-ptr? #f) (let lp ((type type) (free? #f) (const? #f) (null-ptr? #f)
(ptr? #f) (ref? #f) (struct? #f) (link? #f) (result? #f) (array #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))) (define (next) (if (null? (cddr type)) (cadr type) (cdr type)))
(case (and (pair? type) (car type)) (case (and (pair? type) (car type))
((free) ((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) ((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) ((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) ((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) ((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) ((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) ((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) ((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) ((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) ((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) ((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 (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-base type) (vector-ref type 0))
(define (type-free? type) (vector-ref type 1)) (define (type-free? type) (vector-ref type 1))
@ -86,7 +94,8 @@
(define (type-array type) (vector-ref type 9)) (define (type-array type) (vector-ref type 9))
(define (type-value type) (vector-ref type 10)) (define (type-value type) (vector-ref type 10))
(define (type-default? type) (vector-ref type 11)) (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) (define (type-auto-expand? type)
(and (pair? (type-array type)) (and (pair? (type-array type))
@ -103,9 +112,13 @@
((symbol? (car ls)) (lp (cddr ls) res)) ((symbol? (car ls)) (lp (cddr ls) res))
(else (lp (cdr ls) (cons (car 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) (define (type-field-type type field)
(cond (cond
((assq (type-base (parse-type type)) *types*) ((lookup-type (type-base (parse-type type)))
=> (lambda (x) => (lambda (x)
(let lp ((ls (struct-fields (cdr x)))) (let lp ((ls (struct-fields (cdr x))))
(cond (cond
@ -161,7 +174,7 @@
(let ((type (parse-type type))) (let ((type (parse-type type)))
(and (not (type-array type)) (and (not (type-array type))
(not (void-pointer-type? type)) (not (void-pointer-type? type))
(not (assq (type-base type) *types*))))) (not (lookup-type (type-base type))))))
(define (void-pointer-type? type) (define (void-pointer-type? type)
(or (and (eq? 'void (type-base type)) (type-pointer? type)) (or (and (eq? 'void (type-base type)) (type-pointer? type))
@ -170,12 +183,13 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; function objects ;; function objects
(define (parse-func func) (define (parse-func func . o)
(if (not (and (= 3 (length func)) (if (not (and (= 3 (length func))
(or (identifier? (cadr func)) (list (cadr func))) (or (identifier? (cadr func)) (list (cadr func)))
(list (caddr func)))) (list (caddr func))))
(error "bad function definition" 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))) (scheme-name (if (pair? (cadr func)) (caadr func) (cadr func)))
(c-name (if (pair? (cadr func)) (c-name (if (pair? (cadr func))
(cadadr func) (cadadr func)
@ -191,7 +205,8 @@
(cond (cond
((null? ls) ((null? ls)
(vector scheme-name c-name stub-name ret-type (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 (else
(let ((type (parse-type (car ls) i))) (let ((type (parse-type (car ls) i)))
(cond (cond
@ -210,6 +225,9 @@
(define (func-results func) (vector-ref func 4)) (define (func-results func) (vector-ref func 4))
(define (func-c-args func) (vector-ref func 5)) (define (func-c-args func) (vector-ref func 5))
(define (func-scheme-args func) (vector-ref func 6)) (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 ;; utilities
@ -217,6 +235,14 @@
(define (cat . args) (define (cat . args)
(for-each (lambda (x) (if (procedure? x) (x) (display x))) 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) (define (x->string x)
(cond ((string? x) x) (cond ((string? x) x)
((symbol? x) (symbol->string x)) ((symbol? x) (symbol->string x))
@ -315,6 +341,14 @@
(define (type-id-name sym) (define (type-id-name sym)
(string-append "sexp_" (mangle sym) "_type_tag")) (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 ;; .stub file interface
@ -386,6 +420,72 @@
(for-each (lambda (x) (set! *consts* (cons (list type x) *consts*))) (for-each (lambda (x) (set! *consts* (cons (list type x) *consts*)))
(cddr expr)))))) (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 ;; C code generation
@ -427,7 +527,7 @@
((eq? base 'output-port) "SEXP_OPORT") ((eq? base 'output-port) "SEXP_OPORT")
((eq? base 'input-output-port) "SEXP_IPORT") ((eq? base 'input-output-port) "SEXP_IPORT")
((void-pointer-type? type) "SEXP_CPOINTER") ((void-pointer-type? type) "SEXP_CPOINTER")
((assq base *types*) ((lookup-type base)
;; (string-append "sexp_type_tag(" (type-id-name base) ")") ;; (string-append "sexp_type_tag(" (type-id-name base) ")")
(let ((i (type-index type))) (let ((i (type-index type)))
(cond (cond
@ -443,7 +543,7 @@
(else (else
(string-append (string-append
"sexp_unbox_fixnum(sexp_vector_ref(sexp_opcode_argn_type(self), " "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")))) (else "SEXP_OBJECT"))))
(define (type-id-value type . o) (define (type-id-value type . o)
@ -451,12 +551,13 @@
((eq? 'void (type-base type)) ((eq? 'void (type-base type))
"SEXP_VOID") "SEXP_VOID")
(else (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) (define (type-id-init-value type)
(cond (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 (else
(type-id-value type)))) (type-id-value type))))
@ -500,7 +601,7 @@
((eq? 'input-output-port base) ((eq? 'input-output-port base)
(cat "sexp_make_non_null_input_output_port(ctx, " val ", SEXP_FALSE)")) (cat "sexp_make_non_null_input_output_port(ctx, " val ", SEXP_FALSE)"))
(else (else
(let ((ctype (assq base *types*)) (let ((ctype (lookup-type base))
(void*? (void-pointer-type? type))) (void*? (void-pointer-type? type)))
(cond (cond
((or ctype void*?) ((or ctype void*?)
@ -547,7 +648,7 @@
((port-type? base) ((port-type? base)
(cat "sexp_port_stream(" val ")")) (cat "sexp_port_stream(" val ")"))
(else (else
(let ((ctype (assq base *types*)) (let ((ctype (lookup-type base))
(void*? (void-pointer-type? type))) (void*? (void-pointer-type? type)))
(cond (cond
((or ctype void*?) ((or ctype void*?)
@ -561,24 +662,35 @@
(define (base-type-c-name base) (define (base-type-c-name base)
(case base (case base
((string env-string non-null-string) "char*") ((string env-string non-null-string) (if *c++?* "string" "char*"))
(else (symbol->string base)))) (else (symbol->string base))))
(define (type-struct-type type) (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) (cond ((and type-spec (memq 'type: type-spec)) => cadr)
(else #f)))) (else #f))))
(define (type-c-name type) (define (type-c-name-derefed type)
(let* ((type (parse-type type)) (let* ((type (parse-type type))
(base (type-base type)) (base (type-base type))
(type-spec (assq base *types*)) (type-spec (lookup-type base))
(struct-type (type-struct-type type))) (struct-type (type-struct-type type)))
(string-append (string-append
(if (type-const? type) "const " "") (if (type-const? type) "const " "")
(if struct-type (string-append (symbol->string struct-type) " ") "") (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) "*" "")))) (if (type-pointer? type) "*" ""))))
(define (check-type arg type) (define (check-type arg type)
@ -591,7 +703,7 @@
((or (int-type? base) (float-type? base) ((or (int-type? base) (float-type? base)
(string-type? base) (port-type? base)) (string-type? base) (port-type? base))
(cat (type-predicate type) "(" arg ")")) (cat (type-predicate type) "(" arg ")"))
((or (assq base *types*) (void-pointer-type? type)) ((or (lookup-type base) (void-pointer-type? type))
(cat (cat
(if (type-null? type) "(" "") (if (type-null? type) "(" "")
"(sexp_pointerp(" arg ")" "(sexp_pointerp(" arg ")"
@ -614,7 +726,7 @@
(cond (cond
((number? array) ((number? array)
(cat " if (!sexp_listp(ctx, " arg ")" (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"))) " return sexp_type_exception(ctx, self, SEXP_PAIR, " arg ");\n")))
(cat " for (res=" arg "; sexp_pairp(res); res=sexp_cdr(res))\n" (cat " for (res=" arg "; sexp_pairp(res); res=sexp_cdr(res))\n"
" if (! " (lambda () (check-type "sexp_car(res)" type)) ")\n" " if (! " (lambda () (check-type "sexp_car(res)" type)) ")\n"
@ -635,7 +747,7 @@
" if (! " (lambda () (check-type arg type)) ")\n" " if (! " (lambda () (check-type arg type)) ")\n"
" return sexp_type_exception(ctx, self, " " return sexp_type_exception(ctx, self, "
(type-id-number type) ", " arg ");\n")) (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 (cat
" if (! " (lambda () (check-type arg type)) ")\n" " if (! " (lambda () (check-type arg type)) ")\n"
" return sexp_type_exception(ctx, self, " " return sexp_type_exception(ctx, self, "
@ -787,7 +899,7 @@
(eq? val (get-array-length func x)))) (eq? val (get-array-length func x))))
(func-c-args func)) (func-c-args func))
=> (lambda (x) (cat "len" (type-index x)))) => (lambda (x) (cat "len" (type-index x))))
((assq val *types*) ((lookup-type val)
(cat (or (type-struct-type val) "") " " val)) (cat (or (type-struct-type val) "") " " val))
((list? val) ((list? val)
(write (car val)) (write (car val))
@ -886,12 +998,16 @@
c->scheme-converter) c->scheme-converter)
ret-type ret-type
(lambda () (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 (for-each
(lambda (arg) (lambda (arg)
(if (> (type-index arg) 0) (cat ", ")) (if (> (type-index arg) (if (func-method? func) 1 0)) (cat ", "))
(write-actual-parameter func arg)) (write-actual-parameter func arg))
c-args) (if (func-method? func) (cdr c-args) c-args))
(cat ")")) (cat ")"))
(cond (cond
((find type-link? (func-c-args func)) ((find type-link? (func-c-args func))
@ -1016,7 +1132,7 @@
((memq (type-base a) '(input-port input-output-port)) ((memq (type-base a) '(input-port input-output-port))
(cat " sexp_maybe_unblock_port(ctx, arg" (type-index a) ");\n")) (cat " sexp_maybe_unblock_port(ctx, arg" (type-index a) ");\n"))
((and (type-result? a) (not (basic-type? a)) ((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)) (not (type-free? a)) (not (type-pointer? a))
(or (not (type-array a)) (or (not (type-array a))
(not (integer? (get-array-length func a))))) (not (integer? (get-array-length func a)))))
@ -1040,10 +1156,14 @@
((pair? gc-vars) ((pair? gc-vars)
(cat " sexp_gc_release" num-gc-vars "(ctx);\n"))))) (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) (cat "static sexp " (func-stub-name func)
" (sexp ctx, sexp self, sexp_sint_t n" " (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-locals func)
(write-temporaries func) (write-temporaries func)
(write-call func) (write-call func)
@ -1052,6 +1172,70 @@
(cat " return res;\n" (cat " return res;\n"
"}\n\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) (define (parameter-default? x)
(and (pair? x) (and (pair? x)
(member x '((current-input-port) (member x '((current-input-port)
@ -1073,54 +1257,88 @@
(else (else
(c->scheme-converter x value)))))) (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)) (let ((default (and (pair? (func-scheme-args func))
(type-default? (car (reverse (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, ")
"sexp_define_foreign(ctx, env, ") ((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)))) (lambda () (write (symbol->string (func-scheme-name func))))
", " (length (func-scheme-args 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 (cond
((or (not (eq? 'sexp (type-base (func-ret-type func)))) (default (lambda () (cat ", " (write-default default))))
(and (pair? (func-c-args func)) (no-bind? ", SEXP_VOID")
(any (lambda (a) (not (eq? 'sexp (type-base a)))) (else ""))
(func-c-args func)))) ");\n")))
(lambda ()
(cat (define (write-func-types var func)
" if (sexp_opcodep(op)) {\n" (cond
" sexp_opcode_return_type(op) = " ((or (not (eq? 'sexp (type-base (func-ret-type func))))
(type-id-init-value (func-ret-type func)) ";\n" (and (pair? (func-c-args func))
(lambda () (any (lambda (a) (not (eq? 'sexp (type-base a))))
(do ((ls (func-c-args func) (cdr ls)) (func-c-args func))))
(i 1 (+ i 1))) (cat
((null? ls)) " if (sexp_opcodep(" var ")) {\n"
(cond " sexp_opcode_return_type(" var ") = "
((eq? 'sexp (type-base (car ls)))) (type-id-init-value (func-ret-type func)) ";\n"
((<= i 3) (lambda ()
(cat " sexp_opcode_arg" i "_type(op) = " (do ((ls (func-c-args func) (cdr ls))
(type-id-init-value (car ls)) ";\n")) (i 1 (+ i 1)))
(else ((null? ls))
(if (= i 4) (cond
(cat " sexp_opcode_argn_type(op) = " ((eq? 'sexp (type-base (car ls))))
"sexp_make_vector(ctx, sexp_make_fixnum(" ((<= i 3)
(- (length (func-c-args func)) 3) ")," (cat " sexp_opcode_arg" i "_type(" var ") = "
" sexp_make_fixnum(SEXP_OBJECT));\n")) (type-id-init-value (car ls)) ";\n"))
(cat " sexp_vector_set(sexp_opcode_argn_type(op), "
"sexp_make_fixnum(" (- i 4) "), "
(type-id-init-value (car ls)) ");\n")))))
" }\n")))
(else (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) (define (write-type type)
(let ((name (car type)) (let ((name (car type))
@ -1172,7 +1390,7 @@
((type-struct? (car field)) ((type-struct? (car field))
;; assign to a nested struct - copy field-by-field ;; assign to a nested struct - copy field-by-field
(let ((field-type (let ((field-type
(cond ((assq (type-name (car field)) *types*) => cdddr) (cond ((lookup-type (type-name (car field))) => cdddr)
(else (cdr field))))) (else (cdr field)))))
(lambda () (lambda ()
(for-each (for-each
@ -1233,8 +1451,7 @@
(cat ", sexp arg" i) (cat ", sexp arg" i)
(lp (cdr ls) (+ i 1)))))) (lp (cdr ls) (+ i 1))))))
") {\n" ") {\n"
" " (or (type-struct-type name) "") " " (type-c-name name) " r;\n"
" " (type-name name) " *r;\n"
" sexp_gc_var1(res);\n" " sexp_gc_var1(res);\n"
" sexp_gc_preserve1(ctx, res);\n" " sexp_gc_preserve1(ctx, res);\n"
;; TODO: support heap-managed allocations ;; TODO: support heap-managed allocations
@ -1249,10 +1466,11 @@
;; "));\n" ;; "));\n"
" res = sexp_alloc_tagged(ctx, sexp_sizeof(cpointer), " " res = sexp_alloc_tagged(ctx, sexp_sizeof(cpointer), "
"sexp_unbox_fixnum(sexp_opcode_return_type(self)));\n" "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(" " memset(r, 0, sizeof("
(or (type-struct-type name) "") " " (type-name name) "));\n" (type-c-name-derefed name) "));\n"
" sexp_freep(res) = 1;\n" " sexp_freep(res) = 1;\n"
(lambda () (lambda ()
(let lp ((ls args) (i 0)) (let lp ((ls args) (i 0))
@ -1346,7 +1564,12 @@
(newline) (newline)
(write-utilities) (write-utilities)
(for-each write-func *funcs*) (for-each write-func *funcs*)
(for-each write-method *methods*)
(for-each write-type-funcs *types*) (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" (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 () (lambda ()
(for-each (for-each
@ -1360,13 +1583,15 @@
(for-each write-const *consts*) (for-each write-const *consts*)
(for-each write-type *types*) (for-each write-type *types*)
(for-each write-func-binding *funcs*) (for-each write-func-binding *funcs*)
(for-each write-method-binding *methods*)
(for-each (lambda (x) (cat " " x "\n")) (reverse *inits*)) (for-each (lambda (x) (cat " " x "\n")) (reverse *inits*))
(cat " sexp_gc_release3(ctx);\n" (cat " sexp_gc_release3(ctx);\n"
" return SEXP_VOID;\n" " return SEXP_VOID;\n"
"}\n\n")) "}\n\n"))
(define (generate file) (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") (c-system-include "chibi/eval.h")
(load file) (load file)
(write-init)) (write-init))
@ -1379,7 +1604,7 @@
(let* ((compile? (and (pair? args) (member (car args) '("-c" "--compile")))) (let* ((compile? (and (pair? args) (member (car args) '("-c" "--compile"))))
(args (if compile? (cdr args) args)) (args (if compile? (cdr args) args))
(cflags (if (and (pair? args) (member (car args) '("-f" "--flags"))) (cflags (if (and (pair? args) (member (car args) '("-f" "--flags")))
(string-split (cadr args) " ") (string-split (cadr args) #\space)
#f)) #f))
(args (if cflags (cddr args) args)) (args (if cflags (cddr args) args))
(src (car args)) (src (car args))
@ -1403,4 +1628,4 @@
(args (cond-expand (args (cond-expand
(macosx (append '("-dynamiclib" "-Oz") base-args)) (macosx (append '("-dynamiclib" "-Oz") base-args))
(else (append '("-fPIC" "-shared" "-Os") base-args))))) (else (append '("-fPIC" "-shared" "-Os") base-args)))))
(apply system "cc" args)))))) (apply system (if *c++?* "c++" "cc") args))))))