Yet another import of ffi-tools
This commit is contained in:
eknauel
parent
aa3101b7b4
commit
99e0cd7d7d
|
|
@ -0,0 +1,31 @@
|
|||
(define-interface ffi-import-constants-interface
|
||||
(export
|
||||
make-constant
|
||||
constant?
|
||||
constant-type-int?
|
||||
constant-type-char?
|
||||
constant-type-string?
|
||||
constant-c-name
|
||||
constant-scheme-name
|
||||
constant-c-value-name
|
||||
constant-type
|
||||
|
||||
make-integer-constant
|
||||
make-string-constant
|
||||
|
||||
make-constant-from-c-name
|
||||
make-constant-from-c-name-integer
|
||||
|
||||
generate-c-declarations
|
||||
generate-c-enter-values-function
|
||||
generate-c-gc-protect-globals-function
|
||||
|
||||
generate-binding
|
||||
generate-finite-type-definition
|
||||
make-drop-common-prefix-name-converter))
|
||||
|
||||
(define-structure ffi-import-constants ffi-import-constants-interface
|
||||
(open
|
||||
scheme signals
|
||||
srfi-1 srfi-9 srfi-13 srfi-28)
|
||||
(files ffi-tools))
|
||||
|
|
@ -0,0 +1,34 @@
|
|||
(define-interface ffi-tools-rts-interface
|
||||
(export
|
||||
(lookup-shared-value :syntax)
|
||||
make-finite-type-import-function))
|
||||
|
||||
(define-structure ffi-tools-rts ffi-tools-rts-interface
|
||||
(open scheme srfi-23 external-calls)
|
||||
(begin
|
||||
|
||||
(define-syntax lookup-shared-value
|
||||
(syntax-rules ()
|
||||
((lookup-shared-value %s)
|
||||
(shared-binding-ref
|
||||
(lookup-imported-binding %s)))))
|
||||
|
||||
(define (make-finite-type-alist elements id-proc)
|
||||
(map
|
||||
(lambda (e) (cons (id-proc e) e))
|
||||
(vector->list elements)))
|
||||
|
||||
(define (make-finite-type-import-function finite-type-name elements id-proc)
|
||||
(let ((alist (make-finite-type-alist elements id-proc)))
|
||||
(lambda (id)
|
||||
(cond
|
||||
((assoc id alist) => cdr)
|
||||
(else
|
||||
(error "Could not map value to finite type "
|
||||
finite-type-name id))))))
|
||||
|
||||
))
|
||||
|
||||
|
||||
|
||||
|
||||
|
|
@ -0,0 +1,96 @@
|
|||
#include "ffi-tools.h"
|
||||
|
||||
/* convert null-terminated array of strings to a list of Scheme strings */
|
||||
s48_value ffit_enter_string_array(char **array)
|
||||
{
|
||||
int i;
|
||||
s48_value res = S48_NULL;
|
||||
S48_DECLARE_GC_PROTECT(1);
|
||||
|
||||
S48_GC_PROTECT_1(res);
|
||||
for (i = 0; array[i] != NULL; i++)
|
||||
res = s48_cons(s48_enter_string(array[i]), res);
|
||||
S48_GC_UNPROTECT();
|
||||
return res;
|
||||
}
|
||||
|
||||
int length_scheme_list(s48_value list)
|
||||
{
|
||||
s48_value res;
|
||||
S48_DECLARE_GC_PROTECT(2);
|
||||
|
||||
S48_GC_PROTECT_2(list, res);
|
||||
FFIT_CHECK_LIST(list);
|
||||
res = s48_call_scheme(scheme_list_length_function, 1, list);
|
||||
S48_GC_UNPROTECT();
|
||||
return s48_extract_integer(res);
|
||||
}
|
||||
|
||||
int call_scheme_boolean_p(s48_value v)
|
||||
{
|
||||
s48_value res;
|
||||
S48_DECLARE_GC_PROTECT(2);
|
||||
|
||||
S48_GC_PROTECT_2(v, res);
|
||||
res = s48_call_scheme(scheme_boolean_p_function, 1, v);
|
||||
S48_GC_UNPROTECT();
|
||||
return S48_TRUE_P(res);
|
||||
}
|
||||
|
||||
int call_scheme_integer_p(s48_value v)
|
||||
{
|
||||
s48_value res;
|
||||
S48_DECLARE_GC_PROTECT(2);
|
||||
|
||||
S48_GC_PROTECT_2(v, res);
|
||||
res = s48_call_scheme(scheme_integer_p_function, 1, v);
|
||||
S48_GC_UNPROTECT();
|
||||
return S48_TRUE_P(res);
|
||||
}
|
||||
|
||||
/* convert a Scheme list of strings into an null-terminated array of strings */
|
||||
char** ffit_extract_list_of_strings(s48_value list)
|
||||
{
|
||||
char **a;
|
||||
int l, i;
|
||||
s48_value res, e;
|
||||
S48_DECLARE_GC_PROTECT(3);
|
||||
|
||||
S48_GC_PROTECT_3(list, res, e);
|
||||
l = length_scheme_list(list);
|
||||
|
||||
if ((*a = (char *) calloc(l + 1, sizeof(char *))) == NULL)
|
||||
s48_raise_out_of_memory_error();
|
||||
a[l] = NULL;
|
||||
|
||||
e = list;
|
||||
i = 0;
|
||||
while (e != S48_NULL) {
|
||||
if (S48_PAIR_P(e))
|
||||
if (S48_STRING_P(e)) {
|
||||
a[i] = s48_extract_string(e);
|
||||
e = S48_CDR(e);
|
||||
i++;
|
||||
}
|
||||
else {
|
||||
free(a);
|
||||
s48_raise_argument_type_error(e);
|
||||
}
|
||||
else {
|
||||
free(a);
|
||||
s48_raise_argument_type_error(e);
|
||||
}
|
||||
}
|
||||
return a;
|
||||
}
|
||||
|
||||
void ffit_init_hook(void)
|
||||
{
|
||||
S48_GC_PROTECT_GLOBAL(scheme_list_length_function);
|
||||
S48_GC_PROTECT_GLOBAL(scheme_integer_p_function);
|
||||
S48_GC_PROTECT_GLOBAL(scheme_boolean_p_function);
|
||||
|
||||
scheme_list_length_function = s48_get_imported_binding("length");
|
||||
scheme_integer_p_function = s48_get_imported_binding("integer?");
|
||||
scheme_boolean_p_function = s48_get_imported_binding("boolean?");
|
||||
}
|
||||
|
|
@ -0,0 +1,76 @@
|
|||
#include <unistd.h>
|
||||
#include "scheme48.h"
|
||||
|
||||
/* kludges */
|
||||
#define FIXED_S48_RECORD_TYPE(x) (s48_stob_ref((x), S48_STOBTYPE_RECORD, 0))
|
||||
|
||||
/* variables */
|
||||
static s48_value scheme_list_length_function = S48_FALSE;
|
||||
static s48_value scheme_boolean_p_function = S48_FALSE;
|
||||
static s48_value scheme_integer_p_function = S48_FALSE;
|
||||
|
||||
/* prototypes */
|
||||
s48_value ffit_enter_string_array(char**);
|
||||
int length_scheme_list(s48_value);
|
||||
int call_scheme_boolean_p(s48_value);
|
||||
int call_scheme_integer_p(s48_value);
|
||||
char** ffit_extract_list_of_strings(s48_value);
|
||||
void ffit_init_hook(void);
|
||||
|
||||
/* macros */
|
||||
#define FFIT_MAKE_ENTER_RECORD(FUNNAME, SCM_RECTYPE, C_RECTYPE) \
|
||||
s48_value FUNNAME(C_RECTYPE c_rec) { \
|
||||
s48_value scm_rec = S48_FALSE; \
|
||||
S48_DECLARE_GC_PROTECT(1); \
|
||||
\
|
||||
S48_GC_PROTECT_1(scm_rec); \
|
||||
scm_rec = s48_make_record(SCM_RECTYPE); \
|
||||
S48_RECORD_SET(scm_rec, 0, s48_enter_integer((long) c_rec)); \
|
||||
S48_GC_UNPROTECT(); \
|
||||
return scm_rec; \
|
||||
}
|
||||
|
||||
#define FFIT_MAKE_ENTER_RECORD_PROTOTYPE(FUNNAME, C_RECTYPE) \
|
||||
s48_value FUNNAME(C_RECTYPE c_rec);
|
||||
|
||||
#define FFIT_RECORD_TYPE_INIT(C_RECTYPE, SCM_NAME) \
|
||||
S48_GC_PROTECT_GLOBAL(C_RECTYPE); \
|
||||
C_RECTYPE = s48_get_imported_binding("SCM_NAME");
|
||||
|
||||
#define FFIT_CHECK_RECORD_TYPE(SCM_VAL, SCM_RECTYPE) \
|
||||
if (!(S48_RECORD_P(SCM_VAL) && \
|
||||
(FIXED_S48_RECORD_TYPE(SCM_VAL) == SCM_RECTYPE))) \
|
||||
s48_raise_argument_type_error(SCM_VAL)
|
||||
|
||||
#define FFIT_STRUCT_GET(FUNNAME, SCM_RECTYPE, C_RECTYPE, C_FIELD, FIELD_SCM_ENTER_FUN) \
|
||||
s48_value FUNNAME(s48_value scm_rec) { \
|
||||
s48_value res = S48_FALSE; \
|
||||
C_RECTYPE c_rec; \
|
||||
S48_DECLARE_GC_PROTECT(2); \
|
||||
\
|
||||
S48_GC_PROTECT_2(res, scm_rec); \
|
||||
FFIT_CHECK_RECORD_TYPE(scm_rec, SCM_RECTYPE); \
|
||||
c_rec = (C_RECTYPE) s48_extract_integer(S48_RECORD_REF(scm_rec, 0)); \
|
||||
res = FIELD_SCM_ENTER_FUN(c_rec->C_FIELD); \
|
||||
S48_GC_UNPROTECT(); \
|
||||
return res; \
|
||||
}
|
||||
|
||||
#define FFIT_STRUCT_GET_INT(FUNNAME, SCM_RECTYPE, C_RECTYPE, C_FIELD) \
|
||||
FFIT_STRUCT_GET(FUNNAME, SCM_RECTYPE, C_RECTYPE, C_FIELD, s48_enter_integer);
|
||||
|
||||
#define FFIT_STRUCT_GET_CHAR(FUNNAME, SCM_RECTYPE, C_RECTYPE, C_FIELD) \
|
||||
FFIT_STRUCT_GET(FUNNAMEm SCM_RECTYPE, C_RECTYPE, C_FIELD, s48_enter_char);
|
||||
|
||||
#define FFIT_STRUCT_GET_STRING(FUNNAME, SCM_RECTYPE, C_RECTYPE, C_FIELD) \
|
||||
FFIT_STRUCT_GET(FUNNAME, SCM_RECTYPE, C_RECTYPE, C_FIELD, s48_enter_string);
|
||||
|
||||
/* predicates */
|
||||
#define FFIT_LIST_P(x) (S48_PAIR_P(x) || (x == S48_NULL))
|
||||
|
||||
#define FFIT_CHECK_LIST(v) \
|
||||
do { if (!FFIT_LIST_P(v)) s48_raise_argument_type_error(v); } while (0)
|
||||
#define FFIT_CHECK_INTEGER(v) \
|
||||
do { if (!call_scheme_integer_p(v)) s48_raise_argument_type_error(v); } while (0)
|
||||
#define FFIT_CHECK_BOOLEAN(v) \
|
||||
do { if (!call_scheme_boolean_p(v)) s48_raise_argument_type_error(v); } while (0)
|
||||
|
|
@ -0,0 +1,143 @@
|
|||
(define-record-type constant
|
||||
(make-constant c-name scheme-name c-value-name type)
|
||||
constant?
|
||||
(c-name constant-c-name)
|
||||
(scheme-name constant-scheme-name)
|
||||
(c-value-name constant-c-value-name)
|
||||
(type constant-type))
|
||||
|
||||
(define constant-type-int 'constant-type-int)
|
||||
(define (constant-type-int? thing)
|
||||
(equal? (constant-type thing) constant-type-int))
|
||||
|
||||
(define constant-type-char 'constant-type-char)
|
||||
(define (constant-type-char? thing)
|
||||
(equal? (constant-type thing) constant-type-char))
|
||||
|
||||
(define constant-type-string 'constant-type-string)
|
||||
(define (constant-type-string? thing)
|
||||
(equal? (constant-type thing) constant-type-string))
|
||||
|
||||
(define (constant-name->scheme-name constant-name)
|
||||
(let ((replace-underscore
|
||||
(lambda (c) (if (char=? c #\_) #\- c))))
|
||||
(string-map replace-underscore (string-downcase constant-name))))
|
||||
|
||||
(define c-value-name-prefix "scheme_")
|
||||
|
||||
(define (constant-name->value-name constant-name)
|
||||
(string-append c-value-name-prefix constant-name))
|
||||
|
||||
(define (make-integer-constant c-name scheme-name)
|
||||
(make-constant c-name scheme-name
|
||||
(constant-name->value-name c-name)
|
||||
constant-type-int))
|
||||
|
||||
(define (make-string-constant c-name scheme-name)
|
||||
(make-constant c-name scheme-name
|
||||
(constant-name->value-name c-name)
|
||||
constant-type-string))
|
||||
|
||||
(define (make-constant-from-c-name c-name type)
|
||||
(let ((scheme-name (constant-name->scheme-name c-name)))
|
||||
(make-constant c-name scheme-name
|
||||
(constant-name->value-name c-name)
|
||||
type)))
|
||||
|
||||
(define (make-constant-from-c-name-integer c-name)
|
||||
(make-constant-from-c-name c-name constant-type-int))
|
||||
|
||||
(define (generate-c-declarations constant-list)
|
||||
(string-join
|
||||
(map
|
||||
(lambda (c)
|
||||
(format "static s48_value ~a = S48_FALSE;~%"
|
||||
(constant-c-value-name c)))
|
||||
constant-list)))
|
||||
|
||||
(define (generate-c-gc-protect-globals constant-list)
|
||||
(string-join
|
||||
(map
|
||||
(lambda (c)
|
||||
(format "S48_GC_PROTECT_GLOBAL(~a);~%"
|
||||
(constant-c-value-name c)))
|
||||
constant-list)))
|
||||
|
||||
(define (generate-c-enter-value c)
|
||||
(cond
|
||||
((constant-type-int? c)
|
||||
(format "~a = s48_enter_integer(~a);~%"
|
||||
(constant-c-value-name c) (constant-c-name c)))
|
||||
((constant-type-string? c)
|
||||
(format "~a = s48_enter_string(~a);~%"
|
||||
(constant-c-value-name c) (constant-c-name c)))
|
||||
(else
|
||||
(error "Don't know how to handle this constant type: "
|
||||
(constant-type c)))))
|
||||
|
||||
(define (generate-c-enter-values constant-list)
|
||||
(string-join
|
||||
(map generate-c-enter-value constant-list)))
|
||||
|
||||
(define (wrap-in-c-function fun-name body)
|
||||
(format
|
||||
(string-append
|
||||
"void ~a(void) {~%"
|
||||
"~a~%"
|
||||
"}~%~%")
|
||||
fun-name body))
|
||||
|
||||
(define (generate-c-enter-values-function c-fun-name constant-list)
|
||||
(wrap-in-c-function c-fun-name
|
||||
(generate-c-enter-values constant-list)))
|
||||
|
||||
(define (generate-c-gc-protect-globals-function c-fun-name constant-list)
|
||||
(wrap-in-c-function c-fun-name
|
||||
(generate-c-gc-protect-globals constant-list)))
|
||||
|
||||
;;; generating scheme code
|
||||
|
||||
(define (generate-binding constant)
|
||||
(format "(define ~a (lookup-shared-value \"~a\"))~%"
|
||||
(constant-scheme-name constant)
|
||||
(constant-c-value-name constant)))
|
||||
|
||||
(define (generate-finite-type-definition ft-name name-converter constants)
|
||||
(let ((predicate-name (string-append ft-name "-object?"))
|
||||
(elements-name (string-append ft-name "-elements"))
|
||||
(name-name (string-append ft-name "-name"))
|
||||
(index-name (string-append ft-name "-index"))
|
||||
(id-name (string-append ft-name "-id")))
|
||||
(format
|
||||
(string-append
|
||||
"(define-finite-type ~a :~a~%"
|
||||
" (id)~%"
|
||||
" ~a~% ~a~% ~a~% ~a~%"
|
||||
" (~a)~%"
|
||||
" (~a))~%~%")
|
||||
ft-name ft-name
|
||||
predicate-name elements-name name-name index-name
|
||||
(string-append "id " id-name)
|
||||
(generate-finite-type-items name-converter constants))))
|
||||
|
||||
(define (generate-finite-type-items name-converter constants)
|
||||
(string-join
|
||||
(map (lambda (c) (generate-finite-type-item name-converter c))
|
||||
constants)))
|
||||
|
||||
(define (generate-finite-type-item name-converter constant)
|
||||
(format " (~a\t(lookup-shared-value \"~a\"))~%"
|
||||
(name-converter constant)
|
||||
(constant-c-value-name constant)))
|
||||
|
||||
(define (make-drop-common-prefix-name-converter prefix)
|
||||
(let ((len (string-length prefix)))
|
||||
(lambda (constant)
|
||||
(let ((name (constant-c-name constant)))
|
||||
(constant-name->scheme-name
|
||||
(if (string-prefix? prefix name)
|
||||
(string-drop name len)
|
||||
name))))))
|
||||
|
||||
|
||||
|
||||
Loading…
Reference in New Issue