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

*** empty log message ***

This commit is contained in:
eknauel 2004-05-04 18:27:43 +00:00
commit 279ac9a9e5
8 changed files with 449 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

28
.gitignore vendored Normal file
View File

@ -0,0 +1,28 @@
# CVS default ignores begin
tags
TAGS
.make.state
.nse_depinfo
*~
\#*
.#*
,*
_$*
*$
*.old
*.bak
*.BAK
*.orig
*.rej
.del-*
*.a
*.olb
*.o
*.obj
*.so
*.exe
*.Z
*.elc
*.ln
core
# CVS default ignores end

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

@ -0,0 +1,84 @@
#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 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(S48_SHARED_BINDING_REF(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(S48_SHARED_BINDING_REF(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 e;
S48_DECLARE_GC_PROTECT(2);
S48_GC_PROTECT_2(list, e);
l = s48_length(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(S48_CAR(e))) {
a[i] = s48_extract_string(S48_CAR(e));
e = S48_CDR(e);
i++;
}
else {
free(a);
s48_raise_argument_type_error(e);
}
else {
free(a);
s48_raise_argument_type_error(e);
}
}
S48_GC_UNPROTECT();
return a;
}
void ffit_init_hook(void)
{
S48_GC_PROTECT_GLOBAL(scheme_integer_p_function);
S48_GC_PROTECT_GLOBAL(scheme_boolean_p_function);
scheme_integer_p_function = s48_get_imported_binding("integer?");
scheme_boolean_p_function = s48_get_imported_binding("boolean?");
}

95
c/ffi-tools.h Normal file
View File

@ -0,0 +1,95 @@
#include <unistd.h>
#include "scheme48.h"
/* variables */
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 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) && \
(S48_RECORD_TYPE(SCM_VAL) == SCM_RECTYPE))) \
s48_raise_argument_type_error(SCM_VAL);
/* macros extracting values from a C struct */
#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);
/* macros for setting values in a C struct */
#define FFIT_STRUCT_SET(FUNNAME, SCM_RECTYPE, C_RECTYPE, C_FIELD, FIELD_SCM_EXTRACT_FUN) \
s48_value FUNNAME(s48_value scm_rec, s48_value val) { \
C_RECTYPE c_rec; \
S48_DECLARE_GC_PROTECT(2); \
\
S48_GC_PROTECT_2(scm_rec, val); \
FFIT_CHECK_RECORD_TYPE(scm_rec, SCM_RECTYPE); \
c_rec = (C_RECTYPE) s48_extract_integer(S48_RECORD_REF(scm_rec, 0)); \
c_rec->C_FIELD = FIELD_SCM_EXTRACT_FUN(val); \
S48_GC_UNPROTECT(); \
return S48_UNSPECIFIC; \
}
#define FFIT_STRUCT_SET_INT(FUNNAME, SCM_RECTYPE, C_RECTYPE, C_FIELD) \
FFIT_STRUCT_SET(FUNNAME, SCM_RECTYPE, C_RECTYPE, C_FIELD, s48_extract_integer);
#define FFIT_STRUCT_SET_CHAR(FUNNAME, SCM_RECTYPE, C_RECTYPE, C_FIELD) \
FFIT_STRUCT_SET(FUNNAME, SCM_RECTYPE, C_RECTYPE, C_FIELD, s48_extract_char);
#define FFIT_STRUCT_SET_STRING(FUNNAME, SCM_RECTYPE, C_RECTYPE, C_FIELD) \
FFIT_STRUCT_SET(FUNNAME, SCM_RECTYPE, C_RECTYPE, C_FIELD, s48_extract_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)

19
pkg-def.scm Normal file
View File

@ -0,0 +1,19 @@
(define-package "ffi-tools" (0 1 0)
((install-lib-version (1 0)))
(let ((scheme-dir (get-directory 'scheme #f))
(lib-dir (get-directory 'lib #f)))
(write-to-load-script
`((config)
(run '(define-structure ffi-tools-path
(export ffi-tools-lib-path)
(open scheme)
(begin
(define (ffi-tools-lib-path) ,lib-dir))))
(load ,(string-append scheme-dir "/packages-run.scm"))
(load ,(string-append scheme-dir "/packages-gen.scm"))
(user))))
(install-directory-contents "scheme" 'scheme)
(install-directory-contents "c" 'lib)
)

156
scheme/generate.scm Normal file
View File

@ -0,0 +1,156 @@
(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-define-exported-bindings constant-list)
(string-join
(map
(lambda (c)
(format "s48_define_exported_binding(\"~a\", ~a);~%"
(constant-c-value-name c)
(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-define-exported-bindings-function c-fun-name constant-list)
(wrap-in-c-function c-fun-name
(generate-c-define-exported-bindings 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))))))

34
scheme/packages-gen.scm Normal file
View File

@ -0,0 +1,34 @@
;;; packages for generating code
(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-define-exported-bindings-function
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 generate))

10
scheme/packages-run.scm Normal file
View File

@ -0,0 +1,10 @@
;;; packages readed at runtime
(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)
(files runtime))

23
scheme/runtime.scm Normal file
View File

@ -0,0 +1,23 @@
(define-exported-binding "length" length)
(define-exported-binding "boolean?" boolean?)
(define-exported-binding "integer?" integer?)
(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))))))