Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-07-06 04:36:38 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

initial c++ ffi support

Browse source
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
Show stats Download patch file Download diff file Expand all files Collapse all files

3
include/chibi/sexp.h
View file

@ -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)

4
opcodes.c
View file

@ -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

2
sexp.c
View file

@ -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},

411
tools/chibi-ffi
View file

@ -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))))))