Vendor the rlang API

DESCRIPTION

@@ -12,6 +12,8 @@ License: GPL-3
 LazyData: true
 Depends:
     R (>= 3.1.0)
+Imports:
+    rlang
 Suggests:
     knitr,
     rmarkdown (>= 0.2.65),

R/zzz.R

@@ -0,0 +1,4 @@
+.onLoad <- function(libname, pkgname) {
+  loadNamespace("rlang")
+  .Call(r_init_library, asNamespace(pkgname))
+}

src/Makevars

@@ -0,0 +1 @@
+PKG_CPPFLAGS = -I./rlang

src/init.c

@@ -1,4 +1,4 @@
-#include <Rinternals.h>
+#include <rlang.h>
 #include <R_ext/Rdynload.h>
 
 extern SEXP env(SEXP);
@@ -21,6 +21,7 @@ static const R_CallMethodDef call_entries[] = {
   {"lazyeval_make_lazy",            (DL_FUNC) &make_lazy, 3},
   {"lazyeval_make_lazy_dots",       (DL_FUNC) &make_lazy_dots, 3},
   {"lazyeval_rhs",                  (DL_FUNC) &rhs, 1},
+  {"r_init_library",                (DL_FUNC) &r_init_library, 1},
   {NULL, NULL, 0}
 };
 

src/rlang.c

@@ -0,0 +1,5 @@
+// This is an include point for the implementations of the rlang
+// library. It should be included in a single and separate compilation
+// unit.
+
+#include "rlang/rlang.c"

src/rlang/arg.c

@@ -0,0 +1,11 @@
+#include "rlang.h"
+
+int (*r_arg_match)(r_obj* arg,
+                   r_obj* values,
+                   struct r_lazy error_arg,
+                   struct r_lazy error_call);
+
+void r_init_library_arg(void) {
+  r_arg_match = (int (*)(r_obj*, r_obj*, struct r_lazy, struct r_lazy))
+    r_peek_c_callable("rlang", "rlang_arg_match_2");
+}

src/rlang/arg.h

@@ -0,0 +1,14 @@
+// IWYU pragma: private; include "rlang.h"
+
+#ifndef RLANG_ARG_H
+#define RLANG_ARG_H
+
+#include "rlang-types.h"
+
+extern int (*r_arg_match)(r_obj* arg,
+                          r_obj* values,
+                          struct r_lazy error_arg,
+                          struct r_lazy error_call);
+
+
+#endif

src/rlang/attrib.c

@@ -0,0 +1,55 @@
+#include "rlang.h"
+
+static r_obj* r_attrib_get_cb(r_obj* tag, r_obj* val, void* data) {
+  if (tag == *(r_obj**) data) {
+    return val;
+  }
+  return NULL;
+}
+
+r_obj* r_attrib_get(r_obj* x, r_obj* tag) {
+  r_obj* out = r_attrib_map(x, &r_attrib_get_cb, &tag);
+  return out ? out : r_null;
+}
+
+// Collect attributes into a pairlist using `R_mapAttrib`
+static r_obj* r_attrib_collect_cb(r_obj* tag, r_obj* val, void* data) {
+  r_obj** p_tail = (r_obj**) data;
+
+  r_obj* node = r_new_node(val, r_null);
+  r_node_poke_tag(node, tag);
+  r_node_poke_cdr(*p_tail, node);
+
+  *p_tail = node;
+  return NULL;
+}
+
+r_obj* r_attrib_collect(r_obj* x) {
+  r_obj* sentinel = KEEP(r_new_node(r_null, r_null));
+  r_obj* tail = sentinel;
+
+  r_attrib_map(x, &r_attrib_collect_cb, &tail);
+
+  FREE(1);
+  return r_node_cdr(sentinel);
+}
+
+bool r_is_named(r_obj* x) {
+  r_obj* nms = r_names(x);
+
+  if (r_typeof(nms) != R_TYPE_character) {
+    return false;
+  }
+
+  if (r_chr_has(nms, "")) {
+    return false;
+  }
+
+  return true;
+}
+
+void r_attrib_poke_classes(r_obj* x, const char** classes, r_ssize n) {
+  r_obj* classes_chr = KEEP(r_chr_n(classes, n));
+  r_attrib_poke(x, r_syms.class_, classes_chr);
+  FREE(1);
+}

src/rlang/attrib.h

@@ -0,0 +1,79 @@
+// IWYU pragma: private; include "rlang.h"
+
+#ifndef RLANG_ATTRIB_H
+#define RLANG_ATTRIB_H
+
+#include "rlang-types.h"
+#include "globals.h"
+
+
+static inline
+bool r_attrib_has_any(r_obj* x) {
+  return ANY_ATTRIB(x);
+}
+
+// Collect attributes into a fresh pairlist
+r_obj* r_attrib_collect(r_obj* x);
+
+typedef r_obj* (r_attrib_map_fn)(r_obj* tag, r_obj* value, void* data);
+
+// Map a callback to each attribute of an object. Prefer this to collecting for
+// performance-critical applications.
+static inline
+r_obj* r_attrib_map(r_obj* x, r_attrib_map_fn* fn, void* data) {
+  return R_mapAttrib(x, fn, data);
+}
+
+static inline
+void r_attrib_zap(r_obj* x, r_obj* tag) {
+  Rf_setAttrib(x, tag, r_null);
+}
+static inline
+void r_attrib_zap_all(r_obj* x) {
+  CLEAR_ATTRIB(x);
+}
+
+static inline
+void r_attrib_clone_from(r_obj* to, r_obj* from) {
+  SHALLOW_DUPLICATE_ATTRIB(to, from);
+}
+
+
+// Unlike Rf_getAttrib(), this doesn't allocate, but in practice requires
+// protection because rchk considers the return value to be a fresh pointer.
+r_obj* r_attrib_get(r_obj* x, r_obj* tag);
+
+static inline
+r_obj* r_class(r_obj* x) {
+  return r_attrib_get(x, r_syms.class_);
+}
+
+void r_attrib_poke_classes(r_obj* x, const char** classes, r_ssize n);
+
+static inline
+r_obj* r_dim(r_obj* x) {
+  return r_attrib_get(x, r_syms.dim);
+}
+
+static inline
+r_obj* r_dim_names(r_obj* x) {
+  return r_attrib_get(x, r_syms.dim_names);
+}
+
+static inline
+r_obj* r_names(r_obj* x) {
+  return r_attrib_get(x, r_syms.names);
+}
+
+bool r_is_named(r_obj* x);
+
+
+// Defined as macros so rchk can see that `X` protects `VALUE`
+#define r_attrib_poke(X, SYM, VALUE) Rf_setAttrib(X, SYM, VALUE)
+#define r_attrib_poke_class(X, VALUE) Rf_setAttrib(X, r_syms.class_, VALUE)
+#define r_attrib_poke_dim(X, VALUE) Rf_setAttrib(X, r_syms.dim, VALUE)
+#define r_attrib_poke_dim_names(X, VALUE) Rf_setAttrib(X, r_syms.dim_names, VALUE)
+#define r_attrib_poke_names(X, VALUE) Rf_setAttrib(X, r_syms.names, VALUE)
+
+
+#endif

src/rlang/c-utils.c

@@ -0,0 +1,29 @@
+#include <rlang.h>
+
+void* r_shelter_deref(r_obj* x) {
+  enum r_type type = r_typeof(x);
+
+  switch (type) {
+  case R_TYPE_list:
+    if (r_length(x) < 1) {
+      r_abort("Shelter must have at least one element");
+    }
+    x = r_list_get(x, 0);
+    type = r_typeof(x);
+    break;
+  case R_TYPE_pairlist:
+    x = r_node_car(x);
+    type = r_typeof(x);
+    break;
+  case R_TYPE_raw:
+    break;
+  default:
+    r_stop_unimplemented_type(type);
+  }
+
+  if (type != R_TYPE_raw) {
+    r_stop_unexpected_type(type);
+  }
+
+  return r_raw_begin(x);
+}