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)
|
(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)
|
||||||
|
|
|
||||||
211
tools/chibi-ffi
211
tools/chibi-ffi
|
|
@ -1587,67 +1587,107 @@
|
||||||
" 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)
|
||||||
(string-append "sexp_" (x->string (type-name (parse-type name)))
|
(let ((c-name (if (pair? (cadr field)) (cadr (cadr field)) (cadr field))))
|
||||||
"_get_" (x->string (type-base (parse-type (cadr field))))))
|
(string-append "sexp_" (x->string (type-name (parse-type name)))
|
||||||
|
"_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)
|
||||||
(cat "static sexp " (type-getter-name type name field)
|
(let* ((get (car (cddr field)))
|
||||||
" (sexp ctx, sexp self, sexp_sint_t n, sexp x) {\n"
|
(_ (verify-accessor get))
|
||||||
(lambda () (write-validator "x" (parse-type name 0)))
|
(c-name (if (pair? (cadr field)) (cadr (cadr field)) (cadr field)))
|
||||||
" return "
|
(ptr (string-append
|
||||||
(lambda ()
|
"((" (x->string (or (type-struct-type name) ""))
|
||||||
(c->scheme-converter
|
" " (mangle name) "*)"
|
||||||
(car field)
|
"sexp_cpointer_value(x))")))
|
||||||
(string-append (if (type-struct? (car field)) "&" "")
|
(cat "static sexp " (type-getter-name type name field)
|
||||||
"((" (x->string (or (type-struct-type name) ""))
|
" (sexp ctx, sexp self, sexp_sint_t n, sexp x) {\n"
|
||||||
" " (mangle name) "*)"
|
(lambda () (write-validator "x" (parse-type name 0)))
|
||||||
"sexp_cpointer_value(x))" "->"
|
" return "
|
||||||
(x->string (cadr field)))
|
(lambda ()
|
||||||
(and (or (type-struct? (car field)) (type-link? (car field))) "x")))
|
(c->scheme-converter
|
||||||
";\n"
|
(car field)
|
||||||
"}\n\n"))
|
(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")))
|
||||||
|
|
||||||
(define (type-setter-name type name field)
|
(define (type-setter-name type name field)
|
||||||
(string-append "sexp_" (x->string (type-name (parse-type name)))
|
(let ((c-name (if (pair? (cadr field)) (cadr (cadr field)) (cadr field))))
|
||||||
"_set_" (x->string (type-base (parse-type (cadr field))))))
|
(string-append "sexp_" (x->string (type-name (parse-type name)))
|
||||||
|
"_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)
|
||||||
(cond
|
(let* ((set (cadr (cddr field)))
|
||||||
((type-struct? (car field))
|
(_ (verify-accessor set))
|
||||||
;; assign to a nested struct - copy field-by-field
|
(c-name (if (pair? (cadr field)) (cadr (cadr field)) (cadr field)))
|
||||||
(let ((field-type
|
(ptr (string-append
|
||||||
(cond ((lookup-type (type-name (car field)))
|
"((" (x->string (or (type-struct-type name) ""))
|
||||||
=> (lambda (x) (cddr (cdr x))))
|
" " (mangle name) "*)"
|
||||||
(else (cdr field)))))
|
"sexp_cpointer_value(" (x->string dst) "))")))
|
||||||
|
(cond
|
||||||
|
((and (pair? set) (eq? 'function: (cadr set)))
|
||||||
(lambda ()
|
(lambda ()
|
||||||
(for-each
|
(cat (car (cddr set)) "(" ptr ", "
|
||||||
(lambda (subfield)
|
(lambda () (scheme->c-converter (car field) val)) ");\n")))
|
||||||
(let ((subname (x->string (cadr subfield))))
|
((and (pair? set) (eq? 'method: (cadr set)))
|
||||||
(cat
|
(lambda ()
|
||||||
" "
|
(cat ptr "->" (car (cddr set)) "("
|
||||||
(string-append dst "." (x->string (cadr subfield)))
|
(lambda () (scheme->c-converter (car field) val)) ");\n")))
|
||||||
" = "
|
((pair? set)
|
||||||
(string-append
|
(error "invalid setter" set))
|
||||||
"((" (x->string (or (type-struct-type (type-name (car field))) ""))
|
((type-struct? (car field))
|
||||||
" " (mangle (type-name (car field))) "*)" "sexp_cpointer_value(" val "))"
|
;; assign to a nested struct - copy field-by-field
|
||||||
"->" (x->string (cadr subfield)))
|
(let ((field-type
|
||||||
";\n")))
|
(cond ((lookup-type (type-name (car field)))
|
||||||
(struct-fields field-type)))))
|
=> (lambda (x) (cddr (cdr x))))
|
||||||
(else
|
(else (cdr field)))))
|
||||||
(lambda ()
|
(lambda ()
|
||||||
(cat " " dst " = " (lambda () (scheme->c-converter (car field) val)) ";\n")))))
|
(for-each
|
||||||
|
(lambda (subfield)
|
||||||
|
(let ((subname (x->string (cadr subfield))))
|
||||||
|
(cat
|
||||||
|
" "
|
||||||
|
(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 (cadr subfield)))
|
||||||
|
";\n")))
|
||||||
|
(struct-fields field-type)))))
|
||||||
|
(else
|
||||||
|
(lambda ()
|
||||||
|
(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))))
|
||||||
(cat " r->" (cadr field) " = "
|
(cond
|
||||||
(lambda ()
|
((and field (>= (length field) 4))
|
||||||
(scheme->c-converter
|
(cat
|
||||||
(car field)
|
(write-type-setter-assignment
|
||||||
(string-append "arg"
|
type name field "res" arg)))
|
||||||
(number->string i))))
|
(field
|
||||||
";\n"))
|
(cat " r->" (cadr field) " = "
|
||||||
|
(lambda ()
|
||||||
|
(scheme->c-converter (car field) arg))
|
||||||
|
";\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))
|
||||||
(write-type-getter type name field)
|
(let ((get-name (if (pair? (car get+set))
|
||||||
(set! *funcs*
|
(caar get+set)
|
||||||
(cons (parse-func
|
(car get+set))))
|
||||||
`(,(car field)
|
(write-type-getter type name field)
|
||||||
(,(car get+set)
|
(set! *funcs*
|
||||||
#f
|
(cons (parse-func
|
||||||
,(type-getter-name type name field))
|
`(,(car field)
|
||||||
(,name)))
|
(,get-name
|
||||||
*funcs*))
|
#f
|
||||||
(if (type-struct-type name)
|
,(type-getter-name type name field))
|
||||||
(set! *type-getters*
|
(,name)))
|
||||||
(cons `(,(car get+set) ,name ,i) *type-getters*))))
|
*funcs*))
|
||||||
|
(if (type-struct-type name)
|
||||||
|
(set! *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))
|
||||||
(write-type-setter type name field)
|
(let ((set-name (if (pair? (cadr get+set))
|
||||||
(set! *funcs*
|
(car (cadr get+set))
|
||||||
(cons (parse-func
|
(cadr get+set))))
|
||||||
`(,(car field)
|
(write-type-setter type name field)
|
||||||
(,(cadr get+set)
|
(set! *funcs*
|
||||||
#f
|
(cons (parse-func
|
||||||
,(type-setter-name type name field))
|
`(,(car field)
|
||||||
(,name ,(car field))))
|
(,set-name
|
||||||
*funcs*))
|
#f
|
||||||
(if (type-struct-type name)
|
,(type-setter-name type name field))
|
||||||
(set! *type-setters*
|
(,name ,(car field))))
|
||||||
(cons `(,(cadr get+set) ,name ,i) *type-setters*))))))
|
*funcs*))
|
||||||
|
(if (type-struct-type name)
|
||||||
|
(set! *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)
|
||||||
|
|
|
||||||
Loading…
Add table
Reference in a new issue