address CRAN's policy on non-API entry points in C

dusadrian · Sep 9, 2024 · a4a4ec4 · a4a4ec4
1 parent 9ff6f2c
commit a4a4ec4
Show file tree

Hide file tree

Showing 5 changed files with 42 additions and 27 deletions.
diff --git a/R/internals.R b/R/internals.R
@@ -688,9 +688,9 @@ NULL
 }
 
 
-`unlockEnvironment_` <- function (env) {
-    .Call ("_unlockEnvironment", env, PACKAGE = "declared")
-}
+# `unlockEnvironment_` <- function (env) {
+#     .Call ("_unlockEnvironment", env, PACKAGE = "declared")
+# }
 
 
 #' @rdname declared_internal

diff --git a/R/onLoad.R b/R/onLoad.R
@@ -12,7 +12,7 @@
         )
     )
 
-    if (unlockEnvironment_ (asNamespace("base"))) {
+    # if (unlockEnvironment_ (asNamespace("base"))) {
 
         env <- as.environment("package:base")
         do.call ("unlockBinding", list (sym = "print.data.frame", env = env))
@@ -714,9 +714,9 @@
 
             do.call(.Primitive ("sum"), c(dots, na.rm = na.rm))
         }
-    }
+    # }
 
-    if (unlockEnvironment_ (asNamespace("stats"))) {
+    # if (unlockEnvironment_ (asNamespace("stats"))) {
 
         env <- as.environment("package:stats")
 
@@ -817,7 +817,7 @@
                 0.5 * (x[floor (d)] + x[ceiling(d)])
             }
         }
-    }
+    # }
 
     register_S3_method("labelled", "na_values", "declared")
     register_S3_method("labelled", "na_values<-", "declared")

diff --git a/src/declared.c b/src/declared.c
@@ -3,21 +3,24 @@
 #include <R_ext/Rdynload.h>
 #include <R_ext/Boolean.h>
 
-
-// copied from: https://gist.github.com/wch/3280369#file-unlockenvironment-r
+/*
+// copied from: https://github.com/wch/r-source/blob/trunk/src/main/envir.c
+// as mentioned in https://gist.github.com/wch/3280369#file-unlockenvironment-r
+// https://cran.r-project.org/doc/manuals/r-devel/R-exts.html#Moving-into-C-API-compliance
+// https://rstudio.github.io/r-manuals/r-exts/The-R-API.html#moving-into-c-api-compliance
 #define FRAME_LOCK_MASK (1<<14)
 #define FRAME_IS_LOCKED(e) (ENVFLAGS(e) & FRAME_LOCK_MASK)
 #define UNLOCK_FRAME(e) SET_ENVFLAGS(e, ENVFLAGS(e) & (~ FRAME_LOCK_MASK))
 
 SEXP _unlockEnvironment(SEXP env) {
     UNLOCK_FRAME(env);
-    
+
     SEXP result = PROTECT( Rf_allocVector(LGLSXP, 1) );
-    LOGICAL(result)[0] = FRAME_IS_LOCKED(env) == 0;
+    LOGICAL(result)[0] = FRAME_IS_LOCKED(env) == 0; // maybe check R_EnvironmentIsLocked ?
     UNPROTECT(1);
     return result;
 }
-
+*/
 
 typedef union {
     double value;
@@ -47,7 +50,7 @@ SEXP _tag(SEXP x) {
         if (nchars > 2 + firstminus) {
             nchars = 2 + firstminus;
         }
-        
+
         ieee_double y;
         y.value = NA_REAL;
 
@@ -66,7 +69,7 @@ SEXP _tag(SEXP x) {
                 bytepos += 1;
             }
         }
-        
+
         REAL(out)[i] = y.value;
     }
 
@@ -85,7 +88,7 @@ SEXP _hasTag(SEXP x, SEXP tag_) {
             LOGICAL(out)[i] = 0;
         }
     }
-    else {    
+    else {
 
         for (int i = 0; i < n; ++i) {
             double xi = REAL(x)[i];
@@ -98,7 +101,7 @@ SEXP _hasTag(SEXP x, SEXP tag_) {
                 char tag = y.byte[TAG_BYTE];
 
                 Rboolean test = TRUE;
-                
+
                 if (tag == '\0') {
                     LOGICAL(out)[i] = FALSE;
                 }
@@ -107,23 +110,23 @@ SEXP _hasTag(SEXP x, SEXP tag_) {
 
                         int nchars = Rf_length(STRING_ELT(tag_, 0));
                         Rboolean firstminus = CHAR(STRING_ELT(tag_, 0))[0] == CHAR(mkChar("-"))[0];
-                        
+
                         if ((firstminus && !signbit(xi)) || (!firstminus && signbit(xi))) {
                             LOGICAL(out)[i] = FALSE;
                         }
                         else {
-                            
+
                             if (nchars > 2 + firstminus) {
                                 nchars = 2 + firstminus;
                             }
 
                             test = test && tag == CHAR(STRING_ELT(tag_, 0))[firstminus];
                             char tag = y.byte[(TAG_BYTE == 4) ? 5 : 2];
-                            
+
                             if (Rf_length(STRING_ELT(tag_, 0)) > 1 && tag != '\0') {
                                 test = test && tag == CHAR(STRING_ELT(tag_, 0))[firstminus + 1];
                             }
-                            
+
                             LOGICAL(out)[i] = test;
                         }
                     }
@@ -142,7 +145,7 @@ SEXP _hasTag(SEXP x, SEXP tag_) {
 
 
 SEXP _getTag(SEXP x) {
-    
+
     int n = Rf_length(x);
     SEXP out = PROTECT(Rf_allocVector(STRSXP, n));
 
@@ -153,12 +156,12 @@ SEXP _getTag(SEXP x) {
             SET_STRING_ELT(out, i, NA_STRING);
         }
         else {
-            
+
             ieee_double y;
             y.value = xi;
 
             Rboolean firstminus = signbit(xi);
-            
+
             char test[16 + 8 * firstminus];
             if (firstminus) {
                 test[0] = CHAR(mkChar("-"))[0];
@@ -172,7 +175,7 @@ SEXP _getTag(SEXP x) {
             else {
                 char tag2 = y.byte[(TAG_BYTE == 4) ? 5 : 2];
                 int nchars = 1 + (strlen(&tag2) > 0) + firstminus;
-                
+
                 test[firstminus + 1] = tag2;
                 SET_STRING_ELT(out, i, Rf_mkCharLenCE(test, nchars, CE_UTF8));
             }
@@ -192,7 +195,7 @@ SEXP _anyTagged(SEXP x) {
     LOGICAL(out)[0] = 0;
 
     int i = 0;
-    
+
     while (!LOGICAL(out)[0] && i < n) {
         if (TYPEOF(x) == REALSXP) {
             double xi = REAL(x)[i];
@@ -201,7 +204,7 @@ SEXP _anyTagged(SEXP x) {
                 y.value = xi;
 
                 Rboolean firstminus = signbit(xi);
-                
+
                 char test[16 + 8 * firstminus];
                 if (firstminus) {
                     test[0] = CHAR(mkChar("-"))[0];

diff --git a/src/registerDynamicSymbol.c b/src/registerDynamicSymbol.c
@@ -6,3 +6,15 @@ void R_init_declared(DllInfo* info) {
   R_registerRoutines(info, NULL, NULL, NULL, NULL);
   R_useDynamicSymbols(info, TRUE);
 }
+
+
+/*
+8.1.3 Registering symbols
+
+An application embedding R needs a different way of registering symbols because it is not a dynamic library loaded by R as would be the case with a package. Therefore R reserves a special DllInfo entry for the embedding application such that it can register symbols to be used with .C, .Call etc. This entry can be obtained by calling getEmbeddingDllInfo, so a typical use is
+
+    DllInfo *info = R_getEmbeddingDllInfo();
+    R_registerRoutines(info, cMethods, callMethods, NULL, NULL);
+
+The native routines defined by cMethods and callMethods should be present in the embedding application. See Registering native routines for details on registering symbols in general.
+*/
diff --git a/tests/testthat/test-internals.R b/tests/testthat/test-internals.R
@@ -378,7 +378,7 @@ test_that("internal non exported functions work", {
 
   expect_false(hasTag_(bigtag, ""))
 
-  expect_true(unlockEnvironment_(asNamespace("stats")))
+  # expect_true(unlockEnvironment_(asNamespace("stats")))
 
   x <- c(12, 12.3, 12.34)