- ffi-tools now has its own cvs module, remove it from scsh-ldap

- change pkg-def.scm to use installed ffi-tools
This commit is contained in:
eknauel 2004-05-04 19:36:17 +00:00
parent a440b8785b
commit 18811c784c
6 changed files with 40 additions and 404 deletions

View File

@ -1,32 +0,0 @@
(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 ffi-tools))

View File

@ -1,38 +0,0 @@
(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-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))))))
))

View File

@ -1,98 +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 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(S48_SHARED_BINDING_REF(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(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 = 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(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_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?");
}

View File

@ -1,73 +0,0 @@
#include <unistd.h>
#include "scheme48.h"
/* 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) && \
(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)

View File

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

View File

@ -1,17 +1,48 @@
(define-package "ldap" (0 1 0) (define-package "ldap" (0 1 0)
((options (ldap-prefix "Use LDAP library with prefix" "<dir>" #t #f #f))) ((install-lib-version (1 0))
(options (ldap-prefix "Use LDAP library with prefix" "<dir>" #t #f #f)))
(define (display-bold text)
(display "\033[1m")
(display text)
(display "\033[m"))
(newline) (newline)
(display "Configuring, compiling and installting C-stubs") (display-bold "Generating Scheme stub code")
(newline)
(run (scsh -lel ffi-tools/load.scm
-lm scheme/ldap-constants.scm
-o ldap-constants
-c "(make-scm-files command-line-arguments)"
scheme))
(newline)
(display-bold "Generating C stub code")
(newline)
(run (scsh -lel ffi-tools/load.scm
-lm scheme/ldap-constants.scm
-o ldap-constants
-c "(make-c-files command-line-arguments)"
c))
(newline)
(display-bold "Configuring, compiling and installing C-stubs")
(newline) (newline)
(let* ((scsh-includes (include-dir)) (let* ((scsh-includes (include-dir))
(build-host (get-option-value 'build)) (build-host (get-option-value 'build))
(prefix (string-append (get-directory 'lib #f) "/" build-host)) (prefix (string-append (get-directory 'lib #f) "/" build-host))
(ffi-tools-path
(run/string (scsh -lel ffi-tools/load.scm -o ffi-tools-path
-c "(display (ffi-tools-lib-path))")))
(configure (append (configure (append
(list "./configure" (list "./configure"
(string-append "--prefix=" prefix) (string-append "--prefix=" prefix)
(string-append "--with-scsh-includes=" scsh-includes) (string-append "--with-scsh-includes=" scsh-includes)
(string-append "--with-ffi-tools=" ffi-tools-path)
(string-append "--enable-static=no") (string-append "--enable-static=no")
(string-append "--build=" build-host)) (string-append "--build=" build-host))
(cond ((get-option-value 'ldap-prefix) (cond ((get-option-value 'ldap-prefix)
@ -30,7 +61,7 @@
(exit)))) (exit))))
(newline) (newline)
(display "creating load.scm") (display-bold "Creating load.scm")
(newline) (newline)
(let ((schemedir (get-directory 'scheme #f)) (let ((schemedir (get-directory 'scheme #f))
@ -56,11 +87,13 @@
(else (else
(error "Could not figure out libscshldap's name" la-file-name)))))) (error "Could not figure out libscshldap's name" la-file-name))))))
(config) (config)
(load ,(string-append schemedir "/ffi-tools-rts.scm"))
(load ,(string-append schemedir "/interfaces.scm")) (load ,(string-append schemedir "/interfaces.scm"))
(load ,(string-append schemedir "/packages.scm")) (load ,(string-append schemedir "/packages.scm"))
(user)))) (user))))
(newline)
(display-bold "Installing Scheme files")
(newline)
(install-directory-contents "scheme" 'scheme) (install-directory-contents "scheme" 'scheme)
(install-file "ffi-tools/ffi-tools-rts.scm" 'scheme) )
)