Support parsing and writing of base and empty environments. (#8)

include/rds2cpp/Environment.hpp

@@ -30,12 +30,13 @@ struct Environment {
 
     /**
      * Type of the parent environment.
+     * This is usually one of `SEXPType::ENV`, `SEXPType::GLOBALENV_`, `SEXPType::BASEENV_` or `SEXPType::EMPTYENV_`.
      */
     SEXPType parent_type = SEXPType::GLOBALENV_;
 
     /** 
      * Index of the parent environment.
-     * This should only be used if `parent_type` is `ENV`.
+     * This should only be used if `parent_type` is `SEXPType::ENV`.
      */
     size_t parent = -1;
 

include/rds2cpp/SharedWriteInfo.hpp

@@ -138,9 +138,9 @@ struct SharedWriteInfo {
         auto index = ptr->index;
         auto env_type = ptr->env_type;
 
-        if (env_type == SEXPType::GLOBALENV_) {
+        if (env_type == SEXPType::GLOBALENV_ || env_type == SEXPType::BASEENV_ || env_type == SEXPType::EMPTYENV_) {
             buffer.clear();
-            inject_header(SEXPType::GLOBALENV_, buffer);
+            inject_header(env_type, buffer);
             writer.write(buffer.data(), buffer.size());
             return;
         }

include/rds2cpp/parse_environment.hpp

@@ -15,8 +15,15 @@ template<class Reader>
 PairList parse_pairlist_body(Reader&, std::vector<unsigned char>&, SharedParseInfo&);
 
 inline EnvironmentIndex parse_global_environment_body() {
-    // Rely on default constructor.
-    return EnvironmentIndex();
+    return EnvironmentIndex(SEXPType::GLOBALENV_);
+}
+
+inline EnvironmentIndex parse_base_environment_body() {
+    return EnvironmentIndex(SEXPType::BASEENV_);
+}
+
+inline EnvironmentIndex parse_empty_environment_body() {
+    return EnvironmentIndex(SEXPType::EMPTYENV_);
 }
 
 template<class Reader>
@@ -54,6 +61,12 @@ EnvironmentIndex parse_new_environment_body(Reader& reader, std::vector<unsigned
     } else if (lastbit == static_cast<unsigned char>(SEXPType::GLOBALENV_)) {
         new_env.parent_type = SEXPType::GLOBALENV_;
 
+    } else if (lastbit == static_cast<unsigned char>(SEXPType::BASEENV_)) {
+        new_env.parent_type = SEXPType::BASEENV_;
+
+    } else if (lastbit == static_cast<unsigned char>(SEXPType::EMPTYENV_)) {
+        new_env.parent_type = SEXPType::EMPTYENV_;
+
     } else {
         throw std::runtime_error("could not resolve the parent environment");
     }

include/rds2cpp/parse_object.hpp

@@ -68,6 +68,12 @@ std::unique_ptr<RObject> parse_object(Reader& reader, std::vector<unsigned char>
     } else if (sexp_type == static_cast<unsigned char>(SEXPType::GLOBALENV_)) {
         pointerize_(parse_global_environment_body());
 
+    } else if (sexp_type == static_cast<unsigned char>(SEXPType::BASEENV_)) {
+        pointerize_(parse_base_environment_body());
+
+    } else if (sexp_type == static_cast<unsigned char>(SEXPType::EMPTYENV_)) {
+        pointerize_(parse_empty_environment_body());
+
     } else if (sexp_type == static_cast<unsigned char>(SEXPType::REF)) {
         output = shared.resolve_reference(details);
 

include/rds2cpp/write_object.hpp

@@ -65,6 +65,8 @@ void write_object(const RObject* object, Writer& writer, std::vector<unsigned ch
             break;
         case SEXPType::ENV: 
         case SEXPType::GLOBALENV_:
+        case SEXPType::BASEENV_:
+        case SEXPType::EMPTYENV_:
             shared.write_environment(object, writer, buffer);
             break;
         case SEXPType::EXTPTR:

tests/src/parse.cpp

@@ -174,6 +174,12 @@ Rcpp::RObject convert(const rds2cpp::RObject* input) {
 
     } else if (input->type() == rds2cpp::SEXPType::GLOBALENV_) {
         return Rcpp::List::create(Rcpp::Named("environment_id") = Rcpp::IntegerVector::create(-1));
+
+    } else if (input->type() == rds2cpp::SEXPType::BASEENV_) {
+        return Rcpp::List::create(Rcpp::Named("environment_id") = Rcpp::IntegerVector::create(-2));
+
+    } else if (input->type() == rds2cpp::SEXPType::EMPTYENV_) {
+        return Rcpp::List::create(Rcpp::Named("environment_id") = Rcpp::IntegerVector::create(-3));
     }
 
     return R_NilValue;
@@ -201,9 +207,22 @@ Rcpp::RObject parse(std::string file_name) {
         }
         vars.attr("names") = varnames;
 
+        int parent_code = 0;
+        if (env.parent_type == rds2cpp::SEXPType::ENV) {
+            parent_code = static_cast<int>(env.parent);
+        } else if (env.parent_type == rds2cpp::SEXPType::GLOBALENV_) {
+            parent_code = -1;
+        } else if (env.parent_type == rds2cpp::SEXPType::BASEENV_) {
+            parent_code = -2;
+        } else if (env.parent_type == rds2cpp::SEXPType::EMPTYENV_) {
+            parent_code = -3;
+        } else {
+            throw std::runtime_error("oops, don't know how to handle a parent type of " + std::to_string(static_cast<int>(env.parent_type)));
+        }
+
         auto curout = Rcpp::List::create(
             Rcpp::Named("variables") = vars,
-            Rcpp::Named("parent") = Rcpp::IntegerVector::create(env.parent_type == rds2cpp::SEXPType::GLOBALENV_ ? -1 : static_cast<int>(env.parent)),
+            Rcpp::Named("parent") = parent_code,
             Rcpp::Named("locked") = env.locked
         );
         add_attributes(env.attributes, curout);

tests/src/write.cpp

@@ -169,8 +169,18 @@ std::unique_ptr<rds2cpp::RObject> unconvert(const Rcpp::RObject& x, rds2cpp::Rds
                 } else if (static_cast<size_t>(index) > globals.environments.size()) {
                     throw std::runtime_error("environment index out of range");
                 }
-            } else {
+
+            } else if (index == -1) {
                 ptr->env_type = rds2cpp::SEXPType::GLOBALENV_;
+
+            } else if (index == -2) {
+                ptr->env_type = rds2cpp::SEXPType::BASEENV_;
+
+            } else if (index == -3) {
+                ptr->env_type = rds2cpp::SEXPType::EMPTYENV_;
+
+            } else {
+                throw std::runtime_error("unknown special environment index " + std::to_string(index));
             }
 
         } else if (vec.hasAttribute("pretend-to-be-a-builtin")) {

tests/tests/testthat/test-environment.R

@@ -50,6 +50,52 @@ test_that("empty environment writing works as expected", {
     expect_identical(roundtrip, .GlobalEnv)
 })
 
+test_that("base environment loading works as expected", {
+    tmp <- tempfile(fileext=".rds")
+    y <- baseenv()
+    saveRDS(y, file=tmp)
+
+    roundtrip <- rds2cpp:::parse(tmp)
+    expect_identical(roundtrip$value$environment_id, -2L)
+    expect_identical(length(roundtrip$environments), 0L)
+
+    # Adding the baseenv as a parent.
+    tmp <- tempfile(fileext=".rds")
+    y <- new.env(parent=baseenv())
+    y$AA <- 1:5
+    saveRDS(y, file=tmp)
+    roundtrip <- rds2cpp:::parse(tmp)
+
+    expect_identical(roundtrip$value$environment_id, 0L)
+    expect_identical(length(roundtrip$environments), 1L)
+    expect_identical(roundtrip$environments[[1]]$parent, -2L)
+    expect_identical(ls(roundtrip$environments[[1]]$variables), "AA")
+    expect_false(roundtrip$environments[[1]]$locked)
+})
+
+test_that("empty environment loading works as expected", {
+    tmp <- tempfile(fileext=".rds")
+    y <- emptyenv()
+    saveRDS(y, file=tmp)
+
+    roundtrip <- rds2cpp:::parse(tmp)
+    expect_identical(roundtrip$value$environment_id, -3L)
+    expect_identical(length(roundtrip$environments), 0L)
+
+    # Adding the emptyenv as a parent.
+    tmp <- tempfile(fileext=".rds")
+    y <- new.env(parent=emptyenv())
+    y$AA <- 1:5
+    saveRDS(y, file=tmp)
+    roundtrip <- rds2cpp:::parse(tmp)
+
+    expect_identical(roundtrip$value$environment_id, 0L)
+    expect_identical(length(roundtrip$environments), 1L)
+    expect_identical(roundtrip$environments[[1]]$parent, -3L)
+    expect_identical(ls(roundtrip$environments[[1]]$variables), "AA")
+    expect_false(roundtrip$environments[[1]]$locked)
+})
+
 test_that("locked environment loading works as expected", {
     # local() is needed to deal with the fact that the parent
     # environment is mangled somewhat by testthat.
@@ -402,6 +448,37 @@ test_that("environment parenthood works as expected when writing", {
     expect_identical(roundtrip$third$maya, z$third$maya)
 })
 
+test_that("writers work with the special environments", {
+    z <- list(
+        first = {
+            y <- list()
+            attr(y, "pretend-to-be-an-environment") <- TRUE
+            attr(y, "environment-index") <- -1L
+            y
+        },
+        second = {
+            y <- list()
+            attr(y, "pretend-to-be-an-environment") <- TRUE
+            attr(y, "environment-index") <- -2L
+            y
+        },
+        third = {
+            y <- list()
+            attr(y, "pretend-to-be-an-environment") <- TRUE
+            attr(y, "environment-index") <- -3L
+            y
+        }
+    )
+
+    tmp <- tempfile(fileext=".rds")
+    rds2cpp::write(z, file=tmp)
+    roundtrip <- readRDS(tmp)
+
+    expect_identical(roundtrip$first, .GlobalEnv)
+    expect_identical(roundtrip$second, baseenv())
+    expect_identical(roundtrip$third, emptyenv())
+})
+
 test_that("self-references are properly resolved", {
     output <- local({
         y <- new.env()