Redefining tsk_bug_assert to use Rcpp::stop or Rf_error #5

Author: gregorgorjanc

tskitr/R/RcppExports.R

@@ -1,6 +1,14 @@
 # Generated by using Rcpp::compileAttributes() -> do not edit by hand
 # Generator token: 10BE3573-1514-4C36-9D1C-5A225CD40393
 
+test_tsk_bug_assert_c <- function() {
+    invisible(.Call(`_tskitr_test_tsk_bug_assert_c`))
+}
+
+test_tsk_bug_assert_cpp <- function() {
+    invisible(.Call(`_tskitr_test_tsk_bug_assert_cpp`))
+}
+
 #' Report the version of installed kastore C API
 #'
 #' @details The version is stored in the installed header \code{kastore.h}.

tskitr/inst/include/tskit/core.h

@@ -1,2 +1,29 @@
 // Shim header to use tskit C API in Rcpp code in an R session or an R package
 #include <tskit/tskit/core.h>
+
+// Redefinition of tsk_bug_assert to avoid aborting R sessions with tskit C API
+// (following R extensions manual recommendations).
+// While tsk_bug_assert is called only in C API (atm) we provide both C and C++
+// macros for completeness.
+// TODO: Redefine TSK_BUG_ASSERT_MESSAGE or create tskitr version if we will use
+//       tsk_bug_assert in Rcpp. Will not, yet, open GitHub issue at this stage.
+#undef tsk_bug_assert
+#ifdef __cplusplus
+#include <Rcpp.h>
+#define tsk_bug_assert(condition)                                              \
+  do {                                                                         \
+    if (!(condition)) {                                                        \
+      Rcpp::stop("Bug detected in %s at line %d. %s", __FILE__, __LINE__,      \
+                 TSK_BUG_ASSERT_MESSAGE);                                      \
+    }                                                                          \
+  } while (0)
+#else
+#include <R_ext/Error.h>
+#define tsk_bug_assert(condition)                                              \
+  do {                                                                         \
+    if (!(condition)) {                                                        \
+      Rf_error("Bug detected in %s at line %d. %s", __FILE__, __LINE__,        \
+               TSK_BUG_ASSERT_MESSAGE);                                        \
+    }                                                                          \
+  } while (0)
+#endif

tskitr/src/Makevars.in

@@ -13,24 +13,34 @@ TSKIT_SOURCES = \
 TSKIT_OBJECTS = $(TSKIT_SOURCES:.c=.o)
 # $(info TSKIT_OBJECTS = $(TSKIT_OBJECTS)) # for debugging, info is also a GNU extension
 
-# tskitr C++ sources & objects
-# TSKITR_SOURCES = $(wildcard *.cpp) # wildcard is a GNU extension and not desired on CRAN
-TSKITR_SOURCES = \
+# tskitr C/C++ sources & objects
+# TSKITR_CPP_SOURCES = $(wildcard *.cpp) # wildcard is a GNU extension and not desired on CRAN
+TSKITR_CPP_SOURCES = \
 	tskitr.cpp \
+	test_tsk_bug_assert.cpp \
 	RcppExports.cpp
-# $(info TSKITR_SOURCES = $(TSKITR_SOURCES)) # for debugging, info is also a GNU extension
-TSKITR_OBJECTS = $(TSKITR_SOURCES:.cpp=.o)
+# $(info TSKITR_CPP_SOURCES = $(TSKITR_CPP_SOURCES)) # for debugging, info is also a GNU extension
+TSKITR_C_SOURCES = \
+	test_tsk_bug_assert_c.c
+# $(info TSKITR_C_SOURCES = $(TSKITR_C_SOURCES)) # for debugging, info is also a GNU extension
+TSKITR_OBJECTS = $(TSKITR_CPP_SOURCES:.cpp=.o) $(TSKITR_C_SOURCES:.c=.o)
 # $(info TSKITR_OBJECTS = $(TSKITR_OBJECTS)) # for debugging, info is also a GNU extension
 
 # All objects
 OBJECTS = $(TSKIT_OBJECTS) $(TSKITR_OBJECTS)
 # $(info OBJECTS = $(OBJECTS)) # for debugging, info is also a GNU extension
 
 # Include paths and preprocessor defines
-PKG_CPPFLAGS = -I../inst/include -I../inst/include/tskit -I../inst/include/tskit/tskit
+# * A bit complicated include/tskit structure due to how we include tskit headers
+# * $(R_HOME)/include is for <R_ext/Error.h>
+PKG_CPPFLAGS = \
+	-I../inst/include \
+	-I../inst/include/tskit \
+	-I../inst/include/tskit/tskit \
+	-I$(R_HOME)/include
 
 # Compiler flags
-PKG_CFLAGS = -DNDEBUG # to remove calls to assert()
+PKG_CFLAGS = -DNDEBUG # to remove calls to assert() as per the R extensions manual
 # TODO: Should we port any flags from extern/tskit/c/meson.build to R build system? #6
 #       https://github.com/HighlanderLab/tskitr/issues/6
 #       See default flags used by clang  (see below output from devtools::install())

tskitr/src/RcppExports.cpp

@@ -10,6 +10,24 @@ Rcpp::Rostream<true>&  Rcpp::Rcout = Rcpp::Rcpp_cout_get();
 Rcpp::Rostream<false>& Rcpp::Rcerr = Rcpp::Rcpp_cerr_get();
 #endif
 
+// test_tsk_bug_assert_c
+void test_tsk_bug_assert_c();
+RcppExport SEXP _tskitr_test_tsk_bug_assert_c() {
+BEGIN_RCPP
+    Rcpp::RNGScope rcpp_rngScope_gen;
+    test_tsk_bug_assert_c();
+    return R_NilValue;
+END_RCPP
+}
+// test_tsk_bug_assert_cpp
+void test_tsk_bug_assert_cpp();
+RcppExport SEXP _tskitr_test_tsk_bug_assert_cpp() {
+BEGIN_RCPP
+    Rcpp::RNGScope rcpp_rngScope_gen;
+    test_tsk_bug_assert_cpp();
+    return R_NilValue;
+END_RCPP
+}
 // kastore_version
 Rcpp::IntegerVector kastore_version();
 RcppExport SEXP _tskitr_kastore_version() {
@@ -210,6 +228,8 @@ END_RCPP
 }
 
 static const R_CallMethodDef CallEntries[] = {
+    {"_tskitr_test_tsk_bug_assert_c", (DL_FUNC) &_tskitr_test_tsk_bug_assert_c, 0},
+    {"_tskitr_test_tsk_bug_assert_cpp", (DL_FUNC) &_tskitr_test_tsk_bug_assert_cpp, 0},
     {"_tskitr_kastore_version", (DL_FUNC) &_tskitr_kastore_version, 0},
     {"_tskitr_tskit_version", (DL_FUNC) &_tskitr_tskit_version, 0},
     {"_tskitr_ts_load", (DL_FUNC) &_tskitr_ts_load, 2},

tskitr/src/test_tsk_bug_assert.cpp

@@ -0,0 +1,10 @@
+#include <Rcpp.h>
+#include <tskit/core.h>
+
+extern "C" void tskitr_bug_assert_c(void);
+
+// [[Rcpp::export]]
+void test_tsk_bug_assert_c() { tskitr_bug_assert_c(); }
+
+// [[Rcpp::export]]
+void test_tsk_bug_assert_cpp() { tsk_bug_assert(false); }

tskitr/src/test_tsk_bug_assert_c.c

@@ -0,0 +1,3 @@
+#include <tskit/core.h>
+
+void tskitr_bug_assert_c(void) { tsk_bug_assert(0); }

tskitr/tests/testthat/test_tskitr.R

@@ -11,3 +11,8 @@ test_that("tskit_version() works", {
   expect_true(is.integer(v))
   expect_equal(names(v), c("major", "minor", "patch"))
 })
+
+test_that("tsk_bug_assert() works", {
+  expect_error(test_tsk_bug_assert_c())
+  expect_error(test_tsk_bug_assert_cpp())
+})