Use conformant API to iterate over environments

NEWS.md

@@ -1,8 +1,13 @@
 # lobstr (development version)
 
-* `obj_size()` no longer errors with "bad binding access" when inspecting
-  environments with non-standard bindings such as those created by `for` loops
-  or immediate bindings (#48).
+* `obj_size()`, `obj_addrs()`, and `sxp()` no longer error with "bad binding
+  access" when inspecting environments with non-standard bindings such as
+  those created by `for` loops or immediate bindings (#48).
+
+* `sxp(expand = "environment")` no longer shows the internal `_frame` and
+  `_hashtab` structures. Instead, it now shows promise expressions without
+  forcing them. This change was necessary to make lobstr compliant with R's
+  public C API.
 
 # lobstr 1.1.3
 

R/sxp.R

@@ -17,7 +17,7 @@
 #'   suppressed. Use:
 #'
 #'   * "character" to show underlying entries in the global string pool.
-#'   * "environment" to show the underlying hashtables.
+#'   * "environment" to show binding components without any side effect (e.g. promise).
 #'   * "altrep" to show the underlying data.
 #'   * "call" to show the full AST (but [ast()] is usually superior)
 #'   * "bytecode" to show generated bytecode.
@@ -43,14 +43,13 @@
 #' sxp(x)
 #' sxp(x, expand = "altrep")
 #'
-#' # Expand environmnets to see the underlying implementation details
-#' e1 <- new.env(hash = FALSE, parent = emptyenv(), size = 3L)
-#' e2 <- new.env(hash = TRUE, parent = emptyenv(), size = 3L)
-#' e1$x <- e2$x <- 1:10
+#' # Expand environments to see promise expressions without forcing
+#' e <- new.env(parent = emptyenv())
+#' delayedAssign("x", 1 + 1, assign.env = e)
 #'
-#' sxp(e1)
-#' sxp(e1, expand = "environment")
-#' sxp(e2, expand = "environment")
+#' sxp(e)
+#' sxp(e, expand = "environment")
+
 sxp <- function(x, expand = character(), max_depth = 5L) {
   opts <- c("character", "altrep", "environment", "call", "bytecode")
   if (any(!expand %in% opts)) {
@@ -78,18 +77,17 @@ format.lobstr_inspector <- function(x, ..., depth = 0, name = NA) {
   indent <- paste0(rep("  ", depth), collapse = "")
 
   id <- crayon::bold(attr(x, "id"))
-  if (!is_testing()) {
+  if (!is_testing() && !is_placeholder(x)) {
     addr <- paste0(":", crayon::silver(attr(x, "addr")))
   } else {
     addr <- ""
   }
 
-  if (attr(x, "type") == 0) {
-    desc <- crayon::silver("<NILSXP>")
-  } else if (attr(x, "has_seen")) {
+  type <- attr(x, "type")
+
+  if (attr(x, "has_seen")) {
     desc <- paste0("[", attr(x, "id"), addr, "]")
   } else {
-    type <- sexp_type(attr(x, "type"))
     if (sexp_is_vector(type)) {
       length <- paste0("[", attr(x, "length"), "]")
     } else {
@@ -102,7 +100,7 @@ format.lobstr_inspector <- function(x, ..., depth = 0, name = NA) {
       value <- NULL
     }
 
-    if (!is_testing()) {
+    if (!is_testing() && !is_placeholder(x)) {
       no_references <- attr(x, "no_references")
       maybe_shared <- attr(x, "maybe_shared")
       if (no_references == 1) {
@@ -123,20 +121,33 @@ format.lobstr_inspector <- function(x, ..., depth = 0, name = NA) {
       references
     )
 
-    desc <- paste0(
-      "[",
-      id,
-      addr,
-      "] ",
-      "<",
-      crayon::cyan(type),
-      length,
-      value,
-      "> ",
-      "(",
-      sxpinfo,
-      ")"
-    )
+    # Placeholders don't show sxpinfo
+    if (is_placeholder(x)) {
+      desc <- paste0(
+        "[",
+        id,
+        "] ",
+        "<",
+        crayon::cyan(type),
+        value,
+        ">"
+      )
+    } else {
+      desc <- paste0(
+        "[",
+        id,
+        addr,
+        "] ",
+        "<",
+        crayon::cyan(type),
+        length,
+        value,
+        "> ",
+        "(",
+        sxpinfo,
+        ")"
+      )
+    }
   }
 
   name <- if (!identical(name, "")) {
@@ -190,10 +201,6 @@ sxp_view <- function(x, expand = character()) {
 
 # helpers -----------------------------------------------------------------
 
-sexp_type <- function(x) {
-  unname(SEXPTYPE[as.character(x)])
-}
-
 sexp_is_vector <- function(x) {
   x %in%
     c(
@@ -208,32 +215,8 @@ sexp_is_vector <- function(x) {
     )
 }
 
-SEXPTYPE <- c(
-  "0" = "NILSXP",
-  "1" = "SYMSXP",
-  "2" = "LISTSXP",
-  "3" = "CLOSXP",
-  "4" = "ENVSXP",
-  "5" = "PROMSXP",
-  "6" = "LANGSXP",
-  "7" = "SPECIALSXP",
-  "8" = "BUILTINSXP",
-  "9" = "CHARSXP",
-  "10" = "LGLSXP",
-  "13" = "INTSXP",
-  "14" = "REALSXP",
-  "15" = "CPLXSXP",
-  "16" = "STRSXP",
-  "17" = "DOTSXP",
-  "18" = "ANYSXP",
-  "19" = "VECSXP",
-  "20" = "EXPRSXP",
-  "21" = "BCODESXP",
-  "22" = "EXTPTRSXP",
-  "23" = "WEAKREFSXP",
-  "24" = "RAWSXP",
-  "25" = "S4SXP",
-  "30" = "NEWSXP",
-  "31" = "FREESXP",
-  "99" = "FUNSXP"
-)
+# Placeholder nodes do not have any inspectable properties such as refcount or
+# address
+is_placeholder <- function(x) {
+  !nzchar(attr(x, "addr")) || identical(attr(x, "type"), "NILSXP")
+}

src/address.cpp

@@ -1,24 +1,18 @@
 #include "utils.h"
 #include <cpp11/environment.hpp>
+#include <cpp11/sexp.hpp>
 #include <vector>
 
+extern "C" {
+#include <rlang.h>
+}
+
 [[cpp11::register]]
 std::string obj_addr_(SEXP name, cpp11::environment env) {
   return obj_addr_(Rf_eval(name, env));
 }
 
-void frame_addresses(SEXP frame, std::vector<std::string>* refs) {
-  for(SEXP cur = frame; cur != R_NilValue; cur = CDR(cur)) {
-    SEXP obj = CAR(cur);
-    if (obj != R_UnboundValue)
-      refs->push_back(obj_addr_(obj));
-  }
-}
-void hash_table_addresses(SEXP table, std::vector<std::string>* refs) {
-  int n = Rf_length(table);
-  for (int i = 0; i < n; ++i)
-    frame_addresses(VECTOR_ELT(table, i), refs);
-}
+
 
 [[cpp11::register]]
 std::vector<std::string> obj_addrs_(SEXP x) {
@@ -39,14 +33,36 @@ std::vector<std::string> obj_addrs_(SEXP x) {
     break;
 
   case ENVSXP: {
-    // Using node-based object accessors: CAR for FRAME, and TAG for HASHTAB.
-    // TODO: Iterate over environments using environment accessors.
-    // We won't be able to provide an address for things like promises though.
-    bool isHashed = TAG(x) != R_NilValue;
-    if (isHashed) {
-      hash_table_addresses(TAG(x), &out);
-    } else {
-      frame_addresses(CAR(x), &out);
+    cpp11::sexp syms(r_env_syms(x));
+    R_xlen_t n_bindings = Rf_xlength(syms);
+
+    for (R_xlen_t i = 0; i < n_bindings; ++i) {
+      SEXP sym = VECTOR_ELT(syms, i);
+      enum r_env_binding_type type = r_env_binding_type(x, sym);
+
+      switch (type) {
+      case R_ENV_BINDING_TYPE_missing:
+        break;
+
+      case R_ENV_BINDING_TYPE_value:
+        out.push_back(obj_addr_(r_env_get(x, sym)));
+        break;
+
+      case R_ENV_BINDING_TYPE_delayed:
+        out.push_back(obj_addr_(r_env_binding_delayed_expr(x, sym)));
+        break;
+
+      case R_ENV_BINDING_TYPE_forced:
+        out.push_back(obj_addr_(r_env_binding_forced_value(x, sym)));
+        break;
+
+      case R_ENV_BINDING_TYPE_active:
+        out.push_back(obj_addr_(r_env_binding_active_fn(x, sym)));
+        break;
+
+      case R_ENV_BINDING_TYPE_unbound:
+        break;
+      }
     }
     break;
   }