45 #ifndef CGU_EXTENSION_H
46 #define CGU_EXTENSION_H
444 #include <type_traits>
446 #include <functional>
462 #include <libguile.h>
465 #ifndef DOXYGEN_PARSING
468 namespace Extension {
475 enum VectorDeleteType {Long, Double, String};
477 struct VectorDeleteArgs {
478 VectorDeleteType type;
484 extern bool init_mutex();
492 inline SCM cgu_format_try_handler(
void* data) {
493 using Cgu::Extension::FormatArgs;
494 FormatArgs* format_args =
static_cast<FormatArgs*
>(data);
495 return scm_simple_format(SCM_BOOL_F, format_args->text, format_args->rest);
497 inline SCM cgu_format_catch_handler(
void*, SCM, SCM) {
500 inline void* cgu_guile_wrapper(
void* data) {
515 inline void cgu_delete_vector(
void* data) {
516 using Cgu::Extension::VectorDeleteArgs;
517 VectorDeleteArgs* args =
static_cast<VectorDeleteArgs*
>(data);
518 switch (args->type) {
519 case Cgu::Extension::Long:
520 delete static_cast<std::vector<long>*
>(args->vec);
522 case Cgu::Extension::Double:
523 delete static_cast<std::vector<double>*
>(args->vec);
525 case Cgu::Extension::String:
526 delete static_cast<std::vector<std::string>*
>(args->vec);
529 g_critical(
"Incorrect argument passed to cgu_delete_vector");
533 inline void cgu_unlock_module_mutex(
void*) {
536 Cgu::Extension::get_user_module_mutex()->unlock();
540 #endif // DOXYGEN_PARSING
544 namespace Extension {
550 virtual const char*
what()
const throw() {
return (
const char*)message.
get();}
551 const char*
guile_text()
const throw() {
return (
const char*)guile_message.
get();}
553 message(g_strdup_printf(
"Cgu::Extension::GuileException: %s", msg)),
554 guile_message(g_strdup(msg)) {}
562 virtual const char*
what()
const throw() {
return (
const char*)message.
get();}
563 const char*
err_text()
const throw() {
return (
const char*)err_message.
get();}
565 message(g_strdup_printf(
"Cgu::Extension::ReturnValueError: %s", msg)),
566 err_message(g_strdup(msg)) {}
573 virtual const char*
what()
const throw() {
return (
const char*)message.
get();}
575 message(g_strdup_printf(
"Cgu::Extension::WrapperError: %s", msg)) {}
579 #ifndef DOXYGEN_PARSING
584 template <
class Ret,
class TransType>
585 void guile_wrapper_cb2(TransType* translator,
589 std::string* guile_except,
590 std::string* guile_ret_val_err,
591 std::string* gen_err,
595 scm = scm_eval_string_in_module(scm_from_utf8_string(loader->c_str()),
596 scm_c_resolve_module(
"guile-user"));
600 throw std::bad_alloc();
602 scm_dynwind_begin(scm_t_dynwind_flags(0));
603 scm_dynwind_unwind_handler(&cgu_unlock_module_mutex, 0, SCM_F_WIND_EXPLICITLY);
604 get_user_module_mutex()->lock();
605 SCM new_mod = scm_call_0(scm_c_public_ref(
"guile",
"make-fresh-user-module"));
608 scm = scm_eval_string_in_module(scm_from_utf8_string(loader->c_str()),
630 #ifndef CGU_GUILE_HAS_BROKEN_LINKING
631 scm_dynwind_begin(scm_t_dynwind_flags(0));
632 scm_dynwind_block_asyncs();
638 bool badalloc =
false;
640 *retval = (*translator)(scm);
670 catch (std::exception& e) {
680 *gen_err =
"C++ exception thrown in guile_wrapper_cb()";
686 #ifndef CGU_GUILE_HAS_BROKEN_LINKING
689 if (badalloc)
throw std::bad_alloc();
692 template <
class Ret,
class Translator>
693 Ret exec_impl(
const std::string& preamble,
694 const std::string& file,
695 Translator translator,
704 loader +=
"((lambda ()";
710 loader +=
"primitive-load \"";
715 "(lambda (key . details)"
716 "(cons \"***cgu-guile-exception***\" (cons key details))))";
723 std::string guile_except;
724 std::string guile_ret_val_err;
747 std::unique_ptr<Cgu::Callback::Callback> cb(
748 Cgu::Callback::lambda<>(std::bind(&guile_wrapper_cb2<Ret, Translator>,
761 if (scm_with_guile(&cgu_guile_wrapper, cb.get()))
762 throw WrapperError(
"cgu_guile_wrapper() has trapped std::bad_alloc");
763 if (!guile_except.empty())
764 throw GuileException(guile_except.c_str());
765 if (!guile_ret_val_err.empty())
766 throw ReturnValueError(guile_ret_val_err.c_str());
767 if (!gen_err.empty())
768 throw WrapperError(gen_err.c_str());
770 throw WrapperError(
"the preamble or translator threw a native guile exception");
774 #endif // DOXYGEN_PARSING
810 SCM ret = SCM_BOOL_F;
811 int length = scm_to_int(scm_length(args));
813 SCM first = scm_car(args);
814 if (scm_is_true(scm_string_p(first))) {
817 ret = scm_string_append(scm_list_4(scm_from_utf8_string(
"Exception "),
818 scm_symbol_to_string(key),
819 scm_from_utf8_string(
": "),
823 SCM second = scm_cadr(args);
824 if (scm_is_true(scm_string_p(second))) {
826 SCM text = scm_string_append(scm_list_n(scm_from_utf8_string(
"Exception "),
827 scm_symbol_to_string(key),
828 scm_from_utf8_string(
" in procedure "),
830 scm_from_utf8_string(
": "),
836 SCM third = scm_caddr(args);
837 if (scm_is_false(third))
839 else if (scm_is_true(scm_list_p(third))) {
840 FormatArgs format_args = {text, third};
841 ret = scm_internal_catch(SCM_BOOL_T,
842 &cgu_format_try_handler,
844 &cgu_format_catch_handler,
854 if (scm_is_false(ret)) {
857 ret = scm_simple_format(SCM_BOOL_F,
858 scm_from_utf8_string(
"Exception ~S: ~S"),
859 scm_list_2(key, args));
892 if (scm_is_false(scm_list_p(scm))
893 || scm_is_true(scm_null_p(scm)))
return;
894 SCM first = scm_car(scm);
895 if (scm_is_true(scm_string_p(first))) {
897 const char* text = 0;
901 scm_dynwind_begin(scm_t_dynwind_flags(0));
902 char* car = scm_to_utf8_stringn(first, &len);
912 scm_dynwind_unwind_handler(&free, car, scm_t_wind_flags(0));
913 if (len == strlen(
"***cgu-guile-exception***")
914 && !strncmp(car,
"***cgu-guile-exception***", len)) {
919 text = scm_to_utf8_stringn(str, &len);
925 std::unique_ptr<char, Cgu::CFree> up_car(car);
926 std::unique_ptr<const char, Cgu::CFree> up_text(text);
973 if (scm_is_false(scm_list_p(scm)))
979 scm_dynwind_begin(scm_t_dynwind_flags(0));
987 bool badalloc =
false;
988 const char* rv_error = 0;
989 std::vector<long>* res = 0;
990 VectorDeleteArgs* args = 0;
996 res =
new std::vector<long>;
999 args =
new VectorDeleteArgs{Long, res};
1014 scm_dynwind_unwind_handler(&cgu_delete_vector, args, scm_t_wind_flags(0));
1020 SCM guile_vec = scm_vector(scm);
1043 size_t length = scm_to_size_t(scm_vector_length(guile_vec));
1045 res->reserve(length);
1050 for (
size_t count = 0;
1051 count < length && !rv_error && !badalloc;
1053 SCM item = scm_vector_ref(guile_vec, scm_from_size_t(count));
1054 if (scm_is_false(scm_integer_p(item)))
1055 rv_error =
"scheme code did not evaluate to a homogeneous list of integer\n";
1057 SCM min = scm_from_long(std::numeric_limits<long>::min());
1058 SCM max = scm_from_long(std::numeric_limits<long>::max());
1059 if (scm_is_false(scm_leq_p(item, max)) || scm_is_false(scm_geq_p(item, min)))
1060 rv_error =
"scheme code evaluated out of range for long\n";
1063 res->push_back(scm_to_long(item));
1076 std::unique_ptr<std::vector<long>> up_res(res);
1077 std::unique_ptr<VectorDeleteArgs> up_args(args);
1078 if (badalloc)
throw std::bad_alloc();
1082 return std::move(*res);
1131 if (scm_is_false(scm_list_p(scm)))
1137 scm_dynwind_begin(scm_t_dynwind_flags(0));
1145 bool badalloc =
false;
1146 const char* rv_error = 0;
1147 std::vector<double>* res = 0;
1148 VectorDeleteArgs* args = 0;
1154 res =
new std::vector<double>;
1157 args =
new VectorDeleteArgs{Double, res};
1172 scm_dynwind_unwind_handler(&cgu_delete_vector, args, scm_t_wind_flags(0));
1178 SCM guile_vec = scm_vector(scm);
1201 size_t length = scm_to_size_t(scm_vector_length(guile_vec));
1203 res->reserve(length);
1208 for (
size_t count = 0;
1209 count < length && !rv_error && !badalloc;
1211 SCM item = scm_vector_ref(guile_vec, scm_from_size_t(count));
1212 if (scm_is_false(scm_real_p(item)))
1213 rv_error =
"scheme code did not evaluate to a homogeneous list of real numbers\n";
1215 SCM min = scm_from_double(-std::numeric_limits<double>::max());
1216 SCM max = scm_from_double(std::numeric_limits<double>::max());
1217 if (scm_is_false(scm_leq_p(item, max)) || scm_is_false(scm_geq_p(item, min)))
1218 rv_error =
"scheme code evaluated out of range for double\n";
1221 res->push_back(scm_to_double(item));
1234 std::unique_ptr<std::vector<double>> up_res(res);
1235 std::unique_ptr<VectorDeleteArgs> up_args(args);
1236 if (badalloc)
throw std::bad_alloc();
1240 return std::move(*res);
1289 if (scm_is_false(scm_list_p(scm)))
1295 scm_dynwind_begin(scm_t_dynwind_flags(0));
1303 bool badalloc =
false;
1304 const char* rv_error = 0;
1305 std::vector<std::string>* res = 0;
1306 VectorDeleteArgs* args = 0;
1312 res =
new std::vector<std::string>;
1315 args =
new VectorDeleteArgs{String, res};
1330 scm_dynwind_unwind_handler(&cgu_delete_vector, args, scm_t_wind_flags(0));
1336 SCM guile_vec = scm_vector(scm);
1359 size_t length = scm_to_size_t(scm_vector_length(guile_vec));
1361 res->reserve(length);
1366 for (
size_t count = 0;
1367 count < length && !rv_error && !badalloc;
1369 SCM item = scm_vector_ref(guile_vec, scm_from_size_t(count));
1370 if (scm_is_false(scm_string_p(item)))
1371 rv_error =
"scheme code did not evaluate to a homogeneous list of string\n";
1377 char* str = scm_to_utf8_stringn(item, &len);
1379 res->emplace_back(str, len);
1392 std::unique_ptr<std::vector<std::string>> up_res(res);
1393 std::unique_ptr<VectorDeleteArgs> up_args(args);
1394 if (badalloc)
throw std::bad_alloc();
1398 return std::move(*res);
1437 if (scm_is_false(scm_integer_p(scm)))
1439 SCM min = scm_from_long(std::numeric_limits<long>::min());
1440 SCM max = scm_from_long(std::numeric_limits<long>::max());
1441 if (scm_is_false(scm_leq_p(scm, max)) || scm_is_false(scm_geq_p(scm, min)))
1443 return scm_to_long(scm);
1487 if (scm_is_false(scm_real_p(scm)))
1489 SCM min = scm_from_double(-std::numeric_limits<double>::max());
1490 SCM max = scm_from_double(std::numeric_limits<double>::max());
1491 if (scm_is_false(scm_leq_p(scm, max)) || scm_is_false(scm_geq_p(scm, min)))
1493 return scm_to_double(scm);
1533 if (scm_is_false(scm_string_p(scm)))
1539 std::unique_ptr<const char, Cgu::CFree> s(scm_to_utf8_stringn(scm, &len));
1540 return std::string(s.get(), len);
1666 template <
class Translator>
1667 auto exec(
const std::string& preamble,
1668 const std::string& file,
1669 Translator translator) ->
typename std::result_of<Translator(SCM)>::type {
1673 typedef typename std::result_of<Translator(SCM)>::type Ret;
1674 return exec_impl<Ret>(preamble, file, translator,
false);
1758 template <
class Translator>
1760 const std::string& file,
1761 Translator translator) ->
typename std::result_of<Translator(SCM)>::type {
1765 typedef typename std::result_of<Translator(SCM)>::type Ret;
1766 return exec_impl<Ret>(preamble, file, translator,
true);
1773 #endif // CGU_EXTENSION_H
std::vector< long > list_to_vector_long(SCM scm)
Definition: extension.h:971
GuileException(const char *msg)
Definition: extension.h:552
long integer_to_long(SCM scm)
Definition: extension.h:1435
~ReturnValueError()
Definition: extension.h:567
~GuileException()
Definition: extension.h:555
const char * err_text() const
Definition: extension.h:563
void * any_to_void(SCM scm)
Definition: extension.h:1578
auto exec(const std::string &preamble, const std::string &file, Translator translator) -> typename std::result_of< Translator(SCM)>::type
Definition: extension.h:1667
WrapperError(const char *msg)
Definition: extension.h:574
This file provides classes for type erasure.
Definition: extension.h:558
A class enabling the cancellation state of a thread to be controlled.
Definition: thread.h:681
double real_to_double(SCM scm)
Definition: extension.h:1485
Definition: extension.h:546
std::string string_to_string(SCM scm)
Definition: extension.h:1531
std::vector< double > list_to_vector_double(SCM scm)
Definition: extension.h:1129
auto exec_shared(const std::string &preamble, const std::string &file, Translator translator) -> typename std::result_of< Translator(SCM)>::type
Definition: extension.h:1759
virtual const char * what() const
Definition: extension.h:573
T get() const
Definition: shared_handle.h:762
A wrapper class for pthread mutexes.
Definition: mutex.h:117
Provides wrapper classes for pthread mutexes and condition variables, and scoped locking classes for ...
Definition: application.h:44
SCM exception_to_string(SCM key, SCM args)
Definition: extension.h:803
std::vector< std::string > list_to_vector_string(SCM scm)
Definition: extension.h:1287
Definition: extension.h:570
virtual const char * what() const
Definition: extension.h:562
~WrapperError()
Definition: extension.h:576
virtual const char * what() const
Definition: extension.h:550
void rethrow_guile_exception(SCM scm)
Definition: extension.h:889
ReturnValueError(const char *msg)
Definition: extension.h:564
The callback interface class.
Definition: callback.h:522
const char * guile_text() const
Definition: extension.h:551