1 files changed, 153 insertions, 0 deletions
diff --git a/third_party/immer/extra/guile/scm/type.hpp b/third_party/immer/extra/guile/scm/type.hpp
new file mode 100644
index 0000000000..da53ed46ef
--- /dev/null
+++ b/third_party/immer/extra/guile/scm/type.hpp
@@ -0,0 +1,153 @@
+//
+// immer: immutable data structures for C++
+// Copyright (C) 2016, 2017, 2018 Juan Pedro Bolivar Puente
+//
+// This software is distributed under the Boost Software License, Version 1.0.
+// See accompanying file LICENSE or copy at http://boost.org/LICENSE_1_0.txt
+//
+
+#pragma once
+
+#include <scm/detail/finalizer_wrapper.hpp>
+#include <scm/detail/define.hpp>
+#include <string>
+
+namespace scm {
+namespace detail {
+
+template <typename T>
+struct foreign_type_storage
+{
+    static SCM data;
+};
+
+template <typename T>
+SCM foreign_type_storage<T>::data = SCM_UNSPECIFIED;
+
+template <typename T>
+struct convert_foreign_type
+{
+    using storage_t = foreign_type_storage<T>;
+    static T& to_cpp(SCM v)
+    {
+        assert(storage_t::data != SCM_UNSPECIFIED &&
+               "can not convert to undefined type");
+        scm_assert_foreign_object_type(storage_t::data, v);
+        return *(T*)scm_foreign_object_ref(v, 0);
+    }
+
+    template <typename U>
+    static SCM to_scm(U&& v)
+    {
+        assert(storage_t::data != SCM_UNSPECIFIED &&
+               "can not convert from undefined type");
+        return scm_make_foreign_object_1(
+            storage_t::data,
+            new (scm_gc_malloc(sizeof(T), "scmpp")) T(
+                std::forward<U>(v)));
+    }
+};
+
+// Assume that every other type is foreign
+template <typename T>
+struct convert<T,
+               std::enable_if_t<!std::is_fundamental<T>::value &&
+                                // only value types are supported at
+                                // the moment but the story might
+                                // change later...
+                                !std::is_pointer<T>::value>>
+    : convert_foreign_type<T>
+{
+};
+
+template <typename Tag, typename T, int Seq=0>
+struct type_definer : move_sequence
+{
+    using this_t = type_definer;
+    using next_t = type_definer<Tag, T, Seq + 1>;
+
+    std::string type_name_ = {};
+    scm_t_struct_finalize finalizer_ = nullptr;
+
+    type_definer(type_definer&&) = default;
+
+    type_definer(std::string type_name)
+        : type_name_(std::move(type_name))
+    {}
+
+    ~type_definer()
+    {
+        if (!moved_from_) {
+            using storage_t = detail::foreign_type_storage<T>;
+            assert(storage_t::data == SCM_UNSPECIFIED);
+            storage_t::data = scm_make_foreign_object_type(
+                scm_from_utf8_symbol(("<" + type_name_ + ">").c_str()),
+                scm_list_1(scm_from_utf8_symbol("data")),
+                finalizer_);
+        }
+    }
+
+    template <int Seq2, typename Enable=std::enable_if_t<Seq2 + 1 == Seq>>
+    type_definer(type_definer<Tag, T, Seq2> r)
+        : move_sequence{std::move(r)}
+        , type_name_{std::move(r.type_name_)}
+        , finalizer_{std::move(r.finalizer_)}
+    {}
+
+    next_t constructor() &&
+    {
+        define_impl<this_t>(type_name_, [] { return T{}; });
+        return { std::move(*this) };
+    }
+
+    template <typename Fn>
+    next_t constructor(Fn fn) &&
+    {
+        define_impl<this_t>(type_name_, fn);
+        return { std::move(*this) };
+    }
+
+    next_t finalizer() &&
+    {
+        finalizer_ = (scm_t_struct_finalize) +finalizer_wrapper<Tag>(
+            [] (T& x) { x.~T(); });
+        return { std::move(*this) };
+    }
+
+    template <typename Fn>
+    next_t finalizer(Fn fn) &&
+    {
+        finalizer_ = (scm_t_struct_finalize) +finalizer_wrapper<Tag>(fn);
+        return { std::move(*this) };
+    }
+
+    next_t maker() &&
+    {
+        define_impl<this_t>("make-" + type_name_, [] { return T{}; });
+        return { std::move(*this) };
+    }
+
+    template <typename Fn>
+    next_t maker(Fn fn) &&
+    {
+        define_impl<this_t>("make-" + type_name_, fn);
+        return { std::move(*this) };
+    }
+
+    template <typename Fn>
+    next_t define(std::string name, Fn fn) &&
+    {
+        define_impl<this_t>(type_name_ + "-" + name, fn);
+        return { std::move(*this) };
+    }
+};
+
+} // namespace detail
+
+template <typename Tag, typename T=Tag>
+detail::type_definer<Tag, T> type(std::string type_name)
+{
+    return { type_name };
+}
+
+} // namespace scm