fixed a bug in converting out parameters in the ypsilon-compat
layer. Thanks to Ed Cavazos for the patch.
This commit is contained in:
parent
b97cbf1688
commit
230b5186d6
|
@ -198,6 +198,20 @@
|
||||||
(syntax-violation 'c-function "invalid argument type"
|
(syntax-violation 'c-function "invalid argument type"
|
||||||
#'form #'arg-type)])))
|
#'form #'arg-type)])))
|
||||||
|
|
||||||
|
(define (convert-out-byte* who s-val c-val)
|
||||||
|
(let ((n (bytevector-length s-val)))
|
||||||
|
(let loop ([i 0])
|
||||||
|
(unless (= i n)
|
||||||
|
(bytevector-u8-set! s-val i (pointer-ref-c-unsigned-char c-val i))
|
||||||
|
(loop (+ i 1))))))
|
||||||
|
|
||||||
|
(define-syntax convert-out-arg
|
||||||
|
(lambda (x)
|
||||||
|
(syntax-case x (int char* byte* c-callback float double void*)
|
||||||
|
((_ form foreign-name s-val c-val byte*)
|
||||||
|
#'(convert-out-byte* 'foreign-name s-val c-val))
|
||||||
|
((_ form foreign-name s-val c-val arg-ype)
|
||||||
|
#'(void)))))
|
||||||
|
|
||||||
(define (char*->string who x)
|
(define (char*->string who x)
|
||||||
(define (strlen x)
|
(define (strlen x)
|
||||||
|
@ -223,7 +237,6 @@
|
||||||
[(_ form foreign-name val other)
|
[(_ form foreign-name val other)
|
||||||
#'val])))
|
#'val])))
|
||||||
|
|
||||||
|
|
||||||
(define-syntax convert-type
|
(define-syntax convert-type
|
||||||
(lambda (x)
|
(lambda (x)
|
||||||
(define ls
|
(define ls
|
||||||
|
@ -262,21 +275,23 @@
|
||||||
(format "cannot find object ~a in library ~a"
|
(format "cannot find object ~a in library ~a"
|
||||||
name (library-name lib)))))
|
name (library-name lib)))))
|
||||||
|
|
||||||
|
|
||||||
(define-syntax c-function
|
(define-syntax c-function
|
||||||
(lambda (x)
|
(lambda (x)
|
||||||
(syntax-case x ()
|
(syntax-case x ()
|
||||||
[(_ lib lib-name return-type conv foreign-name (arg-type* ...))
|
[(_ lib lib-name return-type conv foreign-name (arg-type* ...))
|
||||||
(with-syntax ([x x]
|
(with-syntax ([x x]
|
||||||
[(t* ...) (generate-temporaries #'(arg-type* ...))])
|
[(t* ...) (generate-temporaries #'(arg-type* ...))]
|
||||||
|
[(u* ...) (generate-temporaries #'(arg-type* ...))])
|
||||||
#'(let ([callout
|
#'(let ([callout
|
||||||
((make-c-callout
|
((make-c-callout
|
||||||
(convert-type return-type)
|
(convert-type return-type)
|
||||||
(list (convert-type arg-type*) ...))
|
(list (convert-type arg-type*) ...))
|
||||||
(lookup-shared-object lib 'foreign-name))])
|
(lookup-shared-object lib 'foreign-name))])
|
||||||
(lambda (t* ...)
|
(lambda (t* ...)
|
||||||
(let ([t* (convert-arg x foreign-name t* arg-type*)] ...)
|
(let ([u* (convert-arg x foreign-name t* arg-type*)] ...)
|
||||||
(let ([v (callout t* ...)])
|
(let ([v (callout u* ...)])
|
||||||
|
(convert-out-arg x foreign-name t* u* arg-type*)
|
||||||
|
...
|
||||||
(convert-return x foreign-name v return-type))))))])))
|
(convert-return x foreign-name v return-type))))))])))
|
||||||
|
|
||||||
(define-syntax c-argument
|
(define-syntax c-argument
|
||||||
|
|
|
@ -1 +1 @@
|
||||||
1748
|
1749
|
||||||
|
|
Loading…
Reference in New Issue