From df5e273932f37a1c296d4d24db1193585babd80a Mon Sep 17 00:00:00 2001 From: eknauel Date: Tue, 4 May 2004 18:27:43 +0000 Subject: [PATCH] ffi-tools initial import --- c/ffi-tools.c | 84 ---------------------- pkg-def.scm | 19 ----- scheme/generate.scm | 156 ---------------------------------------- scheme/packages-gen.scm | 34 --------- scheme/packages-run.scm | 10 --- scheme/runtime.scm | 23 ------ 6 files changed, 326 deletions(-) delete mode 100644 c/ffi-tools.c delete mode 100644 pkg-def.scm delete mode 100644 scheme/generate.scm delete mode 100644 scheme/packages-gen.scm delete mode 100644 scheme/packages-run.scm delete mode 100644 scheme/runtime.scm diff --git a/c/ffi-tools.c b/c/ffi-tools.c deleted file mode 100644 index 6c8678e..0000000 --- a/c/ffi-tools.c +++ /dev/null @@ -1,84 +0,0 @@ -#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/pkg-def.scm b/pkg-def.scm deleted file mode 100644 index 0b4e524..0000000 --- a/pkg-def.scm +++ /dev/null @@ -1,19 +0,0 @@ -(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 deleted file mode 100644 index b2bca3e..0000000 --- a/scheme/generate.scm +++ /dev/null @@ -1,156 +0,0 @@ -(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 deleted file mode 100644 index 7eed3e1..0000000 --- a/scheme/packages-gen.scm +++ /dev/null @@ -1,34 +0,0 @@ -;;; 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 deleted file mode 100644 index 584a6bc..0000000 --- a/scheme/packages-run.scm +++ /dev/null @@ -1,10 +0,0 @@ -;;; 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 deleted file mode 100644 index e364f56..0000000 --- a/scheme/runtime.scm +++ /dev/null @@ -1,23 +0,0 @@ -(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))))))