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

Binding C types, and adding declare-c-struct/class/union to access them from imported libraries.

Browse source
This commit is contained in:
Alex Shinn 2013-05-30 08:08:42 +09:00
parent 6659baa6b6
commit aba919f1b4
1 changed files with 173 additions and 140 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

313
tools/chibi-ffi
View file

@ -343,7 +343,7 @@
(string-append "sexp_" (mangle sym) "_stub")) (string-append "sexp_" (mangle sym) "_stub"))
(define (type-id-name sym) (define (type-id-name sym)
(string-append "sexp_" (mangle sym) "_type_tag")) (string-append "sexp_" (mangle sym) "_type_obj"))
(define (make-integer x) (define (make-integer x)
(case x (case x
@ -411,6 +411,21 @@
(lambda (expr rename compare) (lambda (expr rename compare)
`(define-struct-like ,(cadr expr) ,@(cddr expr))))) `(define-struct-like ,(cadr expr) ,@(cddr expr)))))
(define-syntax declare-c-struct
(er-macro-transformer
(lambda (expr rename compare)
`(define-struct-like ,(cadr expr) type: struct imported?: #t))))
(define-syntax declare-c-class
(er-macro-transformer
(lambda (expr rename compare)
`(define-struct-like ,(cadr expr) type: class imported?: #t))))
(define-syntax declare-c-union
(er-macro-transformer
(lambda (expr rename compare)
`(define-struct-like ,(cadr expr) type: union imported?: #t))))
(define-syntax define-c (define-syntax define-c
(er-macro-transformer (er-macro-transformer
(lambda (expr rename compare) (lambda (expr rename compare)
@ -1431,27 +1446,38 @@
" }\n")) " }\n"))
(define (write-type type) (define (write-type type)
(let ((name (car type)) (let* ((name (car type))
(type (cdr type))) (type (cdr type))
(cat " name = sexp_c_string(ctx, \"" (type-name name) "\", -1);\n" (imported? (cond ((member 'imported?: type) => cadr) (else #f))))
" " (type-id-name name)
" = sexp_register_c_type(ctx, name, "
(cond ((memq 'finalizer: type)
=> (lambda (x)
(let ((name (cadr x)))
(generate-stub-name
(if (pair? name) (car name) name)))))
(else "sexp_finalize_c_type"))
");\n")
(cond (cond
((memq 'predicate: type) (imported?
=> (lambda (x) (cat " name = sexp_intern(ctx, \"" (type-name name) "\", -1);\n"
(let ((pred (cadr x))) " " (type-id-name name) " = sexp_env_ref(env, name, SEXP_FALSE);\n"
(cat " tmp = sexp_make_type_predicate(ctx, name, " " if (sexp_not(" (type-id-name name) ")) {\n"
(type-id-name name) ");\n" " sexp_warn(ctx, \"couldn't import declared type: \", name);\n"
" name = sexp_intern(ctx, \"" pred "\", " " }\n"))
(string-length (x->string pred)) ");\n" (else
" sexp_env_define(ctx, env, name, tmp);\n"))))))) (cat " name = sexp_c_string(ctx, \"" (type-name name) "\", -1);\n"
" " (type-id-name name)
" = sexp_register_c_type(ctx, name, "
(cond ((memq 'finalizer: type)
=> (lambda (x)
(let ((name (cadr x)))
(generate-stub-name
(if (pair? name) (car name) name)))))
(else "sexp_finalize_c_type"))
");\n"
" tmp = sexp_string_to_symbol(ctx, name);\n"
" sexp_env_define(ctx, env, tmp, " (type-id-name name) ");\n")
(cond
((memq 'predicate: type)
=> (lambda (x)
(let ((pred (cadr x)))
(cat " tmp = sexp_make_type_predicate(ctx, name, "
(type-id-name name) ");\n"
" name = sexp_intern(ctx, \"" pred "\", "
(string-length (x->string pred)) ");\n"
" sexp_env_define(ctx, env, name, tmp);\n")))))))))
(define (type-getter-name type name field) (define (type-getter-name type name field)
(string-append "sexp_" (x->string (type-name (parse-type name))) (string-append "sexp_" (x->string (type-name (parse-type name)))
@ -1518,128 +1544,135 @@
" return SEXP_VOID;\n" " return SEXP_VOID;\n"
"}\n\n")) "}\n\n"))
(define (write-type-funcs orig-type) (define (write-type-funcs-helper orig-type name type)
(let ((name (car orig-type)) ;; maybe write finalizer
(type (cdr orig-type))) (cond
;; maybe write finalizer ((memq 'finalizer: type)
(cond => (lambda (x)
((memq 'finalizer: type) (let* ((y (cadr x))
=> (lambda (x) (scheme-name (if (pair? y) (car y) y))
(let* ((y (cadr x)) (cname (if (pair? y) (cadr y) y)))
(scheme-name (if (pair? y) (car y) y)) (cat "static sexp " (generate-stub-name scheme-name)
(cname (if (pair? y) (cadr y) y))) " (sexp ctx, sexp self, sexp_sint_t n, sexp x) {\n"
(cat "static sexp " (generate-stub-name scheme-name) " if (sexp_cpointer_freep(x)) {\n"
" (sexp ctx, sexp self, sexp_sint_t n, sexp x) {\n" " " cname "(sexp_cpointer_value(x));\n"
" if (sexp_cpointer_freep(x)) {\n" ;; TODO: keep track of open/close separately from ownership
" " cname "(sexp_cpointer_value(x));\n" " sexp_cpointer_freep(x) = 0;\n"
;; TODO: keep track of open/close separately from ownership " }\n"
" sexp_cpointer_freep(x) = 0;\n" " return SEXP_VOID;\n"
" }\n" "}\n\n")
" return SEXP_VOID;\n" ;; make the finalizer available
"}\n\n") (set! *funcs*
;; make the finalizer available (cons (parse-func `(void ,(cadr x) (,name))) *funcs*))))))
(set! *funcs* ;; maybe write constructor
(cons (parse-func `(void ,(cadr x) (,name))) *funcs*)))))) (cond
;; maybe write constructor ((memq 'constructor: type)
(cond => (lambda (x)
((memq 'constructor: type) (let ((make (car (cadr x)))
=> (lambda (x) (args (cdr (cadr x))))
(let ((make (car (cadr x))) (cat "static sexp " (generate-stub-name make)
(args (cdr (cadr x)))) " (sexp ctx, sexp self, sexp_sint_t n"
(cat "static sexp " (generate-stub-name make) (lambda ()
" (sexp ctx, sexp self, sexp_sint_t n" (let lp ((ls args) (i 0))
(lambda () (cond ((pair? ls)
(let lp ((ls args) (i 0)) (cat ", sexp arg" i)
(cond ((pair? ls) (lp (cdr ls) (+ i 1))))))
(cat ", sexp arg" i) ") {\n"
(lp (cdr ls) (+ i 1)))))) " " (type-c-name name) " r;\n"
") {\n" " sexp_gc_var1(res);\n"
" " (type-c-name name) " r;\n" " sexp_gc_preserve1(ctx, res);\n"
" sexp_gc_var1(res);\n" ;; TODO: support heap-managed allocations
" sexp_gc_preserve1(ctx, res);\n" ;; " res = sexp_alloc_tagged(ctx, sexp_sizeof(cpointer)"
;; TODO: support heap-managed allocations ;; " + sizeof(struct " (type-name name) "), "
;; " res = sexp_alloc_tagged(ctx, sexp_sizeof(cpointer)" ;; (type-id-name name)
;; " + sizeof(struct " (type-name name) "), " ;; ");\n"
;; (type-id-name name) ;; " r = sexp_cpointer_value(res) = "
;; ");\n" ;; "sexp_cpointer_body(res);\n"
;; " r = sexp_cpointer_value(res) = " ;; " res = sexp_alloc_tagged(ctx, sexp_sizeof(cpointer), sexp_type_tag("
;; "sexp_cpointer_body(res);\n" ;; (type-id-name name)
;; " res = sexp_alloc_tagged(ctx, sexp_sizeof(cpointer), sexp_type_tag(" ;; "));\n"
;; (type-id-name name) " res = sexp_alloc_tagged(ctx, sexp_sizeof(cpointer), "
;; "));\n" "sexp_unbox_fixnum(sexp_opcode_return_type(self)));\n"
" res = sexp_alloc_tagged(ctx, sexp_sizeof(cpointer), " " sexp_cpointer_value(res) = calloc(1, sizeof("
"sexp_unbox_fixnum(sexp_opcode_return_type(self)));\n" (type-c-name-derefed name) "));\n"
" sexp_cpointer_value(res) = calloc(1, sizeof(" " r = (" (type-c-name name) ") sexp_cpointer_value(res);\n"
(type-c-name-derefed name) "));\n" " memset(r, 0, sizeof("
" r = (" (type-c-name name) ") sexp_cpointer_value(res);\n" (type-c-name-derefed name) "));\n"
" memset(r, 0, sizeof(" " sexp_freep(res) = 1;\n"
(type-c-name-derefed name) "));\n" (lambda ()
" sexp_freep(res) = 1;\n" (let lp ((ls args) (i 0))
(lambda () (cond
(let lp ((ls args) (i 0)) ((pair? ls)
(cond (let* ((a (car ls))
((pair? ls) (field
(let* ((a (car ls)) (find (lambda (f) (and (pair? f) (eq? a (cadr f))))
(field (cddr x))))
(find (lambda (f) (and (pair? f) (eq? a (cadr f)))) (if field
(cddr x)))) (cat " r->" (cadr field) " = "
(if field (lambda ()
(cat " r->" (cadr field) " = " (scheme->c-converter
(lambda () (car field)
(scheme->c-converter (string-append "arg"
(car field) (number->string i))))
(string-append "arg" ";\n"))
(number->string i)))) (lp (cdr ls) (+ i 1)))))))
";\n")) " sexp_gc_release1(ctx);\n"
(lp (cdr ls) (+ i 1))))))) " return res;\n"
" sexp_gc_release1(ctx);\n" "}\n\n")
" return res;\n" (set! *funcs*
"}\n\n") (cons (parse-func
(set! *funcs* `(,name ,make
(cons (parse-func ,(map (lambda (a)
`(,name ,make (cond
,(map (lambda (a) ((find (lambda (x) (eq? a (cadr x)))
(cond (struct-fields type))
((find (lambda (x) (eq? a (cadr x))) => car)
(struct-fields type)) (else 'sexp)))
=> car) args)))
(else 'sexp))) *funcs*))))))
args))) ;; write field accessors
*funcs*)))))) (for-each
;; write field accessors (lambda (field)
(for-each (cond
(lambda (field) ((and (pair? field) (pair? (cdr field)))
(cond (cond
((and (pair? field) (pair? (cdr field))) ((and (pair? (cddr field)) (car (cddr field)))
(cond (write-type-getter type name field)
((and (pair? (cddr field)) (car (cddr field))) (set! *funcs*
(write-type-getter type name field) (cons (parse-func
(set! *funcs* `(,(car field)
(cons (parse-func (,(car (cddr field))
`(,(car field) #f
(,(car (cddr field)) ,(type-getter-name type name field))
#f (,name)))
,(type-getter-name type name field)) *funcs*))))
(,name))) (cond
*funcs*)))) ((and (pair? (cddr field))
(cond (pair? (cdr (cddr field)))
((and (pair? (cddr field)) (cadr (cddr field)))
(pair? (cdr (cddr field))) (write-type-setter type name field)
(cadr (cddr field))) (set! *funcs*
(write-type-setter type name field) (cons (parse-func
(set! *funcs* `(,(car field)
(cons (parse-func (,(cadr (cddr field))
`(,(car field) #f
(,(cadr (cddr field)) ,(type-setter-name type name field))
#f (,name ,(car field))))
,(type-setter-name type name field)) *funcs*)))))))
(,name ,(car field)))) (struct-fields type)))
*funcs*)))))))
(struct-fields type)))) (define (write-type-funcs orig-type)
(let* ((name (car orig-type))
(type (cdr orig-type))
(imported? (cond ((member 'imported?: type) => cadr) (else #f))))
(if (not imported?)
(write-type-funcs-helper orig-type name type))))
(define (write-const const) (define (write-const const)
(let ((scheme-name (if (pair? (cadr const)) (car (cadr const)) (cadr const))) (let ((scheme-name
(c-name (if (pair? (cadr const)) (cadr (cadr const)) (mangle (cadr const))))) (if (pair? (cadr const)) (car (cadr const)) (cadr const)))
(c-name
(if (pair? (cadr const)) (cadr (cadr const)) (mangle (cadr const)))))
(cat " name = sexp_intern(ctx, \"" scheme-name "\", " (cat " name = sexp_intern(ctx, \"" scheme-name "\", "
(string-length (x->string scheme-name)) ");\n" (string-length (x->string scheme-name)) ");\n"
" sexp_env_define(ctx, env, name, tmp=" " sexp_env_define(ctx, env, name, tmp="