Feature remove redundant declarations (#199)

Author: sbearrows

NEWS.md

@@ -1,4 +1,5 @@
 # cpp11 (development version)
+* Removed redundant `.Call calls` in cpp11.cpp file (@sbearrows, #170)
 * Allow cpp11 decorators of the form `cpp11::linking_to` (@sbearrows, #193)
 
 # cpp11 0.3.1
@@ -7,6 +8,7 @@
 
 # cpp11 0.3.0
 
+
 ## New functions and features
 * New `x.empty()` method to check if a vector is empty (@sbearrows, #182)
 * New `x.named()` method to check if a vector is named (@sbearrows, #186)

R/register.R

@@ -70,7 +70,8 @@ cpp_register <- function(path = ".", quiet = FALSE) {
     cli::cli_alert_success("generated file {.file {basename(r_path)}}")
   }
 
-  call_entries <- get_call_entries(path)
+
+  call_entries <- get_call_entries(path, funs$name, package)
 
   cpp_function_registration <- glue::glue_data(funs, '    {{
     "_cpp11_{name}", (DL_FUNC) &_{package}_{name}, {n_args}}}, ',
@@ -244,7 +245,7 @@ wrap_call <- function(name, return_type, args) {
   }
 }
 
-get_call_entries <- function(path) {
+get_call_entries <- function(path, names, package) {
   con <- textConnection("res", local = TRUE, open = "w")
 
   withr::with_collate("C",
@@ -258,12 +259,31 @@ get_call_entries <- function(path) {
   close(con)
 
   start <- grep("/* .Call calls */", res, fixed = TRUE)
+
   end <- grep("};", res, fixed = TRUE)
 
   if (length(start) == 0) {
     return("")
   }
-  res[seq(start, end)]
+
+  redundant <- glue::glue_collapse(glue::glue('extern SEXP _{package}_{names}'), sep = '|')
+
+  if (length(redundant) > 0) {
+    redundant <- paste0("^", redundant)
+    res <- res[!grepl(redundant, res)]
+  }
+
+  end <- grep("};", res, fixed = TRUE)
+
+  call_calls <- startsWith(res, "extern SEXP")
+
+  if(any(call_calls)) {
+    return(res[seq(start, end)])
+  }
+
+  mid <- grep("static const R_CallMethodDef CallEntries[] = {", res, fixed = TRUE)
+
+  res[seq(mid, end)]
 }
 
 pkg_links_to_rcpp <- function(path) {

tests/testthat/helper.R

@@ -12,6 +12,15 @@ pkg_path <- function(pkg) {
   dirname(pkg$.__enclos_env__$private$path)
 }
 
+get_funs <- function(path) {
+  all_decorations <- decor::cpp_decorations(path, is_attribute = TRUE)
+  get_registered_functions(all_decorations, "cpp11::register", quiet = FALSE)
+}
+
+get_package_name <- function(path) {
+  desc::desc_get("Package", file = file.path(path, "DESCRIPTION"))
+}
+
 glue_str <- function(...) {
   glue::as_glue(unlist(list(...)))
 }

tests/testthat/test-register.R

@@ -25,14 +25,16 @@ describe("pkg_links_to_rcpp", {
 describe("get_call_entries", {
   it("returns an empty string if there are no R files", {
     pkg <- local_package()
-    expect_equal(get_call_entries(pkg_path(pkg)), "")
+    path <- pkg_path(pkg)
+    expect_equal(get_call_entries(path, get_funs(path)$name, get_package_name(path)), "")
   })
 
   it("returns an empty string if there are no .Call calls", {
     pkg <- local_package()
-    dir.create(file.path(pkg_path(pkg), "R"))
-    writeLines("foo <- function() 1", file.path(pkg_path(pkg), "R", "foo.R"))
-    expect_equal(get_call_entries(pkg_path(pkg)), "")
+    path <- pkg_path(pkg)
+    dir.create(file.path(path, "R"))
+    writeLines("foo <- function() 1", file.path(path, "R", "foo.R"))
+    expect_equal(get_call_entries(path, get_funs(path)$name, get_package_name(path)), "")
   })
 
   it("Errors for invalid packages", {
@@ -44,7 +46,7 @@ describe("get_call_entries", {
     writeLines("Package: testPkg", file.path(pkg, "DESCRIPTION"))
     dir.create(file.path(pkg, "R"))
     writeLines('foo <- function() .Call("bar")', file.path(pkg, "R", "foo.R"))
-    expect_error(get_call_entries(pkg), "has no 'NAMESPACE' file")
+    expect_error(get_call_entries(pkg, get_funs(path)$name, get_package_name(pkg)), "has no 'NAMESPACE' file")
   })
 
   it("returns an empty string for packages with .Call entries and NAMESPACE files", {
@@ -53,10 +55,11 @@ describe("get_call_entries", {
     skip_if(getRversion() < "3.4")
 
     pkg <- local_package()
-    dir.create(file.path(pkg_path(pkg), "R"))
-    writeLines('foo <- function() .Call("bar")', file.path(pkg_path(pkg), "R", "foo.R"))
+    path <- pkg_path(pkg)
+    dir.create(file.path(path, "R"))
+    writeLines('foo <- function() .Call("bar")', file.path(path, "R", "foo.R"))
     expect_equal(
-      get_call_entries(pkg_path(pkg)),
+      get_call_entries(path, get_funs(path)$name, get_package_name(path)),
       c("/* .Call calls */",
         "extern SEXP bar();",
         "",
@@ -67,6 +70,59 @@ describe("get_call_entries", {
       )
     )
   })
+  it("works with multiple register functions.", {
+    pkg <- local_package()
+    p <- pkg_path(pkg)
+    dir.create(file.path(p, "src"))
+    file.copy(test_path("multiple.cpp"), file.path(p, "src", "multiple.cpp"))
+
+    cpp_register(p)
+    cpp_bindings <- file.path(p, "src", "cpp11.cpp")
+    expect_equal(read_file(cpp_bindings),
+                 "// Generated by cpp11: do not edit by hand
+// clang-format off
+
+
+#include \"cpp11/declarations.hpp\"
+
+// multiple.cpp
+int foo();
+extern \"C\" SEXP _testPkg_foo() {
+  BEGIN_CPP11
+    return cpp11::as_sexp(foo());
+  END_CPP11
+}
+// multiple.cpp
+double bar(bool run);
+extern \"C\" SEXP _testPkg_bar(SEXP run) {
+  BEGIN_CPP11
+    return cpp11::as_sexp(bar(cpp11::as_cpp<cpp11::decay_t<bool>>(run)));
+  END_CPP11
+}
+// multiple.cpp
+bool baz(bool run, int value);
+extern \"C\" SEXP _testPkg_baz(SEXP run, SEXP value) {
+  BEGIN_CPP11
+    return cpp11::as_sexp(baz(cpp11::as_cpp<cpp11::decay_t<bool>>(run), cpp11::as_cpp<cpp11::decay_t<int>>(value)));
+  END_CPP11
+}
+
+extern \"C\" {
+static const R_CallMethodDef CallEntries[] = {
+    {\"_testPkg_bar\", (DL_FUNC) &_testPkg_bar, 1},
+    {\"_testPkg_baz\", (DL_FUNC) &_testPkg_baz, 2},
+    {\"_testPkg_foo\", (DL_FUNC) &_testPkg_foo, 0},
+    {NULL, NULL, 0}
+};
+}
+
+extern \"C\" void R_init_testPkg(DllInfo* dll){
+  R_registerRoutines(dll, NULL, CallEntries, NULL, NULL);
+  R_useDynamicSymbols(dll, FALSE);
+  R_forceSymbols(dll, TRUE);
+}
+")
+  })
 })
 
 describe("wrap_call", {
@@ -533,9 +589,6 @@ extern \"C\" SEXP _testPkg_foo() {
 }
 
 extern \"C\" {
-/* .Call calls */
-extern SEXP _testPkg_foo();
-
 static const R_CallMethodDef CallEntries[] = {
     {\"_testPkg_foo\", (DL_FUNC) &_testPkg_foo, 0},
     {NULL, NULL, 0}