Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-06-24 23:06:42 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

Binding C types, and adding declare-c-struct/class/union to access them from imported libraries.

Browse source
This commit is contained in:
Alex Shinn 2013-05-30 08:08:42 +09:00
parent 6659baa6b6
commit aba919f1b4
1 changed files with 173 additions and 140 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

55
tools/chibi-ffi
View file

@ -343,7 +343,7 @@
(string-append "sexp_" (mangle sym) "_stub"))
(define (type-id-name sym)
(string-append "sexp_" (mangle sym) "_type_tag"))
(string-append "sexp_" (mangle sym) "_type_obj"))
(define (make-integer x)
(case x
@ -411,6 +411,21 @@
(lambda (expr rename compare)
`(define-struct-like ,(cadr expr) ,@(cddr expr)))))
(define-syntax declare-c-struct
(er-macro-transformer
(lambda (expr rename compare)
`(define-struct-like ,(cadr expr) type: struct imported?: #t))))
(define-syntax declare-c-class
(er-macro-transformer
(lambda (expr rename compare)
`(define-struct-like ,(cadr expr) type: class imported?: #t))))
(define-syntax declare-c-union
(er-macro-transformer
(lambda (expr rename compare)
`(define-struct-like ,(cadr expr) type: union imported?: #t))))
(define-syntax define-c
(er-macro-transformer
(lambda (expr rename compare)
@ -1431,8 +1446,17 @@
" }\n"))
(define (write-type type)
(let ((name (car type))
(type (cdr type)))
(let* ((name (car type))
(type (cdr type))
(imported? (cond ((member 'imported?: type) => cadr) (else #f))))
(cond
(imported?
(cat " name = sexp_intern(ctx, \"" (type-name name) "\", -1);\n"
" " (type-id-name name) " = sexp_env_ref(env, name, SEXP_FALSE);\n"
" if (sexp_not(" (type-id-name name) ")) {\n"
" sexp_warn(ctx, \"couldn't import declared type: \", name);\n"
" }\n"))
(else
(cat " name = sexp_c_string(ctx, \"" (type-name name) "\", -1);\n"
" " (type-id-name name)
" = sexp_register_c_type(ctx, name, "
@ -1442,7 +1466,9 @@
(generate-stub-name
(if (pair? name) (car name) name)))))
(else "sexp_finalize_c_type"))
");\n")
");\n"
" tmp = sexp_string_to_symbol(ctx, name);\n"
" sexp_env_define(ctx, env, tmp, " (type-id-name name) ");\n")
(cond
((memq 'predicate: type)
=> (lambda (x)
@ -1451,7 +1477,7 @@
(type-id-name name) ");\n"
" name = sexp_intern(ctx, \"" pred "\", "
(string-length (x->string pred)) ");\n"
" sexp_env_define(ctx, env, name, tmp);\n")))))))
" sexp_env_define(ctx, env, name, tmp);\n")))))))))
(define (type-getter-name type name field)
(string-append "sexp_" (x->string (type-name (parse-type name)))
@ -1518,9 +1544,7 @@
" return SEXP_VOID;\n"
"}\n\n"))
(define (write-type-funcs orig-type)
(let ((name (car orig-type))
(type (cdr orig-type)))
(define (write-type-funcs-helper orig-type name type)
;; maybe write finalizer
(cond
((memq 'finalizer: type)
@ -1635,11 +1659,20 @@
,(type-setter-name type name field))
(,name ,(car field))))
*funcs*)))))))
(struct-fields type))))
(struct-fields type)))
(define (write-type-funcs orig-type)
(let* ((name (car orig-type))
(type (cdr orig-type))
(imported? (cond ((member 'imported?: type) => cadr) (else #f))))
(if (not imported?)
(write-type-funcs-helper orig-type name type))))
(define (write-const const)
(let ((scheme-name (if (pair? (cadr const)) (car (cadr const)) (cadr const)))
(c-name (if (pair? (cadr const)) (cadr (cadr const)) (mangle (cadr const)))))
(let ((scheme-name
(if (pair? (cadr const)) (car (cadr const)) (cadr const)))
(c-name
(if (pair? (cadr const)) (cadr (cadr const)) (mangle (cadr const)))))
(cat " name = sexp_intern(ctx, \"" scheme-name "\", "
(string-length (x->string scheme-name)) ");\n"
" sexp_env_define(ctx, env, name, tmp="