Merge pull request #8 from crowding/compliance

Toward API compliance

.github/workflows/R-CMD-check.yaml

@@ -26,7 +26,7 @@ jobs:
 
           - {os: windows-latest, r: 'release'}
           # Use 3.6 to trigger usage of RTools35
-          - {os: windows-latest, r: '3.6'}
+          # - {os: windows-latest, r: '3.6'}
           # use 4.1 to check with rtools40's older compiler
           - {os: windows-latest, r: '4.1'}
 

DESCRIPTION

@@ -1,8 +1,8 @@
 Package: nseval
 Type: Package
 Title: Tools for Lazy and Non-Standard Evaluation
-Version: 0.5.1
-Date: 2023-12-11
+Version: 0.5.2
+Date: 2024-07-01
 Author: Peter Meilstrup <peter.meilstrup@gmail.com>
 Maintainer: Peter Meilstrup <peter.meilstrup@gmail.com>
 Description: Functions to capture, inspect, manipulate, and create
@@ -34,5 +34,5 @@ Collate:
     'force.R'
     'shortcut.R'
     'missing.R'
-RoxygenNote: 7.2.3
+RoxygenNote: 7.3.2
 Roxygen: list(markdown=TRUE)

NAMESPACE

@@ -35,6 +35,7 @@ S3method(forced,default)
 S3method(forced,dots)
 S3method(forced,quotation)
 S3method(format,dots)
+S3method(format,name)
 S3method(format,oneline)
 S3method(format,quotation)
 S3method(is_default_,default)

NEWS.md

@@ -1,3 +1,9 @@
+# nseval 0.5.2 (release date: 2023-07-01)
+
+### Fixes:
+
+* In preparation for normalization of an official R API, references to non-API functions `DDVAL`, `Rf_findVarInFrame3`, `SET_TYPEOF`, `SET_BODY`, `SET_FORMALS` and `SET_CLOENV` have been removed. The calls to PROMSXP accessor functions remain, as they are central to this package's purpose and it is not yet clear what the official API will have in their place.
+
 # nseval 0.5.1 (release date: 2023-12-11)
 
 ### Fixes:

R/format.R

@@ -128,6 +128,7 @@ format_robust <- function(x, ...) {
   tryCatch(format(x, ...), error=function(e) "?FORMAT?")
 }
 
+#' @exportS3Method
 format.name <- function(x, ...) {
   format(as.character(x))
 }

src/caller.c

@@ -4,10 +4,6 @@
 #include <R_ext/Boolean.h>
 #include <Rversion.h>
 
-int nullish(SEXP dots) {        /* R_NilValue but also list() */
-  return (TYPEOF(dots) == VECSXP && LENGTH(dots) == 0);
-}
-
 SEXP _remove(SEXP what, SEXP env) {
 #if defined(R_VERSION) && R_VERSION >= R_Version(4, 0, 0)
   assert_type(what, SYMSXP);
@@ -18,33 +14,26 @@ SEXP _remove(SEXP what, SEXP env) {
 }
 
 SEXP _construct_do_call(SEXP dots) {
-  dots = PROTECT(_flist_to_dotsxp(dots));
-
-  //return a list with 3 items: call, env, dotsxp
+  dots = PROTECT(_flist_to_dotsxp(dots)); // TODO: Either stop assigning to dots in do__, or come up with a pairlist-to-dotsxp kludge
+  assert_type(dots, DOTSXP);
+  //return a list with 3 items: call, env, and optional dotsxp to bind to `...`
   SEXP out = PROTECT(allocVector(VECSXP, 3));
   SEXP fun = CAR(dots);
   SEXP args = CDR(dots);
-
+  LOG("got a %s for an arglist", type2char(TYPEOF(args)));
   assert_type(fun, PROMSXP);
-  int has_args;
-  if (nullish(dots)) {
-    LOG("Nullish");
-    has_args = 0;
+  int arglen;
+  if (isNull(args)) {
+    arglen = 0;
   } else {
-    assert_type(dots, DOTSXP);
-    has_args = 1;
+    assert_type(args, DOTSXP);
+    arglen = length(args);
   }
 
   //construct a pairlist to make the call
   LOG("allocating call");
   SEXP call;
-  {
-    int arglen = 0;
-    if (has_args) arglen = length(dots);
-    LOG("arglen = %d", arglen);
-    SET_VECTOR_ELT(out, 0, call = allocList(arglen));
-    SET_TYPEOF(call, LANGSXP);
-  }
+  SET_VECTOR_ELT(out, 0, call = allocLang(arglen+1));
 
   //construct the call head
   SEXP callenv = PRENV(fun);
@@ -75,7 +64,7 @@ SEXP _construct_do_call(SEXP dots) {
 
   /* construct the call args (all input promises) */
   SEXP copyTo = call;
-  if (has_args) {
+  if (arglen > 0) {
     copyTo = CDR(copyTo);
     SEXP copyFrom = args;
     for (; 

src/dots.c

@@ -11,7 +11,7 @@ SEXP _get_dots(SEXP env, SEXP inherit) {
   if (asLogical(inherit)) {
     vl = findVar(R_DotsSymbol, env);
   } else {
-    vl = findVarInFrame3(env, R_DotsSymbol, TRUE);
+    vl = findVarInFrame(env, R_DotsSymbol);
   }
   if (vl == R_UnboundValue || vl == R_MissingArg) {
     LOG("... not found in env %p", (void *) env);
@@ -24,9 +24,11 @@ SEXP _get_dots(SEXP env, SEXP inherit) {
 SEXP _set_dots(SEXP dots, SEXP env) {
   assert_type(env, ENVSXP);
   if (isNull(dots) || dots == R_MissingArg) {
+    LOG("Setting missing dots");
     defineVar(R_DotsSymbol, R_MissingArg, env); /* is this kosher? */       
   } else {
     assert_type(dots, DOTSXP);
+    LOG("got a DOTSXP, setting `...`");
     defineVar(R_DotsSymbol, dots, env);
   }
   return R_NilValue;
@@ -191,6 +193,22 @@ SEXP _dots_envs(SEXP dots) {
   return(envs);
 }
 
+/* allocDots <- function(n) { */
+/*   do.call(function(...) .Call("_get_dots", environment(), FALSE), rep(list(NULL), n)) */
+/* } */
+
+SEXP allocDots(int n) {
+  SEXP out = R_NilValue;
+  int up = 0;
+  for (; n > 0; n--, up++) {
+    SEXP new = PROTECT(allocSExp(DOTSXP));
+    SETCDR(new, out);
+    out = new;
+  }
+  UNPROTECT(up);
+  return out;
+}
+
 SEXP _flist_to_dotsxp(SEXP flist) {
   assert_type(flist, VECSXP);
   int len = LENGTH(flist);
@@ -200,10 +218,9 @@ SEXP _flist_to_dotsxp(SEXP flist) {
   } else {
     SEXP output, names;
     names = PROTECT(getAttrib(flist, R_NamesSymbol));
-    output = PROTECT(allocList(len));
+    output = PROTECT(allocDots(len));
     SEXP output_iter = output;
     for (i = 0; i < len; i++, output_iter=CDR(output_iter)) {
-      SET_TYPEOF(output_iter, DOTSXP);
       if ((names != R_NilValue) && (STRING_ELT(names, i) != R_BlankString)) {
         SET_TAG(output_iter, install(CHAR(STRING_ELT(names, i))));
       } else {

src/getpromise.c

@@ -24,23 +24,23 @@ SEXP _locate(SEXP sym, SEXP env, SEXP function) {
   assert_type(env, ENVSXP);
   Rboolean fn = asLogical(function);
 
-  if (DDVAL(sym)) {
+  if (ddVal(sym)) {
     error("locate_: double dot symbol `%s` not supported", CHAR(PRINTNAME(sym)));
   }
 
   while (env != R_EmptyEnv) {
     assert_type(env, ENVSXP);
     LOG("looking in env %p for %s", (void *) env, CHAR(PRINTNAME(sym)));
     if (fn) {
-      SEXP x = PROTECT(findVarInFrame3(env, sym, TRUE));
+      SEXP x = PROTECT(findVarInFrame(env, sym));
       LOG("got a %s", type2char(TYPEOF(x)));
       while (TYPEOF(x) == PROMSXP) {
         if (PRVALUE(x) == R_UnboundValue) {
           /* Per R rules, we must force. As forcing isn't exposed in
              Rinternals, I'll do it by calling "force"... or forceAndCall and
              then calling force.... */
           LOG("forcing it");
-          SEXP force = findVarInFrame3(R_BaseNamespace, install("force"), TRUE);
+          SEXP force = findVarInFrame(R_BaseNamespace, install("force"));
           SEXP callForce = PROTECT(list2(force, sym));
           R_forceAndCall(callForce, 1, env);
           UNPROTECT(1);
@@ -61,12 +61,11 @@ SEXP _locate(SEXP sym, SEXP env, SEXP function) {
         break;
       }
     } else {
-      SEXP x = findVarInFrame3(env, sym, FALSE);
-      if (x != R_UnboundValue) {
+      if (R_existsVarInFrame(env, sym)) {
         return env;
       }
     }
-    env = ENCLOS(env);
+    env = R_ParentEnv(env);
   }
   return R_NilValue;
 }
@@ -91,7 +90,7 @@ SEXP x_findVar(SEXP sym, SEXP envir) {
   assert_type(sym, SYMSXP);
   assert_type(envir, ENVSXP);
   SEXP binding;
-  if (DDVAL(sym)) {
+  if (ddVal(sym)) {
     binding = do_ddfindVar(sym, envir);
   } else {
     binding = Rf_findVar(sym, envir);

src/init.c

@@ -32,7 +32,6 @@ extern SEXP _is_missing(SEXP, SEXP, SEXP, SEXP);
 extern SEXP _is_promise(SEXP, SEXP, SEXP);
 extern SEXP _locate(SEXP, SEXP, SEXP);
 extern SEXP _quotation(SEXP, SEXP, SEXP, SEXP);
-extern SEXP _quotation_old(SEXP, SEXP, SEXP);
 extern SEXP _quotation_literal(SEXP);
 extern SEXP _quotation_to_promsxp(SEXP);
 extern SEXP _remove(SEXP, SEXP);
@@ -65,7 +64,6 @@ static const R_CallMethodDef CallEntries[] = {
   {"_is_promise",           (DL_FUNC) &_is_promise,           3},
   {"_locate",               (DL_FUNC) &_locate,               3},
   {"_quotation",            (DL_FUNC) &_quotation,            4},
-  {"_quotation_old",        (DL_FUNC) &_quotation_old,        3},
   {"_quotation_literal",    (DL_FUNC) &_quotation_literal,    1},
   {"_quotation_to_promsxp", (DL_FUNC) &_quotation_to_promsxp, 1},
   {"_remove",               (DL_FUNC) &_remove, 2},

src/promises.c

@@ -103,36 +103,6 @@ SEXP _is_plausible_quotation(SEXP value) {
   return ScalarLogical(is_plausible_quotation(value));
 }
 
-SEXP _quotation_old(SEXP envir, SEXP expr, SEXP value) {
-  SEXP out = PROTECT(allocSExp(CLOSXP));
-  SET_FORMALS(out, R_NilValue);
-  SEXP prom;
-  if (expr == R_MissingArg) {
-    /* Ignore the environment. */
-    SET_CLOENV(out, R_EmptyEnv);
-    SET_BODY(out, expr);
-  } else if (envir == R_NilValue) {
-    /* already-forced promise. Record a PROMSXP in the body? */
-    prom = PROTECT(new_forced_promise(expr, value));
-    SET_CLOENV(out, R_EmptyEnv);
-    SET_BODY(out, prom);
-    UNPROTECT(1);
-  } else {
-    assert_type(envir, ENVSXP);
-    if (value != R_MissingArg) {
-      error("Can't make a promise with both an env and a value");
-    } else {
-      SET_CLOENV(out, envir);
-      SET_BODY(out, expr);
-    }
-  }
-
-  setAttrib(out, R_ClassSymbol, mkString("quotation"));
-
-  UNPROTECT(1);
-  return out;
-}
-
 /* Test if a quotation is "forced" */
 int is_forced_quotation(SEXP clos) {
   switch(TYPEOF(clos)) {
@@ -246,15 +216,6 @@ SEXP promsxp_to_quotation(SEXP prom) {
   }
 }
 
-SEXP empty_closure(void) {
-  SEXP out = PROTECT(allocSExp(CLOSXP));
-  SET_FORMALS(out, R_NilValue);
-  SET_BODY(out, R_MissingArg);
-  SET_CLOENV(out, R_EmptyEnv);
-  UNPROTECT(1);
-  return out;
-}
-
 SEXP _quotation_to_promsxp(SEXP quot) {
   if (_expr_quotation(quot) == R_MissingArg) {
     return R_MissingArg;

src/promises.h

@@ -3,7 +3,6 @@
 
 SEXP forced_value_promise(SEXP in);
 SEXP promsxp_to_quotation(SEXP);
-SEXP empty_closure(void);
 SEXP _quotation_to_promsxp(SEXP);
 SEXP promsxp_to_quotation(SEXP);
 SEXP make_into_promsxp(SEXP);

src/vadr.c

@@ -62,3 +62,19 @@ SEXP new_weird_promise(SEXP expr, SEXP env, SEXP value) {
   UNPROTECT(1);
   return out;
 }
+
+#if R_VERSION < R_Version(4, 4, 1)
+SEXP allocLang(int n)
+{
+  if (n > 0)
+    return LCONS(R_NilValue, allocList(n - 1));
+  else
+    return R_NilValue;
+}
+#endif
+
+#if R_VERSION < R_Version(4, 2, 0)
+Rboolean R_existsVarInFrame(SEXP rho, SEXP symbol) {
+  return (Rf_findVarInFrame3(rho, symbol, FALSE) != R_UnboundValue);
+}
+#endif

src/vadr.h

@@ -3,8 +3,9 @@
 
 #include <R.h>
 #include <Rinternals.h>
+#include <Rversion.h>
 
-#undef DEBUG 
+#undef DEBUG
 // #define DEBUG
 
 #define MIN(x,y) ((x) < (y) ? (x) : (y))
@@ -40,8 +41,6 @@
     }                                                            \
   }
 
-
-
 #ifdef DEBUG
 #define LOG(FMT, ...) Rprintf("%s: "  FMT " @%s:%d\n",                  \
                               __func__, ##__VA_ARGS__, __FILE__, __LINE__)
@@ -59,8 +58,23 @@ SEXP new_weird_promise(SEXP expr, SEXP value, SEXP env);
 SEXP x_findVar(SEXP sym, SEXP envir);
 
 SEXP _flist_to_dotsxp(SEXP flist);
+SEXP _flist_to_pairlist(SEXP flist);
 int is_language(SEXP x);
 int is_forced(SEXP x);
 SEXP peek_promise(SEXP prom);
 
 #endif
+
+#if R_VERSION < R_Version(4, 4, 1)
+SEXP allocLang(int n);
+#endif
+
+#if R_VERSION < R_Version(4, 5, 0)
+# define R_ClosureFormals(x) FORMALS(x)
+# define R_ClosureEnv(x) CLOENV(x)
+# define R_ParentEnv(x) ENCLOS(x)
+#endif
+
+#if R_VERSION < R_Version(4, 2, 0)
+Rboolean R_existsVarInFrame(SEXP rho, SEXP symbol);
+#endif