mirror of
https://github.com/ashinn/chibi-scheme.git
synced 2025-05-19 05:39:18 +02:00
Adding virtual FFI accessors.
This commit is contained in:
Alex Shinn
parent
776182481a
commit
b78187c89b
2 changed files with 189 additions and 81 deletions
|
|
@ -405,6 +405,65 @@ struct point3d {
|
|||
(test '(12 11 10)
|
||||
(match (make-point3d 10 11 12)
|
||||
((@ 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)
|
||||
|
|
|
|||
107
tools/chibi-ffi
107
tools/chibi-ffi
|
|
@ -1587,10 +1587,27 @@
|
|||
" sexp_env_define(ctx, env, name, tmp);\n")))))))))
|
||||
|
||||
(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)))
|
||||
"_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)
|
||||
(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)
|
||||
" (sexp ctx, sexp self, sexp_sint_t n, sexp x) {\n"
|
||||
(lambda () (write-validator "x" (parse-type name 0)))
|
||||
|
|
@ -1598,21 +1615,46 @@
|
|||
(lambda ()
|
||||
(c->scheme-converter
|
||||
(car field)
|
||||
(string-append (if (type-struct? (car field)) "&" "")
|
||||
"((" (x->string (or (type-struct-type name) ""))
|
||||
" " (mangle name) "*)"
|
||||
"sexp_cpointer_value(x))" "->"
|
||||
(x->string (cadr field)))
|
||||
(and (or (type-struct? (car field)) (type-link? (car field))) "x")))
|
||||
(cond
|
||||
((and (pair? get) (eq? 'function: (cadr get)))
|
||||
(string-append (car (cddr get)) "(" ptr ")"))
|
||||
((and (pair? get) (eq? 'method: (cadr get)))
|
||||
(string-append ptr "->" (car (cddr get)) "()"))
|
||||
((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")))
|
||||
|
||||
(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)))
|
||||
"_set_" (x->string (type-base (parse-type (cadr field))))))
|
||||
"_set_" (x->string c-name))))
|
||||
|
||||
(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
|
||||
((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))
|
||||
;; assign to a nested struct - copy field-by-field
|
||||
(let ((field-type
|
||||
|
|
@ -1628,26 +1670,24 @@
|
|||
(string-append dst "." (x->string (cadr subfield)))
|
||||
" = "
|
||||
(string-append
|
||||
"((" (x->string (or (type-struct-type (type-name (car field))) ""))
|
||||
" " (mangle (type-name (car field))) "*)" "sexp_cpointer_value(" val "))"
|
||||
"((" (x->string (or (type-struct-type (type-name (car field)))
|
||||
""))
|
||||
" " (mangle (type-name (car field))) "*)"
|
||||
"sexp_cpointer_value(" val "))"
|
||||
"->" (x->string (cadr subfield)))
|
||||
";\n")))
|
||||
(struct-fields field-type)))))
|
||||
(else
|
||||
(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)
|
||||
(cat "static sexp " (type-setter-name type name field)
|
||||
" (sexp ctx, sexp self, sexp_sint_t n, sexp x, sexp v) {\n"
|
||||
(lambda () (write-validator "x" (parse-type name 0)))
|
||||
(lambda () (write-validator "v" (parse-type (car field) 1)))
|
||||
(write-type-setter-assignment
|
||||
type name field
|
||||
(string-append "((" (x->string (or (type-struct-type name) ""))
|
||||
" " (mangle name) "*)" "sexp_cpointer_value(x))"
|
||||
"->" (x->string (cadr field)))
|
||||
"v")
|
||||
(write-type-setter-assignment type name field "x" "v")
|
||||
" return SEXP_VOID;\n"
|
||||
"}\n\n"))
|
||||
|
||||
|
|
@ -1718,15 +1758,18 @@
|
|||
(let* ((a (car ls))
|
||||
(field
|
||||
(find (lambda (f) (and (pair? f) (eq? a (cadr f))))
|
||||
(cddr x))))
|
||||
(if field
|
||||
(cddr x)))
|
||||
(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) " = "
|
||||
(lambda ()
|
||||
(scheme->c-converter
|
||||
(car field)
|
||||
(string-append "arg"
|
||||
(number->string i))))
|
||||
";\n"))
|
||||
(scheme->c-converter (car field) arg))
|
||||
";\n")))
|
||||
(lp (cdr ls) (+ i 1)))))))
|
||||
" sexp_gc_release1(ctx);\n"
|
||||
" return res;\n"
|
||||
|
|
@ -1752,35 +1795,41 @@
|
|||
(get+set (cddr field)))
|
||||
(cond
|
||||
((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)
|
||||
(set! *funcs*
|
||||
(cons (parse-func
|
||||
`(,(car field)
|
||||
(,(car get+set)
|
||||
(,get-name
|
||||
#f
|
||||
,(type-getter-name type name field))
|
||||
(,name)))
|
||||
*funcs*))
|
||||
(if (type-struct-type name)
|
||||
(set! *type-getters*
|
||||
(cons `(,(car get+set) ,name ,i) *type-getters*))))
|
||||
(cons `(,get-name ,name ,i) *type-getters*)))))
|
||||
(else "SEXP_FALSE"))
|
||||
(cond
|
||||
((and (pair? get+set)
|
||||
(pair? (cdr 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)
|
||||
(set! *funcs*
|
||||
(cons (parse-func
|
||||
`(,(car field)
|
||||
(,(cadr get+set)
|
||||
(,set-name
|
||||
#f
|
||||
,(type-setter-name type name field))
|
||||
(,name ,(car field))))
|
||||
*funcs*))
|
||||
(if (type-struct-type name)
|
||||
(set! *type-setters*
|
||||
(cons `(,(cadr get+set) ,name ,i) *type-setters*))))))
|
||||
(cons `(,set-name ,name ,i) *type-setters*)))))))
|
||||
(lp (cdr ls) (+ i 1))))))
|
||||
|
||||
(define (write-type-funcs orig-type)
|
||||
|
|
|
|||
Loading…
Add table
Reference in a new issue