From 279ac9a9e54dfc2a70553ad2210b98a7f9f73113 Mon Sep 17 00:00:00 2001 From: eknauel Date: Tue, 4 May 2004 18:27:43 +0000 Subject: [PATCH] *** empty log message *** --- .gitignore | 28 ++++++++ c/ffi-tools.c | 84 ++++++++++++++++++++++ c/ffi-tools.h | 95 ++++++++++++++++++++++++ pkg-def.scm | 19 +++++ scheme/generate.scm | 156 ++++++++++++++++++++++++++++++++++++++++ scheme/packages-gen.scm | 34 +++++++++ scheme/packages-run.scm | 10 +++ scheme/runtime.scm | 23 ++++++ 8 files changed, 449 insertions(+) create mode 100644 .gitignore create mode 100644 c/ffi-tools.c create mode 100644 c/ffi-tools.h create mode 100644 pkg-def.scm create mode 100644 scheme/generate.scm create mode 100644 scheme/packages-gen.scm create mode 100644 scheme/packages-run.scm create mode 100644 scheme/runtime.scm diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..da8168b --- /dev/null +++ b/.gitignore @@ -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 diff --git a/c/ffi-tools.c b/c/ffi-tools.c new file mode 100644 index 0000000..6c8678e --- /dev/null +++ b/c/ffi-tools.c @@ -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?"); +} + diff --git a/c/ffi-tools.h b/c/ffi-tools.h new file mode 100644 index 0000000..334395b --- /dev/null +++ b/c/ffi-tools.h @@ -0,0 +1,95 @@ +#include +#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) diff --git a/pkg-def.scm b/pkg-def.scm new file mode 100644 index 0000000..0b4e524 --- /dev/null +++ b/pkg-def.scm @@ -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) +) \ No newline at end of file diff --git a/scheme/generate.scm b/scheme/generate.scm new file mode 100644 index 0000000..b2bca3e --- /dev/null +++ b/scheme/generate.scm @@ -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)))))) + + + diff --git a/scheme/packages-gen.scm b/scheme/packages-gen.scm new file mode 100644 index 0000000..7eed3e1 --- /dev/null +++ b/scheme/packages-gen.scm @@ -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)) diff --git a/scheme/packages-run.scm b/scheme/packages-run.scm new file mode 100644 index 0000000..584a6bc --- /dev/null +++ b/scheme/packages-run.scm @@ -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)) diff --git a/scheme/runtime.scm b/scheme/runtime.scm new file mode 100644 index 0000000..e364f56 --- /dev/null +++ b/scheme/runtime.scm @@ -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))))))