45 #ifndef CGU_EXTENSION_H
46 #define CGU_EXTENSION_H
432 #include <type_traits>
449 #include <libguile.h>
452 #ifndef DOXYGEN_PARSING
455 namespace Extension {
462 enum VectorDeleteType {Long, Double, String};
464 struct VectorDeleteArgs {
465 VectorDeleteType type;
471 extern bool init_mutex() noexcept;
479 inline SCM cgu_format_try_handler(
void* data) {
480 using Cgu::Extension::FormatArgs;
481 FormatArgs* format_args =
static_cast<FormatArgs*
>(data);
482 return scm_simple_format(SCM_BOOL_F, format_args->text, format_args->rest);
484 inline SCM cgu_format_catch_handler(
void*, SCM, SCM) {
487 inline void* cgu_guile_wrapper(
void* data) {
502 inline void cgu_delete_vector(
void* data) {
503 using Cgu::Extension::VectorDeleteArgs;
504 VectorDeleteArgs* args =
static_cast<VectorDeleteArgs*
>(data);
505 switch (args->type) {
506 case Cgu::Extension::Long:
507 delete static_cast<std::vector<long>*
>(args->vec);
509 case Cgu::Extension::Double:
510 delete static_cast<std::vector<double>*
>(args->vec);
512 case Cgu::Extension::String:
513 delete static_cast<std::vector<std::string>*
>(args->vec);
516 g_critical(
"Incorrect argument passed to cgu_delete_vector");
520 inline void cgu_unlock_module_mutex(
void*) {
523 Cgu::Extension::get_user_module_mutex()->unlock();
527 #endif // DOXYGEN_PARSING
531 namespace Extension {
537 virtual const char*
what()
const throw() {
return (
const char*)message.
get();}
538 const char*
guile_text()
const throw() {
return (
const char*)guile_message.
get();}
540 message(g_strdup_printf(u8
"Cgu::Extension::GuileException: %s", msg)),
541 guile_message(g_strdup(msg)) {}
549 virtual const char*
what()
const throw() {
return (
const char*)message.
get();}
550 const char*
err_text()
const throw() {
return (
const char*)err_message.
get();}
552 message(g_strdup_printf(u8
"Cgu::Extension::ReturnValueError: %s", msg)),
553 err_message(g_strdup(msg)) {}
560 virtual const char*
what()
const throw() {
return (
const char*)message.
get();}
562 message(g_strdup_printf(u8
"Cgu::Extension::WrapperError: %s", msg)) {}
566 #ifndef DOXYGEN_PARSING
573 template <
class Ret,
class Translator>
574 Ret exec_impl(
const std::string& preamble,
575 const std::string& file,
576 Translator&& translator,
585 loader += u8
"((lambda ()";
586 loader += u8
"(catch "
591 loader += u8
"primitive-load \"";
593 loader += u8
"load \"";
596 "(lambda (key . details)"
597 "(cons \"***cgu-guile-exception***\" (cons key details))))";
604 std::string guile_except;
605 std::string guile_ret_val_err;
628 std::unique_ptr<Cgu::Callback::Callback> cb(Cgu::Callback::lambda<>([&] () ->
void {
631 scm = scm_eval_string_in_module(scm_from_utf8_string(loader.c_str()),
632 scm_c_resolve_module(
"guile-user"));
636 throw std::bad_alloc();
638 scm_dynwind_begin(scm_t_dynwind_flags(0));
639 scm_dynwind_unwind_handler(&cgu_unlock_module_mutex, 0, SCM_F_WIND_EXPLICITLY);
640 get_user_module_mutex()->lock();
650 SCM new_mod = scm_call_0(scm_c_public_ref(
"guile",
"make-fresh-user-module"));
651 #if SCM_MAJOR_VERSION >= 3
652 scm_call_2(scm_c_public_ref(
"guile",
"set-module-declarative?!"),
653 new_mod, SCM_BOOL_F);
657 scm = scm_eval_string_in_module(scm_from_utf8_string(loader.c_str()),
681 #ifndef CGU_GUILE_HAS_BROKEN_LINKING
682 scm_dynwind_begin(scm_t_dynwind_flags(0));
683 scm_dynwind_block_asyncs();
690 bool badalloc =
false;
692 retval = translator(scm);
708 catch (GuileException& e) {
710 guile_except = e.guile_text();
716 catch (ReturnValueError& e) {
718 guile_ret_val_err = e.err_text();
724 catch (std::exception& e) {
734 gen_err = u8
"C++ exception thrown in cgu_guile_wrapper()";
740 #ifndef CGU_GUILE_HAS_BROKEN_LINKING
743 if (badalloc)
throw std::bad_alloc();
748 if (scm_with_guile(&cgu_guile_wrapper, cb.get()))
749 throw WrapperError(u8
"cgu_guile_wrapper() has trapped std::bad_alloc");
750 if (!guile_except.empty())
751 throw GuileException(guile_except.c_str());
752 if (!guile_ret_val_err.empty())
753 throw ReturnValueError(guile_ret_val_err.c_str());
754 if (!gen_err.empty())
755 throw WrapperError(gen_err.c_str());
757 throw WrapperError(u8
"the preamble or translator threw a native guile exception");
761 #endif // DOXYGEN_PARSING
797 SCM ret = SCM_BOOL_F;
798 int length = scm_to_int(scm_length(args));
800 SCM first = scm_car(args);
801 if (scm_is_true(scm_string_p(first))) {
804 ret = scm_string_append(scm_list_4(scm_from_utf8_string(u8
"Exception "),
805 scm_symbol_to_string(key),
806 scm_from_utf8_string(u8
": "),
810 SCM second = scm_cadr(args);
811 if (scm_is_true(scm_string_p(second))) {
813 SCM text = scm_string_append(scm_list_n(scm_from_utf8_string(u8
"Exception "),
814 scm_symbol_to_string(key),
815 scm_from_utf8_string(u8
" in procedure "),
817 scm_from_utf8_string(u8
": "),
823 SCM third = scm_caddr(args);
824 if (scm_is_false(third))
826 else if (scm_is_true(scm_list_p(third))) {
827 FormatArgs format_args = {text, third};
828 ret = scm_internal_catch(SCM_BOOL_T,
829 &cgu_format_try_handler,
831 &cgu_format_catch_handler,
841 if (scm_is_false(ret)) {
844 ret = scm_simple_format(SCM_BOOL_F,
845 scm_from_utf8_string(u8
"Exception ~S: ~S"),
846 scm_list_2(key, args));
879 if (scm_is_false(scm_list_p(scm))
880 || scm_is_true(scm_null_p(scm)))
return;
881 SCM first = scm_car(scm);
882 if (scm_is_true(scm_string_p(first))) {
884 const char* text = 0;
888 scm_dynwind_begin(scm_t_dynwind_flags(0));
889 char* car = scm_to_utf8_stringn(first, &len);
899 scm_dynwind_unwind_handler(&free, car, scm_t_wind_flags(0));
900 if (len == strlen(u8
"***cgu-guile-exception***")
901 && !strncmp(car, u8
"***cgu-guile-exception***", len)) {
906 text = scm_to_utf8_stringn(str, &len);
912 std::unique_ptr<char, Cgu::CFree> up_car(car);
913 std::unique_ptr<const char, Cgu::CFree> up_text(text);
961 if (scm_is_false(scm_list_p(scm)))
967 scm_dynwind_begin(scm_t_dynwind_flags(0));
975 bool badalloc =
false;
976 const char* rv_error = 0;
977 std::vector<long>* res = 0;
978 VectorDeleteArgs* args = 0;
984 res =
new std::vector<long>;
987 args =
new VectorDeleteArgs{Long, res};
1002 scm_dynwind_unwind_handler(&cgu_delete_vector, args, scm_t_wind_flags(0));
1008 SCM guile_vec = scm_vector(scm);
1031 size_t length = scm_to_size_t(scm_vector_length(guile_vec));
1033 res->reserve(length);
1038 for (
size_t count = 0;
1039 count < length && !rv_error && !badalloc;
1041 SCM item = scm_vector_ref(guile_vec, scm_from_size_t(count));
1042 if (scm_is_false(scm_integer_p(item)))
1043 rv_error = u8
"scheme code did not evaluate to a homogeneous list of integer\n";
1045 SCM min = scm_from_long(std::numeric_limits<long>::min());
1046 SCM max = scm_from_long(std::numeric_limits<long>::max());
1047 if (scm_is_false(scm_leq_p(item, max)) || scm_is_false(scm_geq_p(item, min)))
1048 rv_error = u8
"scheme code evaluated out of range for long\n";
1051 res->push_back(scm_to_long(item));
1064 std::unique_ptr<std::vector<long>> up_res(res);
1065 std::unique_ptr<VectorDeleteArgs> up_args(args);
1066 if (badalloc)
throw std::bad_alloc();
1070 return std::move(*res);
1120 if (scm_is_false(scm_list_p(scm)))
1126 scm_dynwind_begin(scm_t_dynwind_flags(0));
1134 bool badalloc =
false;
1135 const char* rv_error = 0;
1136 std::vector<double>* res = 0;
1137 VectorDeleteArgs* args = 0;
1143 res =
new std::vector<double>;
1146 args =
new VectorDeleteArgs{Double, res};
1161 scm_dynwind_unwind_handler(&cgu_delete_vector, args, scm_t_wind_flags(0));
1167 SCM guile_vec = scm_vector(scm);
1190 size_t length = scm_to_size_t(scm_vector_length(guile_vec));
1192 res->reserve(length);
1197 for (
size_t count = 0;
1198 count < length && !rv_error && !badalloc;
1200 SCM item = scm_vector_ref(guile_vec, scm_from_size_t(count));
1201 if (scm_is_false(scm_real_p(item)))
1202 rv_error = u8
"scheme code did not evaluate to a homogeneous list of real numbers\n";
1204 SCM min = scm_from_double(std::numeric_limits<double>::lowest());
1205 SCM max = scm_from_double(std::numeric_limits<double>::max());
1206 if (scm_is_false(scm_leq_p(item, max)) || scm_is_false(scm_geq_p(item, min)))
1207 rv_error = u8
"scheme code evaluated out of range for double\n";
1210 res->push_back(scm_to_double(item));
1223 std::unique_ptr<std::vector<double>> up_res(res);
1224 std::unique_ptr<VectorDeleteArgs> up_args(args);
1225 if (badalloc)
throw std::bad_alloc();
1229 return std::move(*res);
1280 if (scm_is_false(scm_list_p(scm)))
1286 scm_dynwind_begin(scm_t_dynwind_flags(0));
1294 bool badalloc =
false;
1295 const char* rv_error = 0;
1296 std::vector<std::string>* res = 0;
1297 VectorDeleteArgs* args = 0;
1303 res =
new std::vector<std::string>;
1306 args =
new VectorDeleteArgs{String, res};
1321 scm_dynwind_unwind_handler(&cgu_delete_vector, args, scm_t_wind_flags(0));
1327 SCM guile_vec = scm_vector(scm);
1350 size_t length = scm_to_size_t(scm_vector_length(guile_vec));
1352 res->reserve(length);
1357 for (
size_t count = 0;
1358 count < length && !rv_error && !badalloc;
1360 SCM item = scm_vector_ref(guile_vec, scm_from_size_t(count));
1361 if (scm_is_false(scm_string_p(item)))
1362 rv_error = u8
"scheme code did not evaluate to a homogeneous list of string\n";
1368 char* str = scm_to_utf8_stringn(item, &len);
1370 res->emplace_back(str, len);
1383 std::unique_ptr<std::vector<std::string>> up_res(res);
1384 std::unique_ptr<VectorDeleteArgs> up_args(args);
1385 if (badalloc)
throw std::bad_alloc();
1389 return std::move(*res);
1429 if (scm_is_false(scm_integer_p(scm)))
1431 SCM min = scm_from_long(std::numeric_limits<long>::min());
1432 SCM max = scm_from_long(std::numeric_limits<long>::max());
1433 if (scm_is_false(scm_leq_p(scm, max)) || scm_is_false(scm_geq_p(scm, min)))
1435 return scm_to_long(scm);
1481 if (scm_is_false(scm_real_p(scm)))
1482 throw ReturnValueError(u8
"scheme code did not evaluate to a real number\n");
1483 SCM min = scm_from_double(std::numeric_limits<double>::lowest());
1484 SCM max = scm_from_double(std::numeric_limits<double>::max());
1485 if (scm_is_false(scm_leq_p(scm, max)) || scm_is_false(scm_geq_p(scm, min)))
1486 throw ReturnValueError(u8
"scheme code evaluated out of range for double\n");
1487 return scm_to_double(scm);
1529 if (scm_is_false(scm_string_p(scm)))
1535 std::unique_ptr<const char, Cgu::CFree> s(scm_to_utf8_stringn(scm, &len));
1536 return std::string(s.get(), len);
1658 template <
class Translator>
1659 auto exec(
const std::string& preamble,
1660 const std::string& file,
1661 Translator&& translator) ->
typename std::result_of<Translator(SCM)>::type {
1665 typedef typename std::result_of<Translator(SCM)>::type Ret;
1666 return exec_impl<Ret>(preamble, file, std::forward<Translator>(translator),
false);
1746 template <
class Translator>
1748 const std::string& file,
1749 Translator&& translator) ->
typename std::result_of<Translator(SCM)>::type {
1753 typedef typename std::result_of<Translator(SCM)>::type Ret;
1754 return exec_impl<Ret>(preamble, file, std::forward<Translator>(translator),
true);
1761 #endif // CGU_EXTENSION_H