#include "wrapper.h"
#include <gc/gc.h>
#include <stdint.h>
#include <stdlib.h>
static int eclisp_copy_utf8_bytes(
cl_object object,
char **out,
size_t *out_length
) {
if (!out || !out_length) {
return 0;
}
*out = NULL;
*out_length = 0;
cl_object encoding = ecl_read_from_cstring(":UTF-8");
char dummy;
cl_fixnum size = ecl_encode_to_cstring(&dummy, 0, object, encoding);
if (size <= 0) {
return 0;
}
char *buffer = malloc((size_t)size);
if (!buffer) {
return 0;
}
cl_fixnum written = ecl_encode_to_cstring(buffer, size, object, encoding);
if (written != size) {
free(buffer);
return 0;
}
*out = buffer;
*out_length = (size_t)written - 1;
return 1;
}
static int eclisp_copy_utf8(cl_object object, char **out) {
size_t unused_length = 0;
return eclisp_copy_utf8_bytes(object, out, &unused_length);
}
int eclisp_root_copy(
cl_object object,
eclisp_root **out
) {
if (!out) {
return 0;
}
*out = eclisp_root_new(object);
return *out != NULL;
}
void eclisp_root_free(eclisp_root *root) {
GC_free(root);
}
eclisp_root *eclisp_root_new(cl_object object) {
eclisp_root *root = GC_malloc_uncollectable(sizeof(eclisp_root));
if (!root) {
return NULL;
}
root->object = object;
return root;
}
cl_object eclisp_root_get(const eclisp_root *root) {
return root->object;
}
int eclisp_eval(
const char *source,
eclisp_root **out_root,
char **out_error
) {
if (!source || !out_root || !out_error) {
return -1;
}
*out_root = NULL;
*out_error = NULL;
volatile int status = 0;
cl_env_ptr env = ecl_process_env();
cl_object error_type = ecl_make_symbol("ERROR", "CL");
ECL_CATCH_ALL_BEGIN(env) {
ECL_HANDLER_CASE_BEGIN(env, ecl_list1(error_type)) {
cl_object encoding = ecl_read_from_cstring(":UTF-8");
cl_object string =
ecl_decode_from_cstring(source, -1, encoding);
if (string == NULL) {
status = 3;
} else {
cl_object stream =
cl_make_string_input_stream(1, string);
cl_object eof = cl_gensym(0);
cl_object result = ECL_NIL;
while (1) {
cl_object form = cl_read(
3, stream, ECL_NIL, eof
);
if (form == eof) {
break;
}
result = cl_eval(form);
}
cl_close(1, stream);
*out_root = eclisp_root_new(result);
if (*out_root == NULL) {
status = 2;
}
}
} ECL_HANDLER_CASE(1, condition) {
status = 1;
cl_object message = cl_princ_to_string(condition);
eclisp_copy_utf8(message, out_error);
} ECL_HANDLER_CASE_END;
} ECL_CATCH_ALL_IF_CAUGHT {
status = 1;
} ECL_CATCH_ALL_END;
return status;
}
static eclisp_callback rust_callback = NULL;
static cl_object eclisp_dispatch(
cl_object callback_id,
cl_object arguments
) {
if (!rust_callback) {
cl_error(
1,
ecl_make_simple_base_string(
"Rust dispatcher is not registered", -1
)
);
return ECL_NIL;
}
int64_t id = 0;
if (!eclisp_as_int(callback_id, &id) || id < 0) {
cl_error(
1,
ecl_make_simple_base_string(
"Invalid Rust callback ID", -1
)
);
return ECL_NIL;
}
eclisp_root *result_root = NULL;
char error[1024] = {0};
int status = rust_callback(
(size_t)id,
arguments,
&result_root,
error,
sizeof(error)
);
if (status != ECLISP_OK) {
if (result_root) {
eclisp_root_free(result_root);
}
cl_error(
2,
ecl_make_simple_base_string(
"Rust callback failed: ~A", -1
),
ecl_make_simple_base_string(error, -1)
);
return ECL_NIL;
}
if (!result_root) {
cl_error(
1,
ecl_make_simple_base_string(
"Rust callback returned no result", -1
)
);
return ECL_NIL;
}
cl_object result = eclisp_root_get(result_root);
eclisp_root_free(result_root);
return result;
}
int eclisp_register_dispatcher(eclisp_callback callback) {
if (!callback) {
return ECLISP_INVALID_ARGUMENT;
}
volatile int status = ECLISP_ERROR;
cl_env_ptr env = ecl_process_env();
ECL_CATCH_ALL_BEGIN(env) {
ECL_HANDLER_CASE_BEGIN(
env,
ecl_list1(ecl_make_symbol("ERROR", "CL"))
) {
cl_object symbol = ecl_make_symbol(
"%ECLISP-DISPATCH",
"CL-USER"
);
ecl_def_c_function(
symbol,
(cl_objectfn_fixed)eclisp_dispatch,
2
);
rust_callback = callback;
status = ECLISP_OK;
} ECL_HANDLER_CASE(1, condition) {
(void)condition;
status = ECLISP_ERROR;
} ECL_HANDLER_CASE_END;
} ECL_CATCH_ALL_IF_CAUGHT {
status = ECLISP_ERROR;
} ECL_CATCH_ALL_END;
return status;
}
int eclisp_args_length(cl_object arguments, size_t *out_length) {
if (!out_length) {
return 0;
}
*out_length = 0;
while (ECL_CONSP(arguments)) {
if (*out_length == SIZE_MAX) {
return 0;
}
++*out_length;
arguments = ECL_CONS_CDR(arguments);
}
return arguments == ECL_NIL;
}
int eclisp_args_get(
cl_object arguments,
size_t index,
cl_object *out
) {
if (!out) {
return 0;
}
for (size_t i = 0; i < index; ++i) {
if (!ECL_CONSP(arguments)) {
return 0;
}
arguments = ECL_CONS_CDR(arguments);
}
if (!ECL_CONSP(arguments)) {
return 0;
}
*out = ECL_CONS_CAR(arguments);
return 1;
}
int eclisp_function_get(
const char *name,
eclisp_root **out_root,
char **out_error
) {
if (!name || !out_root || !out_error)
return ECLISP_INVALID_ARGUMENT;
*out_root = NULL;
*out_error = NULL;
volatile int status = ECLISP_OK;
cl_env_ptr env = ecl_process_env();
ECL_CATCH_ALL_BEGIN(env) {
ECL_HANDLER_CASE_BEGIN(
env, ecl_list1(ecl_make_symbol("ERROR", "CL"))
) {
cl_object string = ecl_decode_from_cstring(
name, -1, ecl_make_keyword("UTF-8")
);
string = cl_string_upcase(1, string);
cl_object symbol = cl_find_symbol(1, string);
if (symbol == ECL_NIL || cl_fboundp(symbol) == ECL_NIL) {
status = 3;
} else {
cl_object function = cl_fdefinition(symbol);
*out_root = eclisp_root_new(function);
if (!*out_root)
status = ECLISP_ALLOCATION_FAILED;
}
} ECL_HANDLER_CASE(1, condition) {
status = ECLISP_ERROR;
eclisp_copy_utf8(
cl_princ_to_string(condition), out_error
);
} ECL_HANDLER_CASE_END;
} ECL_CATCH_ALL_IF_CAUGHT {
status = ECLISP_ERROR;
} ECL_CATCH_ALL_END;
return status;
}
int eclisp_function_call(
cl_object function,
size_t argc,
const cl_object *argv,
eclisp_root **out_root,
char **out_error
) {
if (!out_root || !out_error || (argc && !argv))
return ECLISP_INVALID_ARGUMENT;
*out_root = NULL;
*out_error = NULL;
volatile int status = ECLISP_OK;
cl_env_ptr env = ecl_process_env();
ECL_CATCH_ALL_BEGIN(env) {
ECL_HANDLER_CASE_BEGIN(
env, ecl_list1(ecl_make_symbol("ERROR", "CL"))
) {
if (cl_functionp(function) == ECL_NIL) {
status = ECLISP_INVALID_ARGUMENT;
} else {
cl_object arguments = ECL_NIL;
for (size_t i = argc; i > 0; --i)
arguments = cl_cons(argv[i - 1], arguments);
cl_object result = cl_apply(
2, function, arguments
);
*out_root = eclisp_root_new(result);
if (!*out_root)
status = ECLISP_ALLOCATION_FAILED;
}
} ECL_HANDLER_CASE(1, condition) {
status = ECLISP_ERROR;
eclisp_copy_utf8(
cl_princ_to_string(condition), out_error
);
} ECL_HANDLER_CASE_END;
} ECL_CATCH_ALL_IF_CAUGHT {
status = ECLISP_ERROR;
} ECL_CATCH_ALL_END;
return status;
}
int eclisp_call(
const char *function,
size_t argc,
const cl_object *argv,
eclisp_root **out_root,
char **out_error
) {
if (!function || !out_root || !out_error ||
(argc > 0 && !argv)) {
return -1;
}
*out_root = NULL;
*out_error = NULL;
volatile int status = 0;
cl_env_ptr env = ecl_process_env();
cl_object error_type = ecl_make_symbol("ERROR", "CL");
ECL_CATCH_ALL_BEGIN(env) {
ECL_HANDLER_CASE_BEGIN(env, ecl_list1(error_type)) {
cl_object encoding = ecl_make_keyword("UTF-8");
cl_object name = ecl_decode_from_cstring(
function, -1, encoding
);
name = cl_string_upcase(1, name);
cl_object symbol = cl_find_symbol(1, name);
if (symbol == ECL_NIL) {
status = 3;
} else {
cl_object arguments = ECL_NIL;
for (size_t i = argc; i > 0; --i) {
arguments = cl_cons(argv[i - 1], arguments);
}
cl_object result = cl_apply(
2, symbol, arguments
);
*out_root = eclisp_root_new(result);
if (!*out_root) {
status = 2;
}
}
} ECL_HANDLER_CASE(1, condition) {
status = 1;
cl_object message = cl_princ_to_string(condition);
eclisp_copy_utf8(message, out_error);
} ECL_HANDLER_CASE_END;
} ECL_CATCH_ALL_IF_CAUGHT {
status = 1;
} ECL_CATCH_ALL_END;
return status;
}
int eclisp_is_nil(cl_object object) {
return object == ECL_NIL;
}
int eclisp_is_t(cl_object object) {
return object == ECL_T;
}
int eclisp_is_int(cl_object object) {
cl_type type = ecl_t_of(object);
return type == t_fixnum || type == t_bignum;
}
int eclisp_is_float(cl_object object) {
cl_type type = ecl_t_of(object);
return type == t_singlefloat ||
type == t_doublefloat ||
type == t_longfloat;
}
int eclisp_is_string(cl_object object) {
return ECL_STRINGP(object);
}
int eclisp_is_cons(cl_object object) {
return ECL_CONSP(object);
}
int eclisp_is_list(cl_object object) {
return ECL_LISTP(object);
}
int eclisp_as_int(cl_object object, int64_t *out) {
if (!out || !eclisp_is_int(object)) {
return 0;
}
volatile int success = 0;
cl_env_ptr env = ecl_process_env();
ECL_CATCH_ALL_BEGIN(env) {
ECL_HANDLER_CASE_BEGIN(
env,
ecl_list1(ecl_make_symbol("ERROR", "CL"))
) {
*out = ecl_to_int64_t(object);
success = 1;
} ECL_HANDLER_CASE(1, condition) {
(void)condition;
success = 0;
} ECL_HANDLER_CASE_END;
} ECL_CATCH_ALL_IF_CAUGHT {
success = 0;
} ECL_CATCH_ALL_END;
return success;
}
int eclisp_as_float(cl_object object, double *out) {
if (!out) {
return 0;
}
cl_type type = ecl_t_of(object);
if (type == t_singlefloat) {
*out = (double)ecl_single_float(object);
} else if (type == t_doublefloat) {
*out = (double)ecl_double_float(object);
} else if (type == t_longfloat) {
*out = (double)ecl_long_float(object);
} else {
return 0;
}
return 1;
}
int eclisp_as_string(
cl_object object,
char **out,
size_t *out_length
) {
if (!out || !out_length) {
return 0;
}
*out = NULL;
*out_length = 0;
volatile int success = 0;
cl_env_ptr env = ecl_process_env();
ECL_CATCH_ALL_BEGIN(env) {
ECL_HANDLER_CASE_BEGIN(
env,
ecl_list1(ecl_make_symbol("ERROR", "CL"))
) {
if (ECL_STRINGP(object)) {
success = eclisp_copy_utf8_bytes(object, out, out_length);
}
} ECL_HANDLER_CASE(1, condition) {
(void)condition;
success = 0;
} ECL_HANDLER_CASE_END;
} ECL_CATCH_ALL_IF_CAUGHT {
success = 0;
} ECL_CATCH_ALL_END;
if (!success) {
free(*out);
*out = NULL;
*out_length = 0;
}
return success;
}
int eclisp_repr(cl_object object, char **out_repr) {
if (!out_repr) {
return 0;
}
*out_repr = NULL;
volatile int success = 0;
cl_env_ptr env = ecl_process_env();
ECL_CATCH_ALL_BEGIN(env) {
ECL_HANDLER_CASE_BEGIN(
env,
ecl_list1(ecl_make_symbol("ERROR", "CL"))
) {
cl_object repr = cl_prin1_to_string(object);
success = eclisp_copy_utf8(repr, out_repr);
} ECL_HANDLER_CASE(1, condition) {
(void)condition;
success = 0;
} ECL_HANDLER_CASE_END;
} ECL_CATCH_ALL_IF_CAUGHT {
success = 0;
} ECL_CATCH_ALL_END;
if (!success) {
free(*out_repr);
*out_repr = NULL;
}
return success;
}
int eclisp_int_new(int64_t value, eclisp_root **out) {
if (!out) {
return ECLISP_INVALID_ARGUMENT;
}
*out = NULL;
volatile int status = ECLISP_ERROR;
cl_env_ptr env = ecl_process_env();
ECL_CATCH_ALL_BEGIN(env) {
ECL_HANDLER_CASE_BEGIN(
env,
ecl_list1(ecl_make_symbol("ERROR", "CL"))
) {
cl_object object = ecl_make_int64_t(value);
*out = eclisp_root_new(object);
status = *out ? ECLISP_OK : ECLISP_ALLOCATION_FAILED;
} ECL_HANDLER_CASE(1, condition) {
(void)condition;
status = ECLISP_ERROR;
} ECL_HANDLER_CASE_END;
} ECL_CATCH_ALL_IF_CAUGHT {
status = ECLISP_ERROR;
} ECL_CATCH_ALL_END;
return status;
}
int eclisp_float_new(double value, eclisp_root **out) {
if (!out) {
return ECLISP_INVALID_ARGUMENT;
}
*out = NULL;
volatile int status = ECLISP_ERROR;
cl_env_ptr env = ecl_process_env();
ECL_CATCH_ALL_BEGIN(env) {
ECL_HANDLER_CASE_BEGIN(
env,
ecl_list1(ecl_make_symbol("ERROR", "CL"))
) {
cl_object object = ecl_make_double_float(value);
*out = eclisp_root_new(object);
status = *out ? ECLISP_OK : ECLISP_ALLOCATION_FAILED;
} ECL_HANDLER_CASE(1, condition) {
(void)condition;
status = ECLISP_ERROR;
} ECL_HANDLER_CASE_END;
} ECL_CATCH_ALL_IF_CAUGHT {
status = ECLISP_ERROR;
} ECL_CATCH_ALL_END;
return status;
}
int eclisp_cons_new(
cl_object car,
cl_object cdr,
eclisp_root **out
) {
if (!out) {
return ECLISP_INVALID_ARGUMENT;
}
*out = NULL;
volatile int status = ECLISP_ERROR;
cl_env_ptr env = ecl_process_env();
ECL_CATCH_ALL_BEGIN(env) {
ECL_HANDLER_CASE_BEGIN(
env,
ecl_list1(ecl_make_symbol("ERROR", "CL"))
) {
cl_object object = cl_cons(car, cdr);
*out = eclisp_root_new(object);
status = *out ? ECLISP_OK : ECLISP_ALLOCATION_FAILED;
} ECL_HANDLER_CASE(1, condition) {
(void)condition;
status = ECLISP_ERROR;
} ECL_HANDLER_CASE_END;
} ECL_CATCH_ALL_IF_CAUGHT {
status = ECLISP_ERROR;
} ECL_CATCH_ALL_END;
return status;
}
int eclisp_list_new(
size_t length,
const cl_object *values,
eclisp_root **out
) {
if (!out || (length > 0 && !values)) {
return ECLISP_INVALID_ARGUMENT;
}
*out = NULL;
eclisp_root *root = eclisp_root_new(ECL_NIL);
if (!root) {
return ECLISP_ALLOCATION_FAILED;
}
volatile int status = ECLISP_ERROR;
cl_env_ptr env = ecl_process_env();
ECL_CATCH_ALL_BEGIN(env) {
ECL_HANDLER_CASE_BEGIN(
env,
ecl_list1(ecl_make_symbol("ERROR", "CL"))
) {
for (size_t i = length; i > 0; --i) {
root->object = cl_cons(
values[i - 1],
root->object
);
}
status = ECLISP_OK;
} ECL_HANDLER_CASE(1, condition) {
(void)condition;
status = ECLISP_ERROR;
} ECL_HANDLER_CASE_END;
} ECL_CATCH_ALL_IF_CAUGHT {
status = ECLISP_ERROR;
} ECL_CATCH_ALL_END;
if (status != ECLISP_OK) {
eclisp_root_free(root);
return status;
}
*out = root;
return ECLISP_OK;
}
int eclisp_string_new(
const char *text,
size_t length,
eclisp_root **out_root
) {
if (!text || !out_root || length > INTPTR_MAX) {
return -1;
}
*out_root = NULL;
volatile int status = 1;
cl_env_ptr env = ecl_process_env();
ECL_CATCH_ALL_BEGIN(env) {
ECL_HANDLER_CASE_BEGIN(
env,
ecl_list1(ecl_make_symbol("ERROR", "CL"))
) {
cl_object encoding = ecl_make_keyword("UTF-8");
cl_object string = ecl_decode_from_cstring(
text,
(cl_fixnum)length,
encoding
);
if (string != NULL) {
*out_root = eclisp_root_new(string);
status = *out_root ? 0 : 2;
}
} ECL_HANDLER_CASE(1, condition) {
(void)condition;
status = 1;
} ECL_HANDLER_CASE_END;
} ECL_CATCH_ALL_IF_CAUGHT {
status = 1;
} ECL_CATCH_ALL_END;
return status;
}
void eclisp_string_free(char *string) {
free(string);
}
int eclisp_car(cl_object object, eclisp_root **out_car) {
if (!out_car) {
return 0;
}
*out_car = NULL;
if (!ECL_CONSP(object)) {
return 0;
}
*out_car = eclisp_root_new(ECL_CONS_CAR(object));
return *out_car != NULL;
}
int eclisp_cdr(cl_object object, eclisp_root **out_cdr) {
if (!out_cdr) {
return 0;
}
*out_cdr = NULL;
if (!ECL_CONSP(object)) {
return 0;
}
*out_cdr = eclisp_root_new(ECL_CONS_CDR(object));
return *out_cdr != NULL;
}