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

Adding virtual FFI accessors.

Browse source
This commit is contained in:
Alex Shinn 2014-12-25 13:14:09 +09:00
parent 776182481a
commit b78187c89b
2 changed files with 189 additions and 81 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

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

@ -405,6 +405,65 @@ struct point3d {
(test '(12 11 10) (test '(12 11 10)
(match (make-point3d 10 11 12) (match (make-point3d 10 11 12)
((@ point3d (z a) (y b) (x c)) (list a b c)))) ((@ point3d (z a) (y b) (x c)) (list a b c))))
(test '(13 14 15 42)
(let ((pt (make-point3d 13 14 15)))
(match pt
((@ point3d (y b) (z (and (set! set-z!) orig-z)) (x c))
(set-z! 42)
(list c b orig-z (point3d-z pt))))))
) )
(test-ffi
"virtual accessors"
(begin
(c-declare "
struct VirtComplex {
double r, phi;
};
double complex_real(struct VirtComplex* c) {
return c->r * cos(c->phi);
}
double complex_imag(struct VirtComplex* c) {
return c->r * sin(c->phi);
}
void complex_set(struct VirtComplex* c, double x, double y) {
c->r = sqrt(x*x + y*y);
c->phi = atan2(y, x);
}
void complex_real_set(struct VirtComplex* c, double x) {
complex_set(c, x, complex_imag(c));
}
void complex_imag_set(struct VirtComplex* c, double y) {
complex_set(c, complex_real(c), y);
}
")
(define-c-struct VirtComplex
predicate: virt-complex?
constructor: (make-virt-complex real imag)
(double real
(virt-complex-real function: "complex_real")
(virt-complex-real-set! function: "complex_real_set"))
(double imag
(virt-complex-imag function: "complex_imag")
(virt-complex-imag-set! function: "complex_imag_set"))
))
(test-assert (virt-complex? (make-virt-complex 1.0 2.0)))
(test 1.0 (virt-complex-real (make-virt-complex 1.0 2.0)))
(test 2.0 (virt-complex-imag (make-virt-complex 1.0 2.0)))
(let ((c (make-virt-complex 1.0 2.0)))
(test 1.0 (virt-complex-real c))
(virt-complex-real-set! c 3.0)
(test 3.0 (virt-complex-real c))
(test 2.0 (virt-complex-imag c)))
(test '(5 6 7)
(let ((c (make-virt-complex 5.0 6.0)))
(match c
((@ VirtComplex (real r) (imag (and (set! set-imag!) orig-i)))
(set-imag! 7.0)
(map inexact->exact
(map round (list r orig-i (virt-complex-imag c))))))))
)
;; TODO: virtual method accessors
(test-end) (test-end)

107
tools/chibi-ffi
View file

@ -1587,10 +1587,27 @@
" sexp_env_define(ctx, env, name, tmp);\n"))))))))) " sexp_env_define(ctx, env, name, tmp);\n")))))))))
(define (type-getter-name type name field) (define (type-getter-name type name field)
(let ((c-name (if (pair? (cadr field)) (cadr (cadr field)) (cadr field))))
(string-append "sexp_" (x->string (type-name (parse-type name))) (string-append "sexp_" (x->string (type-name (parse-type name)))
"_get_" (x->string (type-base (parse-type (cadr field)))))) "_get_" (x->string c-name)))
;; (string-append "sexp_" (x->string (type-name (parse-type name)))
;; "_get_" (x->string (type-base (parse-type (cadr field)))))
)
(define (verify-accessor field)
(if (and (pair? field)
(not (and (= 3 (length field))
(memq (cadr field) '(function: method:)))))
(error "accessor should be a single symbol or (scheme-name function:|method: c-name) but got" field)))
(define (write-type-getter type name field) (define (write-type-getter type name field)
(let* ((get (car (cddr field)))
(_ (verify-accessor get))
(c-name (if (pair? (cadr field)) (cadr (cadr field)) (cadr field)))
(ptr (string-append
"((" (x->string (or (type-struct-type name) ""))
" " (mangle name) "*)"
"sexp_cpointer_value(x))")))
(cat "static sexp " (type-getter-name type name field) (cat "static sexp " (type-getter-name type name field)
" (sexp ctx, sexp self, sexp_sint_t n, sexp x) {\n" " (sexp ctx, sexp self, sexp_sint_t n, sexp x) {\n"
(lambda () (write-validator "x" (parse-type name 0))) (lambda () (write-validator "x" (parse-type name 0)))
@ -1598,21 +1615,46 @@
(lambda () (lambda ()
(c->scheme-converter (c->scheme-converter
(car field) (car field)
(string-append (if (type-struct? (car field)) "&" "") (cond
"((" (x->string (or (type-struct-type name) "")) ((and (pair? get) (eq? 'function: (cadr get)))
" " (mangle name) "*)" (string-append (car (cddr get)) "(" ptr ")"))
"sexp_cpointer_value(x))" "->" ((and (pair? get) (eq? 'method: (cadr get)))
(x->string (cadr field))) (string-append ptr "->" (car (cddr get)) "()"))
(and (or (type-struct? (car field)) (type-link? (car field))) "x"))) ((pair? get)
(error "invalid getter" get))
(else
(string-append
(if (type-struct? (car field)) "&" "")
ptr "->" (x->string c-name))))
(and (or (type-struct? (car field)) (type-link? (car field)))
"x")))
";\n" ";\n"
"}\n\n")) "}\n\n")))
(define (type-setter-name type name field) (define (type-setter-name type name field)
(let ((c-name (if (pair? (cadr field)) (cadr (cadr field)) (cadr field))))
(string-append "sexp_" (x->string (type-name (parse-type name))) (string-append "sexp_" (x->string (type-name (parse-type name)))
"_set_" (x->string (type-base (parse-type (cadr field)))))) "_set_" (x->string c-name))))
(define (write-type-setter-assignment type name field dst val) (define (write-type-setter-assignment type name field dst val)
(let* ((set (cadr (cddr field)))
(_ (verify-accessor set))
(c-name (if (pair? (cadr field)) (cadr (cadr field)) (cadr field)))
(ptr (string-append
"((" (x->string (or (type-struct-type name) ""))
" " (mangle name) "*)"
"sexp_cpointer_value(" (x->string dst) "))")))
(cond (cond
((and (pair? set) (eq? 'function: (cadr set)))
(lambda ()
(cat (car (cddr set)) "(" ptr ", "
(lambda () (scheme->c-converter (car field) val)) ");\n")))
((and (pair? set) (eq? 'method: (cadr set)))
(lambda ()
(cat ptr "->" (car (cddr set)) "("
(lambda () (scheme->c-converter (car field) val)) ");\n")))
((pair? set)
(error "invalid setter" set))
((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
@ -1628,26 +1670,24 @@
(string-append dst "." (x->string (cadr subfield))) (string-append dst "." (x->string (cadr subfield)))
" = " " = "
(string-append (string-append
"((" (x->string (or (type-struct-type (type-name (car field))) "")) "((" (x->string (or (type-struct-type (type-name (car field)))
" " (mangle (type-name (car field))) "*)" "sexp_cpointer_value(" val "))" ""))
" " (mangle (type-name (car field))) "*)"
"sexp_cpointer_value(" val "))"
"->" (x->string (cadr subfield))) "->" (x->string (cadr subfield)))
";\n"))) ";\n")))
(struct-fields field-type))))) (struct-fields field-type)))))
(else (else
(lambda () (lambda ()
(cat " " dst " = " (lambda () (scheme->c-converter (car field) val)) ";\n"))))) (cat " " ptr "->" c-name " = "
(lambda () (scheme->c-converter (car field) val)) ";\n"))))))
(define (write-type-setter type name field) (define (write-type-setter type name field)
(cat "static sexp " (type-setter-name type name field) (cat "static sexp " (type-setter-name type name field)
" (sexp ctx, sexp self, sexp_sint_t n, sexp x, sexp v) {\n" " (sexp ctx, sexp self, sexp_sint_t n, sexp x, sexp v) {\n"
(lambda () (write-validator "x" (parse-type name 0))) (lambda () (write-validator "x" (parse-type name 0)))
(lambda () (write-validator "v" (parse-type (car field) 1))) (lambda () (write-validator "v" (parse-type (car field) 1)))
(write-type-setter-assignment (write-type-setter-assignment type name field "x" "v")
type name field
(string-append "((" (x->string (or (type-struct-type name) ""))
" " (mangle name) "*)" "sexp_cpointer_value(x))"
"->" (x->string (cadr field)))
"v")
" return SEXP_VOID;\n" " return SEXP_VOID;\n"
"}\n\n")) "}\n\n"))
@ -1718,15 +1758,18 @@
(let* ((a (car ls)) (let* ((a (car ls))
(field (field
(find (lambda (f) (and (pair? f) (eq? a (cadr f)))) (find (lambda (f) (and (pair? f) (eq? a (cadr f))))
(cddr x)))) (cddr x)))
(if field (arg (string-append "arg" (number->string i))))
(cond
((and field (>= (length field) 4))
(cat
(write-type-setter-assignment
type name field "res" arg)))
(field
(cat " r->" (cadr field) " = " (cat " r->" (cadr field) " = "
(lambda () (lambda ()
(scheme->c-converter (scheme->c-converter (car field) arg))
(car field) ";\n")))
(string-append "arg"
(number->string i))))
";\n"))
(lp (cdr ls) (+ i 1))))))) (lp (cdr ls) (+ i 1)))))))
" sexp_gc_release1(ctx);\n" " sexp_gc_release1(ctx);\n"
" return res;\n" " return res;\n"
@ -1752,35 +1795,41 @@
(get+set (cddr field))) (get+set (cddr field)))
(cond (cond
((and (pair? get+set) (car get+set)) ((and (pair? get+set) (car get+set))
(let ((get-name (if (pair? (car get+set))
(caar get+set)
(car get+set))))
(write-type-getter type name field) (write-type-getter type name field)
(set! *funcs* (set! *funcs*
(cons (parse-func (cons (parse-func
`(,(car field) `(,(car field)
(,(car get+set) (,get-name
#f #f
,(type-getter-name type name field)) ,(type-getter-name type name field))
(,name))) (,name)))
*funcs*)) *funcs*))
(if (type-struct-type name) (if (type-struct-type name)
(set! *type-getters* (set! *type-getters*
(cons `(,(car get+set) ,name ,i) *type-getters*)))) (cons `(,get-name ,name ,i) *type-getters*)))))
(else "SEXP_FALSE")) (else "SEXP_FALSE"))
(cond (cond
((and (pair? get+set) ((and (pair? get+set)
(pair? (cdr get+set)) (pair? (cdr get+set))
(cadr get+set)) (cadr get+set))
(let ((set-name (if (pair? (cadr get+set))
(car (cadr get+set))
(cadr get+set))))
(write-type-setter type name field) (write-type-setter type name field)
(set! *funcs* (set! *funcs*
(cons (parse-func (cons (parse-func
`(,(car field) `(,(car field)
(,(cadr get+set) (,set-name
#f #f
,(type-setter-name type name field)) ,(type-setter-name type name field))
(,name ,(car field)))) (,name ,(car field))))
*funcs*)) *funcs*))
(if (type-struct-type name) (if (type-struct-type name)
(set! *type-setters* (set! *type-setters*
(cons `(,(cadr get+set) ,name ,i) *type-setters*)))))) (cons `(,set-name ,name ,i) *type-setters*)))))))
(lp (cdr ls) (+ i 1)))))) (lp (cdr ls) (+ i 1))))))
(define (write-type-funcs orig-type) (define (write-type-funcs orig-type)