eclisp-sys 0.1.1

#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_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;
}