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