97 lines
2.1 KiB
C
97 lines
2.1 KiB
C
#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?");
|
|
}
|