scsh-conservatory
/
scsh-odbc
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Yet another import of ffi-tools

This commit is contained in:
eknauel 2004-02-11 07:28:04 +00:00
parent aa3101b7b4
commit 99e0cd7d7d
5 changed files with 380 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

31
ffi-tools/ffi-tools-package.scm Normal file
View File

@ -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))

34
ffi-tools/ffi-tools-rts.scm Normal file
View File

@ -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))))))
))

96
ffi-tools/ffi-tools.c Normal file
View File

@ -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?");
}

76
ffi-tools/ffi-tools.h Normal file
View File

@ -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)

143
ffi-tools/ffi-tools.scm Normal file
View File

@ -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))))))