diff --git a/R/register.R b/R/register.R index 14fa88cb..2a25a405 100644 --- a/R/register.R +++ b/R/register.R @@ -61,6 +61,18 @@ cpp_register <- function(path = ".", quiet = FALSE) { r_functions <- generate_r_functions(funs, package, use_package = FALSE) + ex_funs <- get_registered_functions(all_decorations, "cpp11::external", quiet) + ex_fun_registration <- "" + ex_declarations <- "" + + if (nrow(ex_funs) > 0) { + ex_fun_registration <- glue::glue_collapse(sprintf("\n %s", glue::glue_data(ex_funs, + 'R_RegisterCCallable("{package}", "_{package}_ex_{name}", (DL_FUNC) {name});' + ))) + ex_declarations <- generate_ex_declarations(ex_funs) + generate_ex_header(path, ex_funs, package, quiet = quiet) + } + dir.create(dirname(r_path), recursive = TRUE, showWarnings = FALSE) brio::write_lines(path = r_path, glue::glue(' @@ -118,10 +130,10 @@ cpp_register <- function(path = ".", quiet = FALSE) { extern "C" {{ {call_entries} }} - {init$declarations} + {init$declarations}{ex_declarations} extern "C" attribute_visible void R_init_{package}(DllInfo* dll){{ R_registerRoutines(dll, NULL, CallEntries, NULL, NULL); - R_useDynamicSymbols(dll, FALSE);{init$calls} + R_useDynamicSymbols(dll, FALSE);{ex_fun_registration}{init$calls} R_forceSymbols(dll, TRUE); }} ', @@ -158,6 +170,94 @@ get_registered_functions <- function(decorations, tag, quiet = FALSE) { out } +generate_ex_declarations <- function(funs) { + funs <- funs[c("name", "return_type", "args", "file", "line", "decoration")] + funs$real_params <- vcapply(funs$args, glue_collapse_data, "{type} {name}") + funs$sexp_params <- vcapply(funs$args, glue_collapse_data, "SEXP {name}") + funs$calls <- mapply(wrap_call, funs$name, funs$return_type, funs$args, SIMPLIFY = TRUE) + + out <- paste0("\n", glue::glue_collapse(glue::glue_data(funs, + '{return_type} {name}({real_params}); // {basename(file)}\n\n' + ))) + unclass(out) +} + +ex_params_call <- function(params) { + ex <- function(name="", comment="") { + list( + name = name, + comment = comment + ) + } + if (is.list(params)) do.call(ex, params) else ex() +} + +generate_ex_header <- function(path, funs, package, quiet = FALSE) { + ex_path <- file.path(path, "inst", "include", glue::glue("{package}_api.h")) + unlink(ex_path) + dir.create(dirname(ex_path), recursive = TRUE, showWarnings = FALSE) + + ex_types <- c( + file.path(path, "inst", "include", paste0(package, "_types.h")), + file.path(path, "inst", "include", paste0(package, "_types.hpp")) + ) + ex_types <- ex_types[file.exists(ex_types)] + + ex_types_import <- if (length(ex_types) > 0) { + paste0("\n", glue::glue_collapse(glue::glue( + '\n\n#include <{ex_type_file}>', + ex_type_file = basename(ex_types) + ))) + } else { + "" + } + + header_guard <- glue::glue("{package_upper}_EXTERNAL_API_H", package_upper=toupper(package)) + + funs$real_params <- vcapply(funs$args, glue_collapse_data, "{type} {name}") + funs$types_params <- vcapply(funs$args, glue_collapse_data, "{type}") + funs$names_params <- vcapply(funs$args, glue_collapse_data, "{name}") + funs$ex_params <- lapply(funs$params, ex_params_call) + funs$ex_params_name <- vapply(funs$ex_params, `[[`, character(1), "name") + funs$ex_params_comment <- vapply(funs$ex_params, `[[`, character(1), "comment") + + call_entries <- glue::glue_data(funs, + ' + {comment}static inline {return_type} {export_name}({real_params}) {{ + static {return_type}(*p_{name})({types_params}) = NULL; + if (p_{name} == NULL) {{ + p_{name} = ({return_type}(*)({types_params})) R_GetCCallable("{package}", "_{package}_ex_{name}"); + }} + return p_{name}({names_params}); + }} + ', + export_name = ifelse(nchar(ex_params_name), ex_params_name, name), + comment = ifelse(nchar(ex_params_comment), sprintf("// %s\n", ex_params_comment), "") + ) + + brio::write_lines(path = ex_path, glue::glue(' + // Generated by cpp11: do not edit by hand + // clang-format off + + #ifndef {header_guard} + #define {header_guard} + + #define R_NO_REMAP + #include + #include {ex_types_import} + + {call_entries} + + #endif // {header_guard} + ', + call_entries = glue::glue_collapse(call_entries, "\n\n") + )) + + if (!quiet) { + cli::cli_alert_success("generated file {.file {basename(ex_path)}}") + } +} + generate_cpp_functions <- function(funs, package = "cpp11") { funs <- funs[c("name", "return_type", "args", "file", "line", "decoration")] funs$real_params <- vcapply(funs$args, glue_collapse_data, "{type} {name}") @@ -303,8 +403,9 @@ get_cpp_register_needs <- function() { check_valid_attributes <- function(decorations, file = decorations$file) { + valid_decor <- c("cpp11::register", "cpp11::init", "cpp11::linking_to", "cpp11::external") bad_decor <- startsWith(decorations$decoration, "cpp11::") & - (!decorations$decoration %in% c("cpp11::register", "cpp11::init", "cpp11::linking_to")) + (!decorations$decoration %in% valid_decor) if(any(bad_decor)) { lines <- decorations$line[bad_decor] @@ -312,9 +413,9 @@ check_valid_attributes <- function(decorations, file = decorations$file) { bad_lines <- glue::glue_collapse(glue::glue("- Invalid attribute `{names}` on line {lines} in file '{file}'."), "\n") - msg <- glue::glue("cpp11 attributes must be one of `cpp11::register`, `cpp11::init` or `cpp11::linking_to`: + msg <- glue::glue("cpp11 attributes must be one of {msg_valid}: {bad_lines} - ") + ", msg_valid = glue::glue_collapse(valid_decor, sep = ", ")) stop(msg, call. = FALSE) }