base.hh

#ifndef VTESTBED_GUILE_BASE_HH
#define VTESTBED_GUILE_BASE_HH

#include <blitz/array.h>
#include <libguile.h>

#include <cstdint>
#include <memory>
#include <string>

namespace vtb {

    namespace guile {

        template <class Pointer>
        inline void
        define_procedure(const char *name, int req, int opt, int rest, Pointer ptr,
                         const char* documentation=nullptr) {
            SCM proc = scm_c_define_gsubr(name, req, opt, rest,
                                          reinterpret_cast<scm_t_subr>(ptr));
            if (documentation) {
                scm_set_procedure_property_x(proc, scm_from_utf8_symbol("documentation"),
                                             scm_from_utf8_string(documentation));
            }
        }

        inline void
        throw_error(const char* message) {
            scm_throw(scm_from_utf8_symbol("vtb-error"),
                      scm_list_1(scm_from_utf8_string(message)));
        }

        inline bool
        symbol_equal(SCM a, SCM b) {
            return scm_is_true(scm_eq_p(a, b));
        }

        inline SCM vtestbed_gc() {
            scm_gc();
            scm_run_finalizers();
            return SCM_UNSPECIFIED;
        }

        template <class T> inline T*
        allocate(const char* name) {
            return reinterpret_cast<T*>(scm_gc_malloc(sizeof(T), name));
        }

        template <class T> inline T*
        allocate_pointerless(const char* name) {
            return reinterpret_cast<T*>(scm_gc_malloc_pointerless(sizeof(T), name));
        }

        template <class T, class ... Args> inline T*
        construct_pointerless(const char* name, Args ... args) {
            auto* ptr = allocate_pointerless<T>(name);
            new (ptr) T(std::forward<Args>(args)...);
            return ptr;
        }

        inline bool is_bound(SCM s) { return !SCM_UNBNDP(s); }
        inline int length(SCM s) { return scm_to_int(scm_length(s)); }
        inline bool is_list(SCM s) { return scm_is_true(scm_list_p(s)); }

        template <int N>
        inline SCM to_scm(const blitz::TinyVector<float,N>& x) {
            auto *ptr = reinterpret_cast<float*>(std::malloc(sizeof(float)*N));
            for (int i=0; i<N; ++i) { ptr[i] = x[i]; }
            return scm_take_f32vector(ptr, N);
        }

        template <int N>
        inline SCM to_scm(const blitz::TinyVector<double,N>& x) {
            auto *ptr = reinterpret_cast<double*>(std::malloc(sizeof(double)*N));
            for (int i=0; i<N; ++i) { ptr[i] = x[i]; }
            return scm_take_f64vector(ptr, N);
        }

        template <class T> struct Uniform_vector_traits;

        template <> struct Uniform_vector_traits<int> {
            using scalar_type = int;
            static constexpr const auto elements = scm_s32vector_elements;
        };

        template <> struct Uniform_vector_traits<float> {
            using scalar_type = float;
            static constexpr const auto elements = scm_f32vector_elements;
        };

        template <> struct Uniform_vector_traits<double> {
            using scalar_type = double;
            static constexpr const auto elements = scm_f64vector_elements;
        };

        template <class T, int N>
        inline blitz::TinyVector<T,N> to_vector(SCM x) {
            scm_t_array_handle handle;
            size_t n = 0;
            ssize_t dn = 1;
            const T* ptr = Uniform_vector_traits<T>::elements(x, &handle, &n, &dn);
            blitz::TinyVector<T,N> y;
            for (size_t i=0; i<n; ++i, ptr += dn) { y[i] = *ptr; }
            return y;
        }

        struct c_deleter {
            inline void operator()(void* ptr) { std::free(ptr); }
        };

        template <class T> using c_string = std::unique_ptr<T,c_deleter>;

        inline c_string<char>
        to_c_string(SCM s) {
            return c_string<char>(scm_to_utf8_string(s));
        }

        inline std::string to_string(SCM s) { return std::string(to_c_string(s).get()); }

        inline SCM to_scm(int32_t x) { return scm_from_int32(x); }
        inline SCM to_scm(uint32_t x) { return scm_from_uint32(x); }
        inline SCM to_scm(int64_t x) { return scm_from_int64(x); }
        inline SCM to_scm(uint64_t x) { return scm_from_uint64(x); }
        inline SCM to_scm(float x) { return scm_from_double(x); }
        inline SCM to_scm(double x) { return scm_from_double(x); }
        inline SCM to_scm(const char* x) { return scm_from_utf8_string(x); }
        inline SCM to_scm(const std::string& x) { return to_scm(x.data()); }

        template <class T> T from_scm(SCM x);
        template <> inline bool from_scm<bool>(SCM x) { return scm_is_true(x); }
        template <> inline int from_scm<int>(SCM x) { return scm_to_int(x); }
        template <> inline float from_scm<float>(SCM x) { return scm_to_double(x); }
        template <> inline double from_scm<double>(SCM x) { return scm_to_double(x); }

    }

}

#endif // vim:filetype=cpp