eclisp-sys 0.1.0

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

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

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_root_is_nil(const eclisp_root *root) {
    return root->object == ECL_NIL;
}

int eclisp_root_is_t(const eclisp_root *root) {
    return root->object == ECL_T;
}

int eclisp_root_is_int(const eclisp_root *root) {
    if (!root) {
        return 0;
    }

    cl_type type = ecl_t_of(root->object);
    return type == t_fixnum || type == t_bignum;
}

int eclisp_root_is_float(const eclisp_root *root) {
    cl_type type = ecl_t_of(root->object);
    return type == t_singlefloat ||
    type == t_doublefloat ||
    type == t_longfloat;
}

int eclisp_root_is_string(const eclisp_root *root) {
    return ECL_STRINGP(root->object);
}

int eclisp_root_as_int(const eclisp_root *root, int64_t *out) {
    if (!root || !out) {
        return 0;
    }

    cl_object object = root->object;

    if (!eclisp_root_is_int(root)) {
      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_root_as_float(const eclisp_root *root, double *out) {
    if (!out) {
        return 0;
    }

    cl_type type = ecl_t_of(root->object);

    if (type == t_singlefloat) {
        *out = (double)ecl_single_float(root->object);
    } else if (type == t_doublefloat) {
        *out = (double)ecl_double_float(root->object);
    } else if (type == t_longfloat) {
        *out = (double)ecl_long_float(root->object);
    } else {
        return 0;
    }

    return 1;
}

int eclisp_root_as_string(
    const eclisp_root *root,
    char **out,
    size_t *out_length
) {
    if (!root || !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(root->object)) {
                success = eclisp_copy_utf8_bytes(root->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_root_repr(
    const eclisp_root *root,
    char **out_repr
) {
    if (!root || !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(root->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_root_car(const eclisp_root *root, eclisp_root **out_car) {
    if (!root || !out_car || !ECL_CONSP(root->object)) {
        return 0;
    }

    cl_object car = ECL_CONS_CAR(root->object);
    *out_car = eclisp_root_new(car);
    return *out_car != NULL;
}

int eclisp_root_cdr(const eclisp_root *root, eclisp_root **out_cdr) {
    if (!root || !out_cdr || !ECL_CONSP(root->object)) {
        return 0;
    }

    cl_object cdr = ECL_CONS_CDR(root->object);
    *out_cdr = eclisp_root_new(cdr);
    return *out_cdr != NULL;
}

int eclisp_root_is_cons(const eclisp_root *root) {
    return root && ECL_CONSP(root->object);
}

int eclisp_root_is_list(const eclisp_root *root) {
    return root && ECL_LISTP(root->object);
}