Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-05-18 21:29:19 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

Handling non-pointer struct return types in the ffi. We do a flat memcopy

Browse source 
of the struct to heap.  Only the base case is supported - combining with
multiple values or returning fixed-size arrays of structs won't work.
Fixes issue #270.
This commit is contained in:
Alex Shinn 2015-06-22 23:01:21 +09:00
parent 64f3be9c99
commit 2e4d0aed91
2 changed files with 25 additions and 2 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

10
tests/ffi/ffi-tests.scm
View file

@ -219,6 +219,13 @@ typedef struct {
Color color; Color color;
} ColoredCircle; } ColoredCircle;
struct Point make_point_struct(double x, double y) {
struct Point res;
res.x = x;
res.y = y;
return res;
}
void set_color(short r, short g, short b, Color* res) { void set_color(short r, short g, short b, Color* res) {
res->r = r; res->r = r;
res->g = g; res->g = g;
@ -255,6 +262,7 @@ double circle_area2(struct Circle circ) {
constructor: (make-point x y) constructor: (make-point x y)
(double x point-x point-x-set!) (double x point-x point-x-set!)
(double y point-y point-y-set!)) (double y point-y point-y-set!))
(define-c (struct Point) make-point-struct (double double))
(define-c-struct Rectangle (define-c-struct Rectangle
predicate: rect? predicate: rect?
constructor: (make-rect top_left bottom_right) constructor: (make-rect top_left bottom_right)
@ -279,6 +287,8 @@ double circle_area2(struct Circle circ) {
(test 1. (point-x (make-point 1. 2.))) (test 1. (point-x (make-point 1. 2.)))
(test 2. (point-y (make-point 1. 2.))) (test 2. (point-y (make-point 1. 2.)))
(test 3. (point-x (let ((pt (make-point 1. 2.))) (point-x-set! pt 3.) pt))) (test 3. (point-x (let ((pt (make-point 1. 2.))) (point-x-set! pt 3.) pt)))
(test 1. (point-x (make-point-struct 1. 2.)))
(test 2. (point-y (make-point-struct 1. 2.)))
;; need constructor argument checking ;; need constructor argument checking
;;(test-error (rect? (make-rect 1 2))) ;;(test-error (rect? (make-rect 1 2)))
;; gc miss - we don't preserve the pointers ;; gc miss - we don't preserve the pointers

17
tools/chibi-ffi
View file

@ -988,6 +988,9 @@
((status-bool) (cat " bool err;\n")) ((status-bool) (cat " bool err;\n"))
((non-null-string) (cat " char *err;\n")) ((non-null-string) (cat " char *err;\n"))
((non-null-pointer) (cat " void *err;\n"))) ((non-null-pointer) (cat " void *err;\n")))
(if (type-struct? ret-type)
(cat " struct " (type-base ret-type) " struct_res;\n"
" struct " (type-base ret-type) "* ptr_res;\n"))
(cond (cond
((pair? ints) ((pair? ints)
(cat " int " (car ints)) (cat " int " (car ints))
@ -1181,8 +1184,10 @@
(cat " loop:\n")) (cat " loop:\n"))
(cat (cond ((error-type? (type-base ret-type)) " err = ") (cat (cond ((error-type? (type-base ret-type)) " err = ")
((type-array ret-type) " tmp = ") ((type-array ret-type) " tmp = ")
((type-struct? ret-type) " struct_res = ")
(else " res = "))) (else " res = ")))
((if (type-array ret-type) ((if (or (type-array ret-type)
(type-struct? ret-type))
(lambda (t f x) (f)) (lambda (t f x) (f))
c->scheme-converter) c->scheme-converter)
ret-type ret-type
@ -1227,7 +1232,15 @@
" if (sexp_filenop(" res "))\n" " if (sexp_filenop(" res "))\n"
" fcntl(sexp_fileno_fd(" res "), F_SETFL, O_NONBLOCK " " fcntl(sexp_fileno_fd(" res "), F_SETFL, O_NONBLOCK "
" | fcntl(sexp_fileno_fd(" res "), F_GETFL));\n" " | fcntl(sexp_fileno_fd(" res "), F_GETFL));\n"
"#endif\n"))))) "#endif\n")))
;; non-pointer struct return types need to be copied to the heap
((type-struct? result)
(cat
" ptr_res = (" (type-c-name result) ") malloc(sizeof("
(type-c-name-derefed result) "));\n"
" memcpy(ptr_res, &struct_res, sizeof(" (type-c-name-derefed result) "));\n"
" res = sexp_make_cpointer(ctx, sexp_unbox_fixnum(sexp_opcode_return_type(self)), ptr_res, SEXP_FALSE, 0);\n"))
))
(define (write-result result . o) (define (write-result result . o)
(let ((res (string-append "res" (type-index-string result))) (let ((res (string-append "res" (type-index-string result)))