lobstr/0000755000176200001440000000000015164116517011566 5ustar liggesuserslobstr/tests/0000755000176200001440000000000014024323175012722 5ustar liggesuserslobstr/tests/testthat/0000755000176200001440000000000015164116517014570 5ustar liggesuserslobstr/tests/testthat/test-ast.R0000644000176200001440000000142015105062605016445 0ustar liggesuserstest_that("quosures print same as expressions", { expect_equal(ast_tree(quo(x)), ast_tree(expr(x))) }) test_that("can print complex expression", { skip_on_os("windows") x <- expr(function(x) if (x > 1) f(y$x, "x", g())) expect_snapshot({ ast(!!x) }) }) test_that("can print complex expression without unicode", { old <- options(lobstr.fancy.tree = FALSE) on.exit(options(old)) x <- expr(function(x) if (x > 1) f(y$x, "x", g())) expect_snapshot({ ast(!!x) }) }) test_that("can print scalar expressions nicely", { old <- options(lobstr.fancy.tree = FALSE) on.exit(options(old)) x <- expr(list( logical = c(FALSE, TRUE, NA), integer = 1L, double = 1, character = "a", complex = 1i )) expect_snapshot({ ast(!!x) }) }) lobstr/tests/testthat/test-tree.R0000644000176200001440000001156415105062605016627 0ustar liggesuserstest_that("Array-like indices can be shown or hidden", { testthat::skip_on_os("windows") expect_snapshot({ tree(list(a = "a", "b", "c"), index_unnamed = TRUE) }) expect_snapshot({ tree(list(a = "a", "b", "c"), index_unnamed = FALSE) }) }) test_that("Atomic arrays have sensible defaults w/ truncation for longer than 10-elements", { testthat::skip_on_os("windows") expect_snapshot( tree( list( name = "vectored list", num_vec = 1:10, char_vec = letters ) ) ) expect_snapshot( tree( list( name = "vectored list", num_vec = 1:10, char_vec = letters ), hide_scalar_types = FALSE ) ) }) test_that("Large and multiline strings are handled gracefully", { testthat::skip_on_os("windows") expect_snapshot({ long_strings <- list( "normal string" = "first element", "really long string" = paste(rep(letters, 4), collapse = ""), "vec of long strings" = c( "a long\nand multi\nline string element", "a fine length", "another long\nand also multi\nline string element" ) ) # No truncation of first string # Really long single string is truncated and elipsesed # Short string inside vector with long strings is not truncated tree(long_strings) # Newline removal can be disabled tree(long_strings, remove_newlines = FALSE) }) }) test_that("Max depth and length can be enforced", { # This test also disables the unicode printing so it can be run on windows # platforms old_opts <- options("lobstr.fancy.tree" = FALSE) on.exit(options(old_opts)) expect_snapshot({ deep_list <- list( list( id = "b", val = 1, children = list( list(id = "b1", val = 2.5), list( id = "b2", val = 8, children = list( list(id = "b21", val = 4) ) ) ) ), list(id = "a", val = 2) ) tree(deep_list, max_depth = 1) tree(deep_list, max_depth = 2) tree(deep_list, max_depth = 3) tree(deep_list, max_length = 0) tree(deep_list, max_length = 2) tree(deep_list, max_depth = 1, max_length = 4) }) }) test_that("Missing values are caught and printed properly", { testthat::skip_on_os("windows") expect_snapshot( tree( list( "null-element" = NULL, "NA-element" = NA ) ) ) }) test_that("non-named elements in named list", { testthat::skip_on_os("windows") expect_snapshot( tree(list("a" = 1, "el w/o id")) ) }) test_that("Attributes are properly displayed as special children nodes", { testthat::skip_on_os("windows") expect_snapshot({ list_w_attrs <- structure( list( structure( list(id = "a", val = 2), level = 2, name = "first child" ), structure( list( id = "b", val = 1, children = list( list(id = "b1", val = 2.5) ) ), level = 2, name = "second child", class = "custom-class" ), level = "1", name = "root" ) ) # Shows attributes tree(list_w_attrs, show_attributes = TRUE) # Hides attributes (default) tree(list_w_attrs, show_attributes = FALSE) }) }) test_that("Can optionally recurse into environments", { testthat::skip_on_os("windows") # Wrapped in a local to avoid different environment setup for code running in # test_that instead of interactively # Can't use snapshots here because environment address change on each run env_printing <- capture.output( local( { ea <- rlang::env(d = 4, e = 5) tree(rlang::env(ea, a = 1, b = 2, c = 3)) }, envir = rlang::global_env() ) ) # Seven total nodes should be printed expect_equal( length(env_printing), 4 ) # Printed only the names we expected expect_equal( mean( grepl( pattern = "(environment|a|b|c):", env_printing ) ), 1 ) # Should only print two environment nodes (aka didn't escape past global env) expect_equal( sum(grepl(pattern = " "3.5.0") # Currently reported size is 640 B # If regular vector would be 4,000,040 B # This test is conservative so shouldn't fail in case representation # changes in the future expect_true(obj_size(1:1e6) < 10000) }) test_that("can compute size of deferred string vectors", { x <- 1:10 names(x) <- 10:1 y <- names(x) obj_size(y) # Just assert that it doesn't crash succeed("Didn't crash") }) # Environment sizes ----------------------------------------------------------- test_that("terminal environments have size zero", { expect_equal(obj_size(globalenv()), new_bytes(0)) expect_equal(obj_size(baseenv()), new_bytes(0)) expect_equal(obj_size(emptyenv()), new_bytes(0)) expect_equal(obj_size(asNamespace("stats")), new_bytes(0)) }) test_that("environment size computed recursively", { e <- new.env(parent = emptyenv()) e_size <- obj_size(e) f <- new.env(parent = e) obj_size(f) expect_equal(obj_size(f), 2 * obj_size(e)) }) test_that("size of function includes environment", { f <- function() { y <- 1:1e3 a ~ b } g <- function() { y <- 1:1e3 function() 10 } expect_true(obj_size(f()) > obj_size(1:1e3)) expect_true(obj_size(g()) > obj_size(1:1e3)) }) test_that("size doesn't include parents of current environment", { x <- c(1:1e4) embedded <- (function() { g <- function() { x <- c(1:1e3) a ~ b } obj_size(g()) })() expect_true(embedded < obj_size(x)) }) test_that("support dots in closure environments", { fn <- (function(...) function() NULL)(foo) expect_error(obj_size(fn), NA) }) test_that("supports cons cells", { cell <- new_node(1, 2) expect_equal( obj_size(cell), obj_size(new_node(NULL, NULL)) + obj_size(1) + obj_size(2) ) non_nil_terminated_list <- new_node(1, new_node(2, 3)) expect_equal( obj_size(non_nil_terminated_list), obj_size(new_node(1, NULL)) + obj_size(cell) ) }) test_that("can size environment with loop binding (#48)", { fn <- function() { for (i in 1) { lobstr::obj_size(environment(), env = globalenv()) } } # Compiling causes `i` to be an immediate binding fn <- compiler::cmpfun(fn) # Loop bindings use internal representation that previously caused # "bad binding access" errors when using CAR/TAG accessors expect_no_error(fn()) }) lobstr/tests/testthat/test-sxp.R0000644000176200001440000000527515143623341016506 0ustar liggesuserstest_that("computes spanning tree", { x <- 1:10 y <- list(x, x, x) obj <- sxp(y) expect_false(attr(obj[[1]], "has_seen")) expect_true(attr(obj[[2]], "has_seen")) }) test_that("captures names of special environments", { x <- list( emptyenv(), baseenv(), globalenv() ) obj <- sxp(x) expect_equal(attr(obj[[1]], "value"), "empty") expect_equal(attr(obj[[2]], "value"), "base") expect_equal(attr(obj[[3]], "value"), "global") }) test_that("captures names of lists", { x <- list(a = 1, b = 2, c = 3) obj <- sxp(x) expect_named(obj, c(names(x), "_attrib")) }) test_that("can expand lists", { x <- c("xxx", "xxx", "y") obj <- sxp(x, expand = "character") expect_length(obj, 3) expect_equal(attr(obj[[1]], "ref"), attr(obj[[2]], "ref")) }) test_that("can inspect active bindings", { e <- new.env(hash = FALSE) env_bind_active(e, f = function() stop("!")) x <- sxp(e) expect_named(x, c("f", "_enclos")) }) test_that("snapshots environment binding types", { e <- new.env(parent = emptyenv(), hash = FALSE) # value e$value <- 1 # missing argument binding env_bind(e, missing = missing_arg()) # delayed and forced promise bindings delayedAssign("delayed", 1 + 1, assign.env = e) delayedAssign("forced", 1 + 1, assign.env = e) invisible(e$forced) # active binding env_bind_active(e, active = function() 42) expect_snapshot({ print(sxp(e)) print(sxp(e, expand = "environment", max_depth = 6L)) }) }) # Regression tests -------------------------------------------------------- test_that("can inspect all atomic vectors", { x <- list( TRUE, 1L, 1, "3", 1i, raw(1) ) expect_snapshot(sxp(x)) }) test_that("can inspect functions", { f <- function(x, y = 1, ...) x + 1 attr(f, "srcref") <- NULL environment(f) <- globalenv() expect_snapshot(sxp(f)) }) test_that("can inspect environments", { e1 <- new.env(parent = emptyenv(), size = 5L) e1$x <- 10 e1$y <- e1 e2 <- new.env(parent = e1, size = 5L) expect_snapshot({ print(sxp(e2)) print(sxp(e2, expand = "environment", max_depth = 5L)) }) }) test_that("can expand altrep", { skip_if_not(getRversion() >= "3.5") skip_if_not(.Machine$sizeof.pointer == 8) # _class RAWSXP has different size expect_snapshot({ x <- 1:10 print(sxp(x, expand = "altrep", max_depth = 4L)) }) }) test_that("can inspect cons cells", { expect_snapshot({ cell <- new_node(1, 2) sxp(cell) non_nil_terminated_list <- new_node(1, new_node(2, 3)) sxp(non_nil_terminated_list) }) }) test_that("fix error message when `expand` argument contains invalid classes", { expect_snapshot(error = TRUE, { sxp(1, expand = "invalid_class") }) }) lobstr/tests/testthat/helper-src.R0000644000176200001440000000230515143624757016766 0ustar liggesusers# Snapshot transformer to scrub src() output for deterministic snapshots scrub_src_transform <- function(lines) { lines <- gsub('filename: "[^"]+"', 'filename: ""', lines) lines <- gsub('directory: "[^"]+"', 'directory: ""', lines) lines <- gsub('timestamp: "[^"]+"', 'timestamp: ""', lines) lines <- gsub('wd: "[^"]+"', 'wd: ""', lines) lines } with_srcref <- function(code, env = parent.frame(), file = NULL) { if (is.null(file)) { file <- tempfile("test_srcref", fileext = ".R") on.exit(unlink(file), add = TRUE) } writeLines(code, file) source(file, local = env, keep.source = TRUE) } parse_with_srcref <- function(code) { parse(text = code, keep.source = TRUE) } simple_function_with_srcref <- function() { code <- c( "test_func <- function(x, y) {", " x + y", "}" ) env <- new.env(parent = baseenv()) with_srcref(code, env = env) env$test_func } multi_statement_function_with_srcref <- function() { code <- c( "multi_func <- function(x) {", " a <- x + 1", " b <- a * 2", " c <- b - 3", " c", "}" ) env <- new.env(parent = baseenv()) with_srcref(code, env = env) env$multi_func } lobstr/tests/testthat/_snaps/0000755000176200001440000000000015143624757016062 5ustar liggesuserslobstr/tests/testthat/_snaps/sxp.md0000644000176200001440000000630515163460160017206 0ustar liggesusers# snapshots environment binding types Code print(sxp(e)) Output [1] () active forced delayed missing value [2] () _enclos [3] () Code print(sxp(e, expand = "environment", max_depth = 6L)) Output [1] () active _fn [2] () _formals _body [4] () _env [5] () e [1] _enclos [6] () _enclos [7] () _enclos [8] () ... _attrib [9] () srcref [10] (object ) _attrib [11] () srcfile [12] (object ) ... class [13] () ... forced _value [14] () _code [15] () ... delayed _code [16] () ... _env [5] missing value [17] () _enclos [18] () # can inspect all atomic vectors Code sxp(x) Output [1] () [2] () [3] () [4] () [5] () [6] () [7] () # can inspect functions Code sxp(f) Output [1] () _formals [2] () x [3] () y [4] () ... [3] _body [5] () ... _env [6] () # can inspect environments Code print(sxp(e2)) Output [1] () _enclos [2] () x [3] () y [2] _enclos [4] () Code print(sxp(e2, expand = "environment", max_depth = 5L)) Output [1] () _enclos [2] () x [3] () y [2] _enclos [4] () # can expand altrep Code x <- 1:10 print(sxp(x, expand = "altrep", max_depth = 4L)) Output [1] (altrep ) _class [2] () _attrib [3] () [4] () [5] () [6] () _data1 [7] () _data2 # can inspect cons cells Code cell <- new_node(1, 2) sxp(cell) Output [1] () [2] () _cdr [3] () Code non_nil_terminated_list <- new_node(1, new_node(2, 3)) sxp(non_nil_terminated_list) Output [1] () [2] () [3] () _cdr [4] () # fix error message when `expand` argument contains invalid classes Code sxp(1, expand = "invalid_class") Condition Error in `sxp()`: ! `expand` must contain only values from: 'character', 'altrep', 'environment', 'call', 'bytecode'. lobstr/tests/testthat/_snaps/size.md0000644000176200001440000000016015163460160017337 0ustar liggesusers# combined bytes are aligned Code new_bytes(c(400, 4e+05)) Output * 400 B * 400 kB lobstr/tests/testthat/_snaps/ast.md0000644000176200001440000000173415163460160017164 0ustar liggesusers# can print complex expression Code ast(!!x) Output █─`function` ├─█─x = `` ├─█─`if` │ ├─█─`>` │ │ ├─x │ │ └─1 │ └─█─f │ ├─█─`$` │ │ ├─y │ │ └─x │ ├─"x" │ └─█─g └─ # can print complex expression without unicode Code ast(!!x) Output o-`function` +-o-x = `` +-o-`if` | +-o-`>` | | +-x | | \-1 | \-o-f | +-o-`$` | | +-y | | \-x | +-"x" | \-o-g \- # can print scalar expressions nicely Code ast(!!x) Output o-list +-logical = o-c | +-FALSE | +-TRUE | \-NA +-integer = 1L +-double = 1 +-character = "a" \-complex = 1i lobstr/tests/testthat/_snaps/ref.md0000644000176200001440000000213015163460160017140 0ustar liggesusers# basic list display Code x <- 1:10 y <- list(x, x) ref(x, list(), list(x, x, x), list(a = x, b = x), letters) Output [1:0x001] █ [2:0x002] █ [3:0x003] ├─[1:0x001] ├─[1:0x001] └─[1:0x001] █ [4:0x004] ├─a = [1:0x001] └─b = [1:0x001] [5:0x005] # basic environment display Code e <- env(a = 1:10) e$b <- e$a e$c <- e ref(e) Output █ [1:0x001] ├─a = [2:0x002] ├─b = [2:0x002] └─c = [1:0x001] # environment shows objects beginning with . Code e <- env(. = 1:10) ref(e) Output █ [1:0x001] └─. = [2:0x002] # can display ref to global string pool on request Code ref(c("string", "string", "new string"), character = TRUE) Output █ [1:0x001] ├─[2:0x002] ├─[2:0x002] └─[3:0x003] lobstr/tests/testthat/_snaps/src.md0000644000176200001440000006642315163460160017172 0ustar liggesusers# src() shows closure with srcref and wholeSrcref Code f <- simple_function_with_srcref() src(f) Output ├─attr("srcref"): │ ├─location: 1:14 - 3:1 │ └─attr("srcfile"): @001 │ ├─Enc: "unknown" │ ├─filename: "" │ ├─fixedNewlines: TRUE │ ├─isFile: TRUE │ ├─lines: "test_func <-...", " x + y", "}" │ ├─parseData: 1, 1, 1, ... │ ├─timestamp: "" │ └─wd: "" └─body(): <{> ├─attr("srcref"): │ ├─[[1]]: │ │ ├─location: 1:29 - 1:29 │ │ └─attr("srcfile"): @001 │ └─[[2]]: │ ├─location: 2:3 - 2:7 │ └─attr("srcfile"): @001 ├─attr("srcfile"): @001 └─attr("wholeSrcref"): ├─location: 1:0 - 3:1 └─attr("srcfile"): @001 # src() shows multi-statement function Code f <- multi_statement_function_with_srcref() src(f) Output ├─attr("srcref"): │ ├─location: 1:15 - 6:1 │ └─attr("srcfile"): @001 │ ├─Enc: "unknown" │ ├─filename: "" │ ├─fixedNewlines: TRUE │ ├─isFile: TRUE │ ├─lines: "multi_func <...", " a <- x + 1", " b <- a * 2", ... │ ├─parseData: 1, 1, 1, ... │ ├─timestamp: "" │ └─wd: "" └─body(): <{> ├─attr("srcref"): │ ├─[[1]]: │ │ ├─location: 1:27 - 1:27 │ │ └─attr("srcfile"): @001 │ ├─[[2]]: │ │ ├─location: 2:3 - 2:12 │ │ └─attr("srcfile"): @001 │ ├─[[3]]: │ │ ├─location: 3:3 - 3:12 │ │ └─attr("srcfile"): @001 │ ├─[[4]]: │ │ ├─location: 4:3 - 4:12 │ │ └─attr("srcfile"): @001 │ └─[[5]]: │ ├─location: 5:3 - 5:3 │ └─attr("srcfile"): @001 ├─attr("srcfile"): @001 └─attr("wholeSrcref"): ├─location: 1:0 - 6:1 └─attr("srcfile"): @001 # src() shows quoted function with nested body Code with_srcref("x <- quote(function() {})") src(x) Output ├─[[3]]: <{> │ ├─attr("srcref"): │ │ └─[[1]]: │ │ ├─location: 1:23 - 1:23 │ │ └─attr("srcfile"): @001 │ │ ├─Enc: "unknown" │ │ ├─filename: "" │ │ ├─fixedNewlines: TRUE │ │ ├─isFile: TRUE │ │ ├─lines: "x <- quote(function() {})" │ │ ├─parseData: 1, 1, 1, ...... │ │ ├─timestamp: "" │ │ └─wd: "" │ ├─attr("srcfile"): @001 │ └─attr("wholeSrcref"): │ ├─location: 1:0 - 1:24 │ └─attr("srcfile"): @001 └─[[4]]: ├─location: 1:12 - 1:24 └─attr("srcfile"): @001 # src() shows quoted function body directly Code with_srcref("x <- quote(function() {})") src(x[[3]]) Output <{> ├─attr("srcref"): │ └─[[1]]: │ ├─location: 1:23 - 1:23 │ └─attr("srcfile"): @001 │ ├─Enc: "unknown" │ ├─filename: "" │ ├─fixedNewlines: TRUE │ ├─isFile: TRUE │ ├─lines: "x <- quote(function() {})" │ ├─parseData: 1, 1, 1, ... │ ├─timestamp: "" │ └─wd: "" ├─attr("srcfile"): @001 └─attr("wholeSrcref"): ├─location: 1:0 - 1:24 └─attr("srcfile"): @001 # src() shows quoted function with arguments Code with_srcref("x <- quote(function(a, b) {})") src(x) Output ├─[[3]]: <{> │ ├─attr("srcref"): │ │ └─[[1]]: │ │ ├─location: 1:27 - 1:27 │ │ └─attr("srcfile"): @001 │ │ ├─Enc: "unknown" │ │ ├─filename: "" │ │ ├─fixedNewlines: TRUE │ │ ├─isFile: TRUE │ │ ├─lines: "x <- quote(function(a, b) {})" │ │ ├─parseData: 1, 1, 1, ...... │ │ ├─timestamp: "" │ │ └─wd: "" │ ├─attr("srcfile"): @001 │ └─attr("wholeSrcref"): │ ├─location: 1:0 - 1:28 │ └─attr("srcfile"): @001 └─[[4]]: ├─location: 1:12 - 1:28 └─attr("srcfile"): @001 # src() shows srcref with parsed field when positions differ Code srcfile <- srcfilecopy("test.R", c("x <- function() {", " # A long comment that spans", " # multiple lines", " y <- 1", "}")) synthetic_srcref <- structure(c(2L, 3L, 4L, 8L, 3L, 8L, 1L, 5L), class = "srcref", srcfile = srcfile) src(synthetic_srcref) Output ├─location: 2:3 - 4:8 ├─parsed: 1:3 - 5:8 └─attr("srcfile"): @001 ├─Enc: "unknown" ├─filename: "" ├─fixedNewlines: TRUE ├─isFile: FALSE ├─lines: "x <- functio...", " # A long c...", " # multiple...", ... ├─timestamp: "" └─wd: "" # src() shows expression with single element Code x <- parse(text = "x + 1", keep.source = TRUE) src(x) Output ├─attr("srcref"): │ └─[[1]]: │ ├─location: 1:1 - 1:5 │ └─attr("srcfile"): @001 │ ├─Enc: "unknown" │ ├─filename: "" │ ├─fixedNewlines: TRUE │ ├─isFile: FALSE │ ├─lines: "x + 1" │ ├─parseData: 1, 1, 1, ... │ ├─timestamp: "" │ └─wd: "" ├─attr("srcfile"): @001 └─attr("wholeSrcref"): ├─location: 1:0 - 2:0 └─attr("srcfile"): @001 # src() shows expression with multiple elements Code x <- parse(text = c("x + 1", "y + 2", "z + 3"), keep.source = TRUE) src(x) Output ├─attr("srcref"): │ ├─[[1]]: │ │ ├─location: 1:1 - 1:5 │ │ └─attr("srcfile"): @001 │ │ ├─Enc: "unknown" │ │ ├─filename: "" │ │ ├─fixedNewlines: TRUE │ │ ├─isFile: FALSE │ │ ├─lines: "x + 1", "y + 2", "z + 3" │ │ ├─parseData: 1, 1, 1, ... │ │ ├─timestamp: "" │ │ └─wd: "" │ ├─[[2]]: │ │ ├─location: 2:1 - 2:5 │ │ └─attr("srcfile"): @001 │ └─[[3]]: │ ├─location: 3:1 - 3:5 │ └─attr("srcfile"): @001 ├─attr("srcfile"): @001 └─attr("wholeSrcref"): ├─location: 1:0 - 4:0 └─attr("srcfile"): @001 # src() shows expression with nested block and wholeSrcref Code x <- parse(text = "{\n 1\n}", keep.source = TRUE) src(x) Output ├─attr("srcref"): │ └─[[1]]: │ ├─location: 1:1 - 3:1 │ └─attr("srcfile"): @001 │ ├─Enc: "unknown" │ ├─filename: "" │ ├─fixedNewlines: TRUE │ ├─isFile: FALSE │ ├─lines: "{", " 1", "}" │ ├─parseData: 1, 1, 1, ... │ ├─timestamp: "" │ └─wd: "" ├─attr("srcfile"): @001 ├─attr("wholeSrcref"): │ ├─location: 1:0 - 4:0 │ └─attr("srcfile"): @001 └─[[1]]: <{> ├─attr("srcref"): │ ├─[[1]]: │ │ ├─location: 1:1 - 1:1 │ │ └─attr("srcfile"): @001 │ └─[[2]]: │ ├─location: 2:3 - 2:3 │ └─attr("srcfile"): @001 ├─attr("srcfile"): @001 └─attr("wholeSrcref"): ├─location: 1:0 - 3:1 └─attr("srcfile"): @001 # src() shows nested block element directly Code x <- parse(text = "{\n 1\n}", keep.source = TRUE) src(x[[1]]) Output <{> ├─attr("srcref"): │ ├─[[1]]: │ │ ├─location: 1:1 - 1:1 │ │ └─attr("srcfile"): @001 │ │ ├─Enc: "unknown" │ │ ├─filename: "" │ │ ├─fixedNewlines: TRUE │ │ ├─isFile: FALSE │ │ ├─lines: "{", " 1", "}" │ │ ├─parseData: 1, 1, 1, ... │ │ ├─timestamp: "" │ │ └─wd: "" │ └─[[2]]: │ ├─location: 2:3 - 2:3 │ └─attr("srcfile"): @001 ├─attr("srcfile"): @001 └─attr("wholeSrcref"): ├─location: 1:0 - 3:1 └─attr("srcfile"): @001 # src() shows block with srcref list and wholeSrcref Code x <- parse(text = "{\n a <- 1\n b <- 2\n}", keep.source = TRUE) src(x[[1]]) Output <{> ├─attr("srcref"): │ ├─[[1]]: │ │ ├─location: 1:1 - 1:1 │ │ └─attr("srcfile"): @001 │ │ ├─Enc: "unknown" │ │ ├─filename: "" │ │ ├─fixedNewlines: TRUE │ │ ├─isFile: FALSE │ │ ├─lines: "{", " a <- 1", " b <- 2", ... │ │ ├─parseData: 1, 1, 1, ... │ │ ├─timestamp: "" │ │ └─wd: "" │ ├─[[2]]: │ │ ├─location: 2:3 - 2:8 │ │ └─attr("srcfile"): @001 │ └─[[3]]: │ ├─location: 3:3 - 3:8 │ └─attr("srcfile"): @001 ├─attr("srcfile"): @001 └─attr("wholeSrcref"): ├─location: 1:0 - 4:1 └─attr("srcfile"): @001 # src() shows single srcref Code x <- parse(text = "x + 1", keep.source = TRUE) sr <- attr(x, "srcref")[[1]] src(sr) Output ├─location: 1:1 - 1:5 └─attr("srcfile"): @001 ├─Enc: "unknown" ├─filename: "" ├─fixedNewlines: TRUE ├─isFile: FALSE ├─lines: "x + 1" ├─parseData: 1, 1, 1, ... ├─timestamp: "" └─wd: "" # src() shows list of srcrefs with count Code x <- parse(text = c("x + 1", "y + 2"), keep.source = TRUE) sr_list <- attr(x, "srcref") src(sr_list) Output ├─[[1]]: │ ├─location: 1:1 - 1:5 │ └─attr("srcfile"): @001 │ ├─Enc: "unknown" │ ├─filename: "" │ ├─fixedNewlines: TRUE │ ├─isFile: FALSE │ ├─lines: "x + 1", "y + 2" │ ├─parseData: 1, 1, 1, ... │ ├─timestamp: "" │ └─wd: "" └─[[2]]: ├─location: 2:1 - 2:5 └─attr("srcfile"): @001 # src() reveals srcref list structure with index notation Code with_srcref("x <- quote(function() { 1 })") src(x[[3]]) Output <{> ├─attr("srcref"): │ ├─[[1]]: │ │ ├─location: 1:23 - 1:23 │ │ └─attr("srcfile"): @001 │ │ ├─Enc: "unknown" │ │ ├─filename: "" │ │ ├─fixedNewlines: TRUE │ │ ├─isFile: TRUE │ │ ├─lines: "x <- quote(function() { 1 })" │ │ ├─parseData: 1, 1, 1, ... │ │ ├─timestamp: "" │ │ └─wd: "" │ └─[[2]]: │ ├─location: 1:25 - 1:25 │ └─attr("srcfile"): @001 ├─attr("srcfile"): @001 └─attr("wholeSrcref"): ├─location: 1:0 - 1:27 └─attr("srcfile"): @001 # src() handles srcrefs nested in language calls Code x <- parse(text = "foo({ if (1) bar({ 2 }) })", keep.source = TRUE) src(x, max_depth = 10) Output ├─attr("srcref"): │ └─[[1]]: │ ├─location: 1:1 - 1:26 │ └─attr("srcfile"): @001 │ ├─Enc: "unknown" │ ├─filename: "" │ ├─fixedNewlines: TRUE │ ├─isFile: FALSE │ ├─lines: "foo({ if (1) bar({ 2 }) })" │ ├─parseData: 1, 1, 1, ... │ ├─timestamp: "" │ └─wd: "" ├─attr("srcfile"): @001 ├─attr("wholeSrcref"): │ ├─location: 1:0 - 2:0 │ └─attr("srcfile"): @001 └─[[1]][[2]]: <{> ├─attr("srcref"): │ ├─[[1]]: │ │ ├─location: 1:5 - 1:5 │ │ └─attr("srcfile"): @001 │ └─[[2]]: │ ├─location: 1:7 - 1:23 │ └─attr("srcfile"): @001 ├─attr("srcfile"): @001 ├─attr("wholeSrcref"): │ ├─location: 1:0 - 1:25 │ └─attr("srcfile"): @001 └─[[2]][[3]][[2]]: <{> ├─attr("srcref"): │ ├─[[1]]: │ │ ├─location: 1:18 - 1:18 │ │ └─attr("srcfile"): @001 │ └─[[2]]: │ ├─location: 1:20 - 1:20 │ └─attr("srcfile"): @001 ├─attr("srcfile"): @001 └─attr("wholeSrcref"): ├─location: 1:0 - 1:22 └─attr("srcfile"): @001 # src() handles srcrefs nested in function bodies Code with_srcref("f <- function() foo({ if (1) bar({ 2 }) })") src(f, max_depth = 10) Output ├─attr("srcref"): │ ├─location: 1:6 - 1:42 │ └─attr("srcfile"): @001 │ ├─Enc: "unknown" │ ├─filename: "" │ ├─fixedNewlines: TRUE │ ├─isFile: TRUE │ ├─lines: "f <- function() foo({ if (1) bar..." │ ├─parseData: 1, 1, 1, ... │ ├─timestamp: "" │ └─wd: "" └─body(): └─[[2]]: <{> ├─attr("srcref"): │ ├─[[1]]: │ │ ├─location: 1:21 - 1:21 │ │ └─attr("srcfile"): @001 │ └─[[2]]: │ ├─location: 1:23 - 1:39 │ └─attr("srcfile"): @001 ├─attr("srcfile"): @001 ├─attr("wholeSrcref"): │ ├─location: 1:0 - 1:41 │ └─attr("srcfile"): @001 └─[[2]][[3]][[2]]: <{> ├─attr("srcref"): │ ├─[[1]]: │ │ ├─location: 1:34 - 1:34 │ │ └─attr("srcfile"): @001 │ └─[[2]]: │ ├─location: 1:36 - 1:36 │ └─attr("srcfile"): @001 ├─attr("srcfile"): @001 └─attr("wholeSrcref"): ├─location: 1:0 - 1:38 └─attr("srcfile"): @001 # src() currently shows duplicate srcfile objects Code f <- simple_function_with_srcref() src(f) Output ├─attr("srcref"): │ ├─location: 1:14 - 3:1 │ └─attr("srcfile"): @001 │ ├─Enc: "unknown" │ ├─filename: "" │ ├─fixedNewlines: TRUE │ ├─isFile: TRUE │ ├─lines: "test_func <-...", " x + y", "}" │ ├─parseData: 1, 1, 1, ... │ ├─timestamp: "" │ └─wd: "" └─body(): <{> ├─attr("srcref"): │ ├─[[1]]: │ │ ├─location: 1:29 - 1:29 │ │ └─attr("srcfile"): @001 │ └─[[2]]: │ ├─location: 2:3 - 2:7 │ └─attr("srcfile"): @001 ├─attr("srcfile"): @001 └─attr("wholeSrcref"): ├─location: 1:0 - 3:1 └─attr("srcfile"): @001 # src() shows many duplicate srcfiles in nested expression Code x <- parse(text = "{\n 1\n 2\n}", keep.source = TRUE) src(x) Output ├─attr("srcref"): │ └─[[1]]: │ ├─location: 1:1 - 4:1 │ └─attr("srcfile"): @001 │ ├─Enc: "unknown" │ ├─filename: "" │ ├─fixedNewlines: TRUE │ ├─isFile: FALSE │ ├─lines: "{", " 1", " 2", ... │ ├─parseData: 1, 1, 1, ... │ ├─timestamp: "" │ └─wd: "" ├─attr("srcfile"): @001 ├─attr("wholeSrcref"): │ ├─location: 1:0 - 5:0 │ └─attr("srcfile"): @001 └─[[1]]: <{> ├─attr("srcref"): │ ├─[[1]]: │ │ ├─location: 1:1 - 1:1 │ │ └─attr("srcfile"): @001 │ ├─[[2]]: │ │ ├─location: 2:3 - 2:3 │ │ └─attr("srcfile"): @001 │ └─[[3]]: │ ├─location: 3:3 - 3:3 │ └─attr("srcfile"): @001 ├─attr("srcfile"): @001 └─attr("wholeSrcref"): ├─location: 1:0 - 4:1 └─attr("srcfile"): @001 # src() handles empty block Code x <- parse(text = "{}", keep.source = TRUE) src(x[[1]]) Output <{> ├─attr("srcref"): │ └─[[1]]: │ ├─location: 1:1 - 1:1 │ └─attr("srcfile"): @001 │ ├─Enc: "unknown" │ ├─filename: "" │ ├─fixedNewlines: TRUE │ ├─isFile: FALSE │ ├─lines: "{}" │ ├─parseData: 1, 1, 1, ... │ ├─timestamp: "" │ └─wd: "" ├─attr("srcfile"): @001 └─attr("wholeSrcref"): ├─location: 1:0 - 1:2 └─attr("srcfile"): @001 # src() handles function without arguments Code with_srcref("f <- function() { NULL }") src(f) Output ├─attr("srcref"): │ ├─location: 1:6 - 1:24 │ └─attr("srcfile"): @001 │ ├─Enc: "unknown" │ ├─filename: "" │ ├─fixedNewlines: TRUE │ ├─isFile: TRUE │ ├─lines: "f <- function() { NULL }" │ ├─parseData: 1, 1, 1, ... │ ├─timestamp: "" │ └─wd: "" └─body(): <{> ├─attr("srcref"): │ ├─[[1]]: │ │ ├─location: 1:17 - 1:17 │ │ └─attr("srcfile"): @001 │ └─[[2]]: │ ├─location: 1:19 - 1:22 │ └─attr("srcfile"): @001 ├─attr("srcfile"): @001 └─attr("wholeSrcref"): ├─location: 1:0 - 1:24 └─attr("srcfile"): @001 # src() handles if statement with blocks Code x <- parse(text = "if (TRUE) { 1 } else { 2 }", keep.source = TRUE) src(x) Output ├─attr("srcref"): │ └─[[1]]: │ ├─location: 1:1 - 1:26 │ └─attr("srcfile"): @001 │ ├─Enc: "unknown" │ ├─filename: "" │ ├─fixedNewlines: TRUE │ ├─isFile: FALSE │ ├─lines: "if (TRUE) { 1 } else { 2 }" │ ├─parseData: 1, 1, 1, ... │ ├─timestamp: "" │ └─wd: "" ├─attr("srcfile"): @001 ├─attr("wholeSrcref"): │ ├─location: 1:0 - 2:0 │ └─attr("srcfile"): @001 ├─[[1]][[3]]: <{> │ ├─attr("srcref"): │ │ ├─[[1]]: │ │ │ ├─location: 1:11 - 1:11 │ │ │ └─attr("srcfile"): @001 │ │ └─[[2]]: │ │ ├─location: 1:13 - 1:13 │ │ └─attr("srcfile"): @001 │ ├─attr("srcfile"): @001 │ └─attr("wholeSrcref"): │ ├─location: 1:0 - 1:15 │ └─attr("srcfile"): @001 └─[[1]][[4]]: <{> ├─attr("srcref"): │ ├─[[1]]: │ │ ├─location: 1:22 - 1:22 │ │ └─attr("srcfile"): @001 │ └─[[2]]: │ ├─location: 1:24 - 1:24 │ └─attr("srcfile"): @001 ├─attr("srcfile"): @001 └─attr("wholeSrcref"): ├─location: 1:0 - 1:26 └─attr("srcfile"): @001 # src() respects show_source_lines parameter Code f <- simple_function_with_srcref() src(f) Output ├─attr("srcref"): │ ├─location: 1:14 - 3:1 │ └─attr("srcfile"): @001 │ ├─Enc: "unknown" │ ├─filename: "" │ ├─fixedNewlines: TRUE │ ├─isFile: TRUE │ ├─lines: "test_func <-...", " x + y", "}" │ ├─parseData: 1, 1, 1, ... │ ├─timestamp: "" │ └─wd: "" └─body(): <{> ├─attr("srcref"): │ ├─[[1]]: │ │ ├─location: 1:29 - 1:29 │ │ └─attr("srcfile"): @001 │ └─[[2]]: │ ├─location: 2:3 - 2:7 │ └─attr("srcfile"): @001 ├─attr("srcfile"): @001 └─attr("wholeSrcref"): ├─location: 1:0 - 3:1 └─attr("srcfile"): @001 # src() shows expression with multiple nested blocks Code x <- parse(text = "{\n {\n 1\n }\n {\n 2\n }\n}", keep.source = TRUE) src(x) Output ├─attr("srcref"): │ └─[[1]]: │ ├─location: 1:1 - 8:1 │ └─attr("srcfile"): @001 │ ├─Enc: "unknown" │ ├─filename: "" │ ├─fixedNewlines: TRUE │ ├─isFile: FALSE │ ├─lines: "{", " {", " 1", ... │ ├─parseData: 1, 1, 1, ... │ ├─timestamp: "" │ └─wd: "" ├─attr("srcfile"): @001 ├─attr("wholeSrcref"): │ ├─location: 1:0 - 9:0 │ └─attr("srcfile"): @001 └─[[1]]: <{> ├─attr("srcref"): │ ├─[[1]]: │ │ ├─location: 1:1 - 1:1 │ │ └─attr("srcfile"): @001 │ ├─[[2]]: │ │ ├─location: 2:3 - 4:3 │ │ └─attr("srcfile"): @001 │ └─[[3]]: │ ├─location: 5:3 - 7:3 │ └─attr("srcfile"): @001 ├─attr("srcfile"): @001 ├─attr("wholeSrcref"): │ ├─location: 1:0 - 8:1 │ └─attr("srcfile"): @001 ├─[[2]]: <{> │ ├─attr("srcref"): │ │ ├─[[1]]: │ │ │ ├─location: 2:3 - 2:3 │ │ │ └─attr("srcfile"): @001 │ │ └─[[2]]: │ │ ├─location: 3:5 - 3:5 │ │ └─attr("srcfile"): @001 │ ├─attr("srcfile"): @001 │ └─attr("wholeSrcref"): │ ├─location: 1:0 - 4:3 │ └─attr("srcfile"): @001 └─[[3]]: <{> ├─attr("srcref"): │ ├─[[1]]: │ │ ├─location: 5:3 - 5:3 │ │ └─attr("srcfile"): @001 │ └─[[2]]: │ ├─location: 6:5 - 6:5 │ └─attr("srcfile"): @001 ├─attr("srcfile"): @001 └─attr("wholeSrcref"): ├─location: 1:0 - 7:3 └─attr("srcfile"): @001 # src() shows function with nested block in body Code with_srcref("f <- function(x) {\n if (x) {\n 1\n }\n}") src(f) Output ├─attr("srcref"): │ ├─location: 1:6 - 5:1 │ └─attr("srcfile"): @001 │ ├─Enc: "unknown" │ ├─filename: "" │ ├─fixedNewlines: TRUE │ ├─isFile: TRUE │ ├─lines: "f <- functio...", " if (x) {", " 1", ... │ ├─parseData: 1, 1, 1, ... │ ├─timestamp: "" │ └─wd: "" └─body(): <{> ├─attr("srcref"): │ ├─[[1]]: │ │ ├─location: 1:18 - 1:18 │ │ └─attr("srcfile"): @001 │ └─[[2]]: │ ├─location: 2:3 - 4:3 │ └─attr("srcfile"): @001 ├─attr("srcfile"): @001 ├─attr("wholeSrcref"): │ ├─location: 1:0 - 5:1 │ └─attr("srcfile"): @001 └─[[2]][[3]]: <{> ├─attr("srcref"): │ ├─[[1]]: │ │ ├─location: 2:10 - 2:10 │ │ └─attr("srcfile"): @001 │ └─[[2]]: │ ├─location: 3:5 - 3:5 │ └─attr("srcfile"): @001 ├─attr("srcfile"): @001 └─attr("wholeSrcref"): ├─location: 1:0 - 4:3 └─attr("srcfile"): @001 lobstr/tests/testthat/_snaps/tree.md0000644000176200001440000001313315163460161017331 0ustar liggesusers# Array-like indices can be shown or hidden Code tree(list(a = "a", "b", "c"), index_unnamed = TRUE) Output ├─a: "a" ├─2: "b" └─3: "c" --- Code tree(list(a = "a", "b", "c"), index_unnamed = FALSE) Output ├─a: "a" ├─"b" └─"c" # Atomic arrays have sensible defaults w/ truncation for longer than 10-elements Code tree(list(name = "vectored list", num_vec = 1:10, char_vec = letters)) Output ├─name: "vectored list" ├─num_vec: 1, 2, 3, 4, 5, 6, 7, 8, 9, 10 └─char_vec: "a", "b", "c", "d", "e", "f", "g", "h", "i", "j", ... --- Code tree(list(name = "vectored list", num_vec = 1:10, char_vec = letters), hide_scalar_types = FALSE) Output ├─name: "vectored list" ├─num_vec: 1, 2, 3, 4, 5, 6, 7, 8, 9, 10 └─char_vec: "a", "b", "c", "d", "e", "f", "g", "h", "i", "j", ... # Large and multiline strings are handled gracefully Code long_strings <- list(`normal string` = "first element", `really long string` = paste( rep(letters, 4), collapse = ""), `vec of long strings` = c( "a long\nand multi\nline string element", "a fine length", "another long\nand also multi\nline string element")) tree(long_strings) Output ├─normal string: "first element" ├─really long string: "abcdefghijklmnopqrstuvwxyzabcdef..." └─vec of long strings: "a long↵and m...", "a fine length", "another long..." Code tree(long_strings, remove_newlines = FALSE) Output ├─normal string: "first element" ├─really long string: "abcdefghijklmnopqrstuvwxyzabcdef..." └─vec of long strings: "a long and m...", "a fine length", "another long..." # Max depth and length can be enforced Code deep_list <- list(list(id = "b", val = 1, children = list(list(id = "b1", val = 2.5), list(id = "b2", val = 8, children = list(list(id = "b21", val = 4))))), list( id = "a", val = 2)) tree(deep_list, max_depth = 1) Output +-... \-... Code tree(deep_list, max_depth = 2) Output +- | +-id: "b" | +-val: 1 | \-children: ... \- +-id: "a" \-val: 2 Code tree(deep_list, max_depth = 3) Output +- | +-id: "b" | +-val: 1 | \-children: | +-... | \-... \- +-id: "a" \-val: 2 Code tree(deep_list, max_length = 0) Output ... Code tree(deep_list, max_length = 2) Output +- ... Code tree(deep_list, max_depth = 1, max_length = 4) Output +-... \-... # Missing values are caught and printed properly Code tree(list(`null-element` = NULL, `NA-element` = NA)) Output ├─null-element: └─NA-element: NA # non-named elements in named list Code tree(list(a = 1, "el w/o id")) Output ├─a: 1 └─"el w/o id" # Attributes are properly displayed as special children nodes Code list_w_attrs <- structure(list(structure(list(id = "a", val = 2), level = 2, name = "first child"), structure(list(id = "b", val = 1, children = list(list( id = "b1", val = 2.5))), level = 2, name = "second child", class = "custom-class"), level = "1", name = "root")) tree(list_w_attrs, show_attributes = TRUE) Output ├─ │ ├─id: "a" │ ├─val: 2 │ ├┄attr(,"names"): "id", "val" │ ├┄attr(,"level"): 2 │ └┄attr(,"name"): "first child" ├─S3 │ ├─id: "b" │ ├─val: 1 │ ├─children: │ ┊ └─ │ ┊ ├─id: "b1" │ ┊ ├─val: 2.5 │ ┊ └┄attr(,"names"): "id", "val" │ ├┄attr(,"names"): "id", "val", "children" │ ├┄attr(,"level"): 2 │ ├┄attr(,"name"): "second child" │ └┄attr(,"class"): "custom-class" ├─level: "1" ├─name: "root" └┄attr(,"names"): "", "", "level", "name" Code tree(list_w_attrs, show_attributes = FALSE) Output ├─ │ ├─id: "a" │ └─val: 2 ├─S3 │ ├─id: "b" │ ├─val: 1 │ └─children: │ └─ │ ├─id: "b1" │ └─val: 2.5 ├─level: "1" └─name: "root" # Function arguments get printed Code tree(list(no_args = function() { }, few_args = function(a, b, c) { }, lots_of_args = function(d, e, f, g, h, i, j, k, l, m, n, o, p) { })) Output ├─no_args: function() ├─few_args: function(a, b, c) └─lots_of_args: function(d, e, f, g, h, ...) # Handles expressions Code tree(list(a = quote(a), b = quote(a + 1), c = y ~ mx + b)) Output ├─a: a ├─b: a + 1 └─c: S3 y ~ mx + b # Hidden lists dont cause infinite recursion Code tree(package_version("1.2.3")) Output S3 └─1, 2, 3 lobstr/tests/testthat/test-src.R0000644000176200001440000007006215143624757016473 0ustar liggesusers# Test: Closures (evaluated functions) ------------------------------------------ if (utils::packageVersion("base") < "4.2.0") { # Tree characters are ASCII on old Windows R skip_on_os("windows") } test_that("src() shows closure with srcref and wholeSrcref", { expect_snapshot(transform = scrub_src_transform, { f <- simple_function_with_srcref() src(f) }) }) test_that("src() shows multi-statement function", { expect_snapshot(transform = scrub_src_transform, { f <- multi_statement_function_with_srcref() src(f) }) }) # Test: Quoted functions -------------------------------------------------------- test_that("src() shows quoted function with nested body", { expect_snapshot(transform = scrub_src_transform, { with_srcref("x <- quote(function() {})") src(x) }) }) test_that("src() shows quoted function body directly", { expect_snapshot(transform = scrub_src_transform, { with_srcref("x <- quote(function() {})") src(x[[3]]) }) }) test_that("src() shows quoted function with arguments", { expect_snapshot(transform = scrub_src_transform, { with_srcref("x <- quote(function(a, b) {})") src(x) }) }) test_that("src() shows srcref with parsed field when positions differ", { expect_snapshot(transform = scrub_src_transform, { # Create a synthetic 8-element srcref where parsed positions differ # Format: c(first_line, first_byte, last_line, last_byte, # first_col, last_col, first_parsed, last_parsed) # This simulates a case where R's parser reports different positions # than the actual source locations (e.g., due to string continuations) srcfile <- srcfilecopy( "test.R", c( "x <- function() {", " # A long comment that spans", " # multiple lines", " y <- 1", "}" ) ) synthetic_srcref <- structure( c(2L, 3L, 4L, 8L, 3L, 8L, 1L, 5L), class = "srcref", srcfile = srcfile ) src(synthetic_srcref) }) }) # Test: Expression objects ------------------------------------------------------ test_that("src() shows expression with single element", { expect_snapshot(transform = scrub_src_transform, { x <- parse(text = "x + 1", keep.source = TRUE) src(x) }) }) test_that("src() shows expression with multiple elements", { expect_snapshot(transform = scrub_src_transform, { x <- parse(text = c("x + 1", "y + 2", "z + 3"), keep.source = TRUE) src(x) }) }) test_that("src() shows expression with nested block and wholeSrcref", { expect_snapshot(transform = scrub_src_transform, { x <- parse(text = "{\n 1\n}", keep.source = TRUE) src(x) }) }) test_that("src() shows nested block element directly", { expect_snapshot(transform = scrub_src_transform, { x <- parse(text = "{\n 1\n}", keep.source = TRUE) src(x[[1]]) }) }) # Test: Blocks with wholeSrcref ------------------------------------------------- test_that("src() shows block with srcref list and wholeSrcref", { expect_snapshot(transform = scrub_src_transform, { x <- parse(text = "{\n a <- 1\n b <- 2\n}", keep.source = TRUE) src(x[[1]]) }) }) # Test: Single srcref objects --------------------------------------------------- test_that("src() shows single srcref", { expect_snapshot(transform = scrub_src_transform, { x <- parse(text = "x + 1", keep.source = TRUE) sr <- attr(x, "srcref")[[1]] src(sr) }) }) # Test: List of srcrefs --------------------------------------------------------- test_that("src() shows list of srcrefs with count", { expect_snapshot(transform = scrub_src_transform, { x <- parse(text = c("x + 1", "y + 2"), keep.source = TRUE) sr_list <- attr(x, "srcref") src(sr_list) }) }) # Test: Srcref lists shown as with [[1]], [[2]] notation ---------------- test_that("src() reveals srcref list structure with index notation", { expect_snapshot(transform = scrub_src_transform, { with_srcref("x <- quote(function() { 1 })") src(x[[3]]) }) }) test_that("src() handles srcrefs nested in language calls", { expect_snapshot(transform = scrub_src_transform, { x <- parse(text = "foo({ if (1) bar({ 2 }) })", keep.source = TRUE) src(x, max_depth = 10) }) }) test_that("src() handles srcrefs nested in function bodies", { expect_snapshot(transform = scrub_src_transform, { with_srcref("f <- function() foo({ if (1) bar({ 2 }) })") src(f, max_depth = 10) }) }) # Test: Type labels ------------------------------------------------------------- test_that("src() uses correct type labels", { # Closure f <- simple_function_with_srcref() result_closure <- src(f) expect_equal(attr(result_closure, "srcref_type"), "closure") # Quoted function with_srcref("x <- quote(function() {})") result_quoted <- src(x) expect_equal(attr(result_quoted, "srcref_type"), "quoted_function") # Expression expr <- parse(text = "1 + 1", keep.source = TRUE) result_expr <- src(expr) expect_equal(attr(result_expr, "srcref_type"), "expression") # Block block <- parse(text = "{1}", keep.source = TRUE)[[1]] result_block <- src(block) expect_equal(attr(result_block, "srcref_type"), "block") }) # Test: Srcfile duplication (current behavior - will change in Phase 1) -------- test_that("src() currently shows duplicate srcfile objects", { expect_snapshot(transform = scrub_src_transform, { # Current behavior: srcfile appears twice (in srcref and wholeSrcref) # After Phase 1: should use reference notation like @abc123 f <- simple_function_with_srcref() src(f) }) }) test_that("src() shows many duplicate srcfiles in nested expression", { expect_snapshot(transform = scrub_src_transform, { # Current behavior: same srcfile appears many times # After Phase 1: these should be deduplicated x <- parse(text = "{\n 1\n 2\n}", keep.source = TRUE) src(x) }) }) # Test: Edge cases -------------------------------------------------------------- test_that("src() handles empty block", { expect_snapshot(transform = scrub_src_transform, { x <- parse(text = "{}", keep.source = TRUE) src(x[[1]]) }) }) test_that("src() handles function without arguments", { expect_snapshot(transform = scrub_src_transform, { with_srcref("f <- function() { NULL }") src(f) }) }) test_that("src() handles if statement with blocks", { expect_snapshot(transform = scrub_src_transform, { x <- parse(text = "if (TRUE) { 1 } else { 2 }", keep.source = TRUE) src(x) }) }) # Test: Parameters -------------------------------------------------------------- test_that("src() respects show_source_lines parameter", { expect_snapshot(transform = scrub_src_transform, { f <- simple_function_with_srcref() src(f) }) }) # Test: Complex nested structures ----------------------------------------------- test_that("src() shows expression with multiple nested blocks", { expect_snapshot(transform = scrub_src_transform, { x <- parse( text = "{\n {\n 1\n }\n {\n 2\n }\n}", keep.source = TRUE ) src(x) }) }) test_that("src() shows function with nested block in body", { expect_snapshot(transform = scrub_src_transform, { with_srcref("f <- function(x) {\n if (x) {\n 1\n }\n}") src(f) }) }) # Tests for src() function and helpers # Helper function tests -------------------------------------------------------- test_that("extract_srcref_info handles 4-element srcrefs", { # Create a simple expression with srcref expr <- parse(text = "x + 1", keep.source = TRUE) srcref <- attr(expr, "srcref")[[1]] # Manually create a 4-element srcref for testing # Note: In practice, 4-element srcrefs are rare in modern R srcref_4 <- structure( c(1L, 1L, 1L, 5L), class = "srcref", srcfile = attr(srcref, "srcfile") ) info <- srcref_info(srcref_4) expect_s3_class(info$location, "lobstr_srcref_location") expect_equal(as.character(info$location), "1:1 - 1:5") }) test_that("extract_srcref_info handles 6-element srcrefs", { # Create a 6-element srcref expr <- parse(text = "x + 1", keep.source = TRUE) srcref_base <- attr(expr, "srcref")[[1]] srcref_6 <- structure( c(1L, 1L, 1L, 5L, 1L, 5L), class = "srcref", srcfile = attr(srcref_base, "srcfile") ) info <- srcref_info(srcref_6) expect_s3_class(info$location, "lobstr_srcref_location") expect_equal(as.character(info$location), "1:1 - 1:5") }) test_that("extract_srcref_info handles 8-element srcrefs", { expr <- parse(text = "x + 1", keep.source = TRUE) srcref <- attr(expr, "srcref")[[1]] # Most modern srcrefs are 8-element info <- srcref_info(srcref) expect_s3_class(info$location, "lobstr_srcref_location") expect_match(as.character(info$location), "\\d+:\\d+ - \\d+:\\d+") }) test_that("extract_srcref_info shows encoding details when requested", { expr <- parse(text = "x + 1", keep.source = TRUE) srcref <- attr(expr, "srcref")[[1]] info <- srcref_info(srcref) expect_true("location" %in% names(info)) }) test_that("extract_srcref_info errors on invalid srcref length", { # Create an invalid srcref with wrong number of elements bad_srcref <- structure(c(1L, 2L, 3L), class = "srcref") expect_error( srcref_info(bad_srcref), "Unexpected srcref length" ) }) test_that("srcfile_node handles srcfilecopy", { expr <- parse(text = "x + 1", keep.source = TRUE) srcfile <- attr(attr(expr, "srcref")[[1]], "srcfile") srcref <- attr(expr, "srcref")[[1]] seen_srcfiles <- new.env(parent = emptyenv()) info <- srcfile_node(srcfile, seen_srcfiles) expect_equal(attr(info, "srcfile_class"), class(srcfile)[1]) expect_type(info$filename, "character") expect_type(info$Enc, "character") }) test_that("srcfile_node handles NULL gracefully", { seen_srcfiles <- new.env(parent = emptyenv()) info <- srcfile_node(NULL, seen_srcfiles) expect_null(info) }) test_that("srcfile_lines extracts from srcfilecopy", { code <- c("x <- 1", "y <- 2", "z <- 3") expr <- parse(text = code, keep.source = TRUE) srcref <- attr(expr, "srcref")[[1]] srcfile <- attr(srcref, "srcfile") snippet <- srcfile_lines(srcfile, srcref) expect_type(snippet, "character") expect_true(length(snippet) >= 1) }) test_that("srcfile_lines respects max_lines", { code <- c("x <- 1", "y <- 2", "z <- 3", "a <- 4", "b <- 5") expr <- parse(text = paste(code, collapse = "\n"), keep.source = TRUE) srcfile <- attr(attr(expr, "srcref")[[1]], "srcfile") srcref <- structure( c(1L, 1L, 5L, 10L, 1L, 10L, 1L, 5L), class = "srcref", srcfile = srcfile ) snippet <- srcfile_lines(srcfile, srcref) expect_type(snippet, "character") expect_lte(length(snippet), 3) }) test_that("srcref_location works correctly", { srcref <- structure( c(1L, 5L, 3L, 20L, 5L, 20L, 1L, 3L), class = "srcref" ) loc <- srcref_location(srcref) expect_equal(loc, "1:5 - 3:20") }) # Integration tests for src() -------------------------------------------------- test_that("src works with functions with source references", { fun <- simple_function_with_srcref() result <- src(fun) expect_type(result, "list") expect_equal(attr(result, "srcref_type"), "closure") }) test_that("src works with single srcref objects", { expr <- parse(text = "x + 1", keep.source = TRUE) srcref <- attr(expr, "srcref")[[1]] result <- src(srcref) expect_type(result, "list") expect_equal(attr(result, "srcref_type"), "srcref") expect_true("location" %in% names(result)) }) test_that("src works with list of srcrefs", { expr <- parse(text = c("x + 1", "y + 2"), keep.source = TRUE) srcref_list <- attr(expr, "srcref") result <- src(srcref_list) expect_type(result, "list") expect_equal(attr(result, "srcref_type"), "list") }) test_that("src works with expressions", { expr <- parse(text = "x + 1", keep.source = TRUE) result <- src(expr) expect_type(result, "list") }) test_that("src works for objects without srcrefs", { fun <- function(x) x + 1 attr(fun, "srcref") <- NULL expect_null(src(fun)) expect_null(src(new.env())) expect_null(src(list())) expect_null(src(sum)) }) test_that("src respects max_lines_preview parameter", { fun <- multi_statement_function_with_srcref() result <- src(fun, max_lines_preview = 1) expect_type(result, "list") expect_equal(attr(result, "srcref_type"), "closure") }) test_that("src returns structure and print method works", { fun <- simple_function_with_srcref() # src() returns visibly (with S3 class) result <- src(fun) expect_s3_class(result, "lobstr_srcref") # print method returns invisibly and outputs to console expect_output( expect_invisible(print(result)), "" ) }) # S3 method tests -------------------------------------------------------------- test_that("tree_label.srcref formats correctly", { expr <- parse(text = "x + 1", keep.source = TRUE) srcref <- attr(expr, "srcref")[[1]] # Call the method directly since srcref has proper class label <- tree_label.srcref(srcref, list()) expect_type(label, "character") expect_match(label, "= 1) # Should be hex ID (up to 6 chars) expect_true(nchar(id) <= 6) # Check that wholeSrcref uses a reference whole_srcfile <- result$`body()`$`attr("wholeSrcref")`$`attr("srcfile")` expect_s3_class(whole_srcfile, "lobstr_srcfile_ref") expect_equal(as.character(whole_srcfile), id) }) test_that("srcfile deduplication - multiple statement srcrefs share one srcfile", { # Create a function with multiple statements code <- parse( text = "f <- function(x) { a <- x + 1; b <- a * 2; b }", keep.source = TRUE ) f <- eval(code[[1]]) result <- src(f) # Get the ID from the first occurrence first_srcfile <- result$`attr("srcref")`$`attr("srcfile")` id <- attr(first_srcfile, "srcfile_id") # Check that all statement srcrefs use references stmt_list <- result$`body()`$`attr("srcref")` for (i in seq_along(stmt_list)) { stmt_name <- paste0("[[", i, "]]") stmt_srcfile <- stmt_list[[stmt_name]]$`attr("srcfile")` # Should be a reference expect_s3_class(stmt_srcfile, "lobstr_srcfile_ref") expect_equal(as.character(stmt_srcfile), id) } }) test_that("srcfile deduplication - IDs are stable within a single src() call", { # Parse the same code twice to get two different srcfile objects code1 <- parse(text = "f <- function(x) { x + 1 }", keep.source = TRUE) code2 <- parse(text = "g <- function(y) { y * 2 }", keep.source = TRUE) f <- eval(code1[[1]]) g <- eval(code2[[1]]) # Call src() on first function result_f <- src(f) id_f <- attr(result_f$`attr("srcref")`$`attr("srcfile")`, "srcfile_id") # Call src() on second function (different call, different seen_srcfiles) result_g <- src(g) id_g <- attr(result_g$`attr("srcref")`$`attr("srcfile")`, "srcfile_id") # IDs are sequential and start fresh for each src() call expect_type(id_f, "character") expect_type(id_g, "character") # Both should be 3-digit sequential IDs starting at "001" expect_equal(id_f, "001") expect_equal(id_g, "001") }) test_that("srcfile deduplication - multiple files means no cross-file deduplication", { # Parse two separate code snippets (different srcfile objects) code1 <- parse(text = "f <- function(x) { x + 1 }", keep.source = TRUE) code2 <- parse(text = "g <- function(y) { y * 2 }", keep.source = TRUE) f <- eval(code1[[1]]) g <- eval(code2[[1]]) # Get the srcfile addresses srcfile_f <- attr(attr(f, "srcref"), "srcfile") srcfile_g <- attr(attr(g, "srcref"), "srcfile") addr_f <- lobstr::obj_addr(srcfile_f) addr_g <- lobstr::obj_addr(srcfile_g) # Different srcfiles should have different addresses expect_false(addr_f == addr_g) # If we call src() on each separately, they each get their own ID result_f <- src(f) result_g <- src(g) id_f <- attr(result_f$`attr("srcref")`$`attr("srcfile")`, "srcfile_id") id_g <- attr(result_g$`attr("srcref")`$`attr("srcfile")`, "srcfile_id") # IDs are sequential and start fresh for each src() call, so both get "001" # This ensures deterministic snapshots expect_equal(id_f, "001") expect_equal(id_g, "001") }) test_that("srcfile deduplication - nested functions from same file", { # Create code with a nested function code <- " outer <- function() { inner <- function(x) { x + 1 } inner(5) } " parsed <- parse(text = code, keep.source = TRUE) eval(parsed[[1]]) result <- src(outer) # The outer function should have a srcfile with an ID outer_srcfile <- result$`attr("srcref")`$`attr("srcfile")` expect_true(!is.null(attr(outer_srcfile, "srcfile_id"))) # All other references should use the same ID id <- attr(outer_srcfile, "srcfile_id") # Check wholeSrcref reference whole_srcfile <- result$`body()`$`attr("wholeSrcref")`$`attr("srcfile")` expect_s3_class(whole_srcfile, "lobstr_srcfile_ref") expect_equal(as.character(whole_srcfile), id) }) test_that("srcfile deduplication - reference notation displays correctly", { code <- parse(text = "f <- function(x) { x + 1 }", keep.source = TRUE) f <- eval(code[[1]]) # Capture the output output <- capture.output(print(src(f))) # Should see the full srcfile once with @id notation full_srcfile_lines <- grep(" @[0-9a-f]+", output) expect_true(length(full_srcfile_lines) >= 1) # Should see reference notation (just @id without class) ref_lines <- grep("^[^<]*@[0-9a-f]+\\s*$", output, perl = TRUE) expect_true(length(ref_lines) >= 1) # Extract the ID from both to verify they match full_line <- output[full_srcfile_lines[1]] id_from_full <- regmatches(full_line, regexpr("@[0-9a-f]+", full_line)) ref_line <- output[ref_lines[1]] id_from_ref <- regmatches(ref_line, regexpr("@[0-9a-f]+", ref_line)) expect_equal(id_from_full, id_from_ref) }) test_that("lobstr_srcfile_ref class has correct structure", { # Create a reference object directly ref <- new_srcfile_ref("abc123", "srcfilecopy") expect_s3_class(ref, "lobstr_srcfile_ref") expect_equal(as.character(ref), "abc123") expect_equal(attr(ref, "srcfile_class"), "srcfilecopy") # Tree label should show just @id label <- tree_label.lobstr_srcfile_ref(ref, list()) expect_equal(label, "@abc123") }) test_that("srcfile deduplication - expression with multiple elements", { # Parse an expression with multiple top-level elements code <- parse(text = c("x <- 1", "y <- 2", "z <- 3"), keep.source = TRUE) result <- src(code) # The expression should have an srcref list srcref_list <- result$`attr("srcref")` # Get the first srcfile first_srcfile <- srcref_list$`[[1]]`$`attr("srcfile")` id <- attr(first_srcfile, "srcfile_id") expect_type(id, "character") # Other elements should reference the same srcfile second_srcfile <- srcref_list$`[[2]]`$`attr("srcfile")` expect_s3_class(second_srcfile, "lobstr_srcfile_ref") expect_equal(as.character(second_srcfile), id) third_srcfile <- srcref_list$`[[3]]`$`attr("srcfile")` expect_s3_class(third_srcfile, "lobstr_srcfile_ref") expect_equal(as.character(third_srcfile), id) }) # Deep nesting tests ---------------------------------------------------------- test_that("deep nesting - for loop with nested block", { code <- parse( text = " f <- function(x) { for (i in 1:x) { print(i) } } ", keep.source = TRUE ) eval(code[[1]]) result <- src(f) # Should have body with nested block expect_true("body()" %in% names(result)) # Should show nested block with path notation [[2]][[4]] # (element 2 of body is the for loop, element 4 is the body block) nested_block_path <- grep( "^\\[\\[2\\]\\]\\[\\[4\\]\\]", names(result$`body()`), value = TRUE ) expect_true(length(nested_block_path) >= 1) # The nested block should have srcref attributes nested_block <- result$`body()`[[nested_block_path[1]]] expect_s3_class(nested_block, "lobstr_srcref") expect_true( !is.null(nested_block$`attr("srcref")`) || !is.null(nested_block$`attr("wholeSrcref")`) ) }) test_that("deep nesting - if/else with blocks", { code <- parse( text = " g <- function(x) { if (x > 0) { y <- x + 1 } else { y <- x - 1 } y } ", keep.source = TRUE ) eval(code[[1]]) result <- src(g) # Should show both if and else blocks with path notation body_names <- names(result$`body()`) # Look for nested blocks (should be [[2]][[3]] and [[2]][[4]]) if_block_paths <- grep( "^\\[\\[2\\]\\]\\[\\[3\\]\\]", body_names, value = TRUE ) else_block_paths <- grep( "^\\[\\[2\\]\\]\\[\\[4\\]\\]", body_names, value = TRUE ) expect_true(length(if_block_paths) >= 1) expect_true(length(else_block_paths) >= 1) # Both blocks should be srcref objects if_block <- result$`body()`[[if_block_paths[1]]] expect_s3_class(if_block, "lobstr_srcref") else_block <- result$`body()`[[else_block_paths[1]]] expect_s3_class(else_block, "lobstr_srcref") }) test_that("deep nesting - nested blocks { { { } } }", { code <- parse( text = " h <- function() { { { x <- 1 } } } ", keep.source = TRUE ) eval(code[[1]]) result <- src(h) # Should have nested blocks expect_true("body()" %in% names(result)) # Should have at least one nested [[2]] block expect_true("[[2]]" %in% names(result$`body()`)) # That nested block should have further nesting nested_block <- result$`body()`$`[[2]]` expect_s3_class(nested_block, "lobstr_srcref") expect_true("[[2]]" %in% names(nested_block)) }) test_that("deep nesting - multiple top-level statements", { code <- parse( text = " f <- function(x) { a <- x + 1 b <- a * 2 for (i in 1:b) { print(i) } b } ", keep.source = TRUE ) eval(code[[1]]) result <- src(f) # Should have body with statement srcrefs expect_true("body()" %in% names(result)) expect_true("attr(\"srcref\")" %in% names(result$`body()`)) # Should show the nested for loop block body_names <- names(result$`body()`) for_block_paths <- grep( "\\[\\[4\\]\\]\\[\\[4\\]\\]", body_names, value = TRUE ) expect_true(length(for_block_paths) >= 1) }) test_that("deep nesting - empty function", { code <- parse(text = "f <- function() {}", keep.source = TRUE) eval(code[[1]]) result <- src(f) # Should still have structure expect_type(result, "list") expect_s3_class(result, "lobstr_srcref") expect_true("attr(\"srcref\")" %in% names(result)) }) test_that("deep nesting - very deep structure respects max_depth", { # Create deeply nested structure code <- parse( text = " f <- function(x) { for (i in 1:x) { if (i > 0) { while (i < 10) { for (j in 1:i) { print(j) } break } } } } ", keep.source = TRUE ) eval(code[[1]]) # With low max_depth, should truncate result_shallow <- src(f, max_depth = 2) expect_type(result_shallow, "list") # With high max_depth, should show more nesting result_deep <- src(f, max_depth = 10) expect_type(result_deep, "list") # Deep version should have more nested paths shallow_paths <- names(result_shallow) deep_paths <- names(result_deep) # Both should be valid results expect_true(length(shallow_paths) > 0) expect_true(length(deep_paths) > 0) }) test_that("deep nesting - intermediate calls without srcrefs are omitted", { code <- parse( text = " f <- function(x) { for (i in 1:x) { print(i) } } ", keep.source = TRUE ) eval(code[[1]]) # Capture output output <- capture.output(print(src(f))) # Should NOT see intermediate nodes language_nodes <- grep("", output, value = TRUE) expect_equal(length(language_nodes), 0) # Should see collapsed path notation collapsed_paths <- grep( "\\[\\[\\d+\\]\\]\\[\\[\\d+\\]\\]", output, value = TRUE ) expect_true(length(collapsed_paths) > 0) }) test_that("deep nesting - while loop with nested block", { code <- parse( text = " f <- function(x) { i <- 0 while (i < x) { print(i) i <- i + 1 } } ", keep.source = TRUE ) eval(code[[1]]) result <- src(f) # Should have nested block for while body body_names <- names(result$`body()`) while_block_paths <- grep( "\\[\\[3\\]\\]\\[\\[3\\]\\]", body_names, value = TRUE ) expect_true(length(while_block_paths) >= 1) }) test_that("deep nesting - repeat loop with nested block", { code <- parse( text = " f <- function(x) { repeat { print(x) break } } ", keep.source = TRUE ) eval(code[[1]]) result <- src(f) # Should have nested block for repeat body expect_true("body()" %in% names(result)) body_names <- names(result$`body()`) # Look for nested block path nested_paths <- grep("^\\[\\[2\\]\\]\\[\\[2\\]\\]", body_names, value = TRUE) expect_true(length(nested_paths) >= 1) }) test_that("deep nesting - switch statement with blocks", { code <- parse( text = ' f <- function(x) { switch(x, a = { print("a") }, b = { print("b") } ) } ', keep.source = TRUE ) eval(code[[1]]) result <- src(f) # Should have structure expect_type(result, "list") expect_s3_class(result, "lobstr_srcref") }) test_that("deep nesting - quoted expressions with nested blocks", { code <- parse( text = " x <- quote({ for (i in 1:3) { print(i) } }) ", keep.source = TRUE ) eval(code[[1]]) result <- src(x) # Should show nested structure expect_type(result, "list") # Should have nested block paths if (!is.null(result) && length(result) > 0) { all_names <- names(unlist(result, recursive = TRUE)) nested_paths <- grep( "\\[\\[\\d+\\]\\]\\[\\[\\d+\\]\\]", all_names, value = TRUE ) # Might or might not have nested paths depending on how quote() preserves srcrefs expect_true(length(nested_paths) >= 0) } }) lobstr/tests/testthat/test-ref.R0000644000176200001440000000211015104641646016436 0ustar liggesuserstest_that("basic list display", { skip_on_os("windows") test_addr_reset() expect_snapshot({ x <- 1:10 y <- list(x, x) ref( x, list(), list(x, x, x), list(a = x, b = x), letters ) }) }) test_that("basic environment display", { skip_on_os("windows") test_addr_reset() expect_snapshot({ e <- env(a = 1:10) e$b <- e$a e$c <- e ref(e) }) }) test_that("environment shows objects beginning with .", { skip_on_os("windows") test_addr_reset() expect_snapshot({ e <- env(. = 1:10) ref(e) }) }) test_that("can display ref to global string pool on request", { skip_on_os("windows") test_addr_reset() expect_snapshot({ ref(c("string", "string", "new string"), character = TRUE) }) }) test_that("custom methods are never called (#30)", { # `[[.numeric_number` causes infinite recursion expect_error(ref(package_version("1.1.1")), NA) e <- env(a = 1:10) e$b <- e$a e$c <- e # `as.list.data.frame`(, ...) fails class(e) <- "data.frame" expect_error(ref(e), NA) }) lobstr/tests/testthat.R0000644000176200001440000000007013256202040014673 0ustar liggesuserslibrary(testthat) library(lobstr) test_check("lobstr") lobstr/MD50000644000176200001440000001514315164116517012102 0ustar liggesusersc2bb3fb99f3109e06d32355ec8f1f1e4 *DESCRIPTION 55585878199a4aa76ee6070d47853de8 *LICENSE 9038e771f534d877ad49c3c42ff0faaf *NAMESPACE b485c142764466f43d506444f0efacc5 *NEWS.md 93d58f53eeb7461eb9be11353d16243b *R/address.R 887513c48bdad71580fe033e2b2552ec *R/ast.R 613cdb00a43af3dc0d7669cbf675a91a *R/cpp11.R 67faf9bf8522879cbbb2e94170f96f4c *R/cst.R df6cc46bc7fae1a55b713f3d5065b35a *R/lobstr-package.R 77b2d5222f377a5ffd40fc3a996ad438 *R/lobstr.R 77012918976575fd5b176b95a1d18fb3 *R/mem.R 471b6c034f79b901e05a6577ffd9b537 *R/ref.R f4bbdecc00615ef10fce35e53a901772 *R/size.R 8f42ca9c4b2110f55c977fd97d205548 *R/src.R fc9d347fa6afcf818fb681f3ca3c8467 *R/sxp.R de77eb8eacd96ba05cb92130763b7804 *R/tree.R 03aab0d1289681e1df94ae9c0121e6c8 *R/utils.R b6cfd4c5de698c60682b683233fb33fc *README.md bdd7b9bd580494bff2099316a5e6ce53 *man/ast.Rd ec937196239fb6b6959b59e5f7764caa *man/cst.Rd b51d8ae702c213f25503ea546758b280 *man/figures/logo.png 17061ea6756974cbb5d3a5242ec19c80 *man/lobstr-package.Rd b6292677acd723224e8bb27b7938225e *man/mem_used.Rd de54fc026d86e22ce7e10db07ab32377 *man/obj_addr.Rd f8b5ee446ac342e149827cad29a7f658 *man/obj_size.Rd 98becd81975658d8c612269738f63faf *man/ref.Rd 87a193bd70e161424e066bacf51e9770 *man/src.Rd 448042b0da47c548e2b71ddbf20f1af6 *man/sxp.Rd 2dcd00295599b14d671167cdf11ad5e3 *man/tree.Rd 0b86e73f611aed90ccdbbf5e4b47c719 *man/tree_label.Rd 29688af1f6d0d8038071b4f2bea1f016 *src/Makevars ccd8ce38962090ce95aec275626c7ad6 *src/address.cpp e5037e4c3fff04793e3fd3efdfa11371 *src/cpp11.cpp ec8ad8584f4d1e2bdf08212e4d8cd218 *src/inspect.cpp 3518d52b1685a20b913f095abbaeadad *src/lobstr.cpp f675812d8927e9b13fce5f1e8ed31f1b *src/rlang.c 0608535fc0aaf4efdf5a51912e6a6c84 *src/rlang/arg.c f33102fbb69a55bf8a314cd6cea529bd *src/rlang/arg.h 032997de0eb7a70acd881d9a53b6efb3 *src/rlang/attrib.c 3e42584f7654b259dd1b49842b3ef33c *src/rlang/attrib.h 9c9b7d12443672c8dee0a4615b56c2fc *src/rlang/c-utils.c bf583f300a656f07bb842e3f25b96107 *src/rlang/c-utils.h 22e5d851558dcb490b87b5ffebbcb6f8 *src/rlang/call.c 291751537e6eb339c08899eca084dee6 *src/rlang/call.h 7e95330c7c69a3090b2c3f6b62412b0c *src/rlang/cnd.c c323a0eff3440f67d2652c7d9f7ba22e *src/rlang/cnd.h b176a262a2ea2e884f4914289466de7b *src/rlang/cpp/rlang.cpp 29bd3e7d88cdb8a4a641f05ee089069c *src/rlang/cpp/vec.cpp e087224ebfb79ff325c2224665ab8a90 *src/rlang/debug.c ada02ec97cd21a5717e586f6be114b76 *src/rlang/debug.h c4c0b92858e604f1e651c5aa247ac5b0 *src/rlang/decl/cnd-decl.h c42446da8c4955c10b5acc67ec1ee130 *src/rlang/decl/df-decl.h 1aa66d903f3a4cb578ca16d7188511c6 *src/rlang/decl/dict-decl.h bcd3be7be1e7d4c9056adc78687c9f71 *src/rlang/decl/dyn-list-of-decl.h 9069f6115ab0b8cc64574cb3dfd5678a *src/rlang/decl/env-binding-decl.h acb47374357e2572e2c74ace4bcf5739 *src/rlang/decl/env-decl.h bf8df189e2ff68b0c0fe62d076814545 *src/rlang/decl/obj-decl.h 5cbb39aebac52f777c30ab65c94b2461 *src/rlang/decl/stack-decl.h e235b255aac77f597c1b0ea723f628e3 *src/rlang/decl/walk-decl.h db6c3d3e9e9424851c462289c9f08032 *src/rlang/df.c 59d548d90ba18659db46a8d6407913f1 *src/rlang/df.h 543a9da88f455acab0e00bed195c33ea *src/rlang/dict.c 1cf19f35f85a08af0c2c18bccb8fcb29 *src/rlang/dict.h 71410a32c3ded0854db20181ee5d5432 *src/rlang/dots-info.c 5fae98d74d830ca3d2a5afe098dd6493 *src/rlang/dots-info.h ca299d0a21f7c1b3354f1af93f663929 *src/rlang/dyn-array.c 3a77133e2b00de3f8bb61adbae4510f4 *src/rlang/dyn-array.h aadc788be09a2bd9a565c3e825eb428c *src/rlang/dyn-list-of.c 3b0bab5449ddb404e1ea6365c7eb38af *src/rlang/dyn-list-of.h decb10ed526637adb2fe3888f16f0464 *src/rlang/env-binding.c e7386f3f3b48887c5654c13e5336429a *src/rlang/env-binding.h 0e52014937a175a24690529ce6edd68d *src/rlang/env.c 3a5f4e5731304faf675e782360c935e3 *src/rlang/env.h 3d14354720fb5e921e054b499c477fff *src/rlang/eval.c 4ca79fe26c1b1cfd826dbc1bd8db3709 *src/rlang/eval.h 01f0a156858ea14578547720b4e94232 *src/rlang/export.c 9f78f01cd55ea638136022dd7bb6eeb1 *src/rlang/export.h ec36cc014954270b6b827f3844f5cf1b *src/rlang/fn.c afe3dad269ac797b1faa96bd5b374e93 *src/rlang/fn.h edbdbd626761de992dbb9f7a3b98b65d *src/rlang/formula.c b1fe913e42251fedac387df505833e8a *src/rlang/formula.h 524663b4ae77330bf56f45ab01aab16b *src/rlang/globals.c a49c88313a4858d75327828d537ecb5c *src/rlang/globals.h 883cf705478e061c810b25eec596eff6 *src/rlang/node.c 838e203b8802e4be9b09e03f2ddb3ac0 *src/rlang/node.h 6c50f61ab770398065ef1cc3992a9978 *src/rlang/obj.c a9d225f90fcbc919915f5a2364279151 *src/rlang/obj.h 4576f3bc9e1dafe198460d4c2b0e88f4 *src/rlang/parse.c fbbf64374cf70d42e7040794e1b30c7c *src/rlang/parse.h a5e865607e4e717784f5f951533d372c *src/rlang/quo.c 91e7e7c43c3edea2509fb3d1bbc3b81c *src/rlang/quo.h f24278fd4bb74e6cbe00d85c109255e3 *src/rlang/rlang-types.h b927fd7cf8ccf08ce0382805d25479cb *src/rlang/rlang.c 426d212a318562f9cb48ce9ec0714657 *src/rlang/rlang.h a24cd0a56d6993488d143ed8f5ffb7d7 *src/rlang/rlang.hpp 3115b50ab84dff920d09f95b4f73e395 *src/rlang/session.c c4f658b2f142941877450cc6a721942c *src/rlang/session.h 6225f1c2d3182e4bb957b8f1aba27937 *src/rlang/stack.c 3205bebc161f15bb38b38d88df1d6812 *src/rlang/stack.h e08266d8bec196133ce136c495e7f4ad *src/rlang/state.h 267ea357e68ff19af4f151c76b8c21c3 *src/rlang/sym.c 6a3a6aa98e58a296b6a86a177ad1b0a9 *src/rlang/sym.h 6ec4b806d0cad8eddae9250f2cbf3231 *src/rlang/vec-chr.c ae5f17aa96c3e532b67f3b9448ef5037 *src/rlang/vec-chr.h bf006c89dcffdc61228a385ee5ad342f *src/rlang/vec-lgl.c fda191ce4e58fefe29b8d9a734a6b7ef *src/rlang/vec-lgl.h 59cbf3a32be65ef4a5e95aefc9cc8afb *src/rlang/vec.c 32a20d759795163abe023042889cd8cf *src/rlang/vec.h aad9cb50156b9ab0f02ea91fb31db1b7 *src/rlang/vendor.c 1f93206ea8ca8cab1275e816347e852a *src/rlang/vendor.h e6050a519de98f82529d300b78a19117 *src/rlang/walk.c 83491b8bfe5110dda8e27b4fe2041399 *src/rlang/walk.h 6827fa2aa984760cc5ad2766638ef934 *src/size.cpp 5d797a0b288604a4eb8533c800b182b3 *src/utils.h 35f98f5a6ad54e371e4e1f6638702a56 *tests/testthat.R d1c5d4f6ca1bb06511f91dcc97e4411c *tests/testthat/_snaps/ast.md 5edf1832e72c5c1b136d22b718fbc5a5 *tests/testthat/_snaps/ref.md 49c177f4b6c0498ea010271f15c41f09 *tests/testthat/_snaps/size.md 002770f2aa0f299a2c147bd40a511e91 *tests/testthat/_snaps/src.md bb6aa92b44c310877f30462eba56b826 *tests/testthat/_snaps/sxp.md 5beb76d4bc2736d98bead602cace3859 *tests/testthat/_snaps/tree.md 05781b3cccc4ded9b8078d7f43519760 *tests/testthat/helper-src.R 6dbe9bae43164489a61eafc76d13efdd *tests/testthat/test-address.R 8516fb7771e07a79d042097e54b52955 *tests/testthat/test-ast.R 7a1b90369e931672aff2d32874300b72 *tests/testthat/test-ref.R b0f0229ebaef0da41f081a9d56372a06 *tests/testthat/test-size.R 8cfbebd880ac00eefd78baec99b75002 *tests/testthat/test-src.R b104f769c862a60febc7fbb84ec0f46c *tests/testthat/test-sxp.R 91439f783675942e53423287c3e3b5b4 *tests/testthat/test-tree.R lobstr/R/0000755000176200001440000000000015163460154011765 5ustar liggesuserslobstr/R/size.R0000644000176200001440000000736515105062605013070 0ustar liggesusers#' Calculate the size of an object. #' #' `obj_size()` computes the size of an object or set of objects; #' `obj_sizes()` breaks down the individual contribution of multiple objects #' to the total size. #' #' @section Compared to `object.size()`: #' Compared to [object.size()], `obj_size()`: #' #' * Accounts for all types of shared values, not just strings in #' the global string pool. #' #' * Includes the size of environments (up to `env`) #' #' * Accurately measures the size of ALTREP objects. #' #' @section Environments: #' `obj_size()` attempts to take into account the size of the #' environments associated with an object. This is particularly important #' for closures and formulas, since otherwise you may not realise that you've #' accidentally captured a large object. However, it's easy to over count: #' you don't want to include the size of every object in every environment #' leading back to the [emptyenv()]. `obj_size()` takes #' a heuristic approach: it never counts the size of the global environment, #' the base environment, the empty environment, or any namespace. #' #' Additionally, the `env` argument allows you to specify another #' environment at which to stop. This defaults to the environment from which #' `obj_size()` is called to prevent double-counting of objects created #' elsewhere. #' #' @export #' @param ... Set of objects to compute size. #' @param env Environment in which to terminate search. This defaults to the #' current environment so that you don't include the size of objects that #' are already stored elsewhere. #' #' Regardless of the value here, `obj_size()` never looks past the #' global or base environments. #' #' @return An estimate of the size of the object, in bytes. #' @examples #' # obj_size correctly accounts for shared references #' x <- runif(1e4) #' obj_size(x) #' #' z <- list(a = x, b = x, c = x) #' obj_size(z) #' #' # this means that object size is not transitive #' obj_size(x) #' obj_size(z) #' obj_size(x, z) #' #' # use obj_size() to see the unique contribution of each component #' obj_sizes(x, z) #' obj_sizes(z, x) #' obj_sizes(!!!z) #' #' # obj_size() also includes the size of environments #' f <- function() { #' x <- 1:1e4 #' a ~ b #' } #' obj_size(f()) #' #' #' # In R 3.5 and greater, `:` creates a special "ALTREP" object that only #' # stores the first and last elements. This will make some vectors much #' # smaller than you'd otherwise expect #' obj_size(1:1e6) obj_size <- function(..., env = parent.frame()) { dots <- list2(...) size <- obj_size_(dots, env, size_node(), size_vector()) new_bytes(size) } #' @rdname obj_size #' @export obj_sizes <- function(..., env = parent.frame()) { dots <- list2(...) size <- obj_csize_(dots, env, size_node(), size_vector()) names(size) <- names(dots) new_bytes(size) } size_node <- function(x) as.vector(utils::object.size(quote(expr = ))) size_vector <- function(x) as.vector(utils::object.size(logical())) new_bytes <- function(x) { structure(x, class = "lobstr_bytes") } #' @export format.lobstr_bytes <- function(x, ...) { prettyunits::pretty_bytes(unclass(x)) } #' @export print.lobstr_bytes <- function(x, ...) { fx <- format(x) if (length(x) == 1) { cat_line(fx) } else { if (!is.null(names(x))) { cat_line(format(names(x)), ": ", fx) } else { cat_line("* ", fx) } } invisible(x) } #' @export c.lobstr_bytes <- function(...) { new_bytes(NextMethod()) } #' @export `[.lobstr_bytes` <- function(...) { new_bytes(NextMethod()) } # Helpers for interactive exploration ------------------------------------- comp <- function(x) { base <- utils::object.size(x) lobstr <- obj_size(x) c(base = base, lobstr = lobstr, diff = base - lobstr) } insp <- function(x) { eval(quote(.Internal(inspect(x)))) } lobstr/R/sxp.R0000644000176200001440000001272115143623341012722 0ustar liggesusers#' Inspect an object #' #' `sxp(x)` is similar to `.Internal(inspect(x))`, recursing into the C data #' structures underlying any R object. The main difference is the output is a #' little more compact, it recurses fully, and avoids getting stuck in infinite #' loops by using a depth-first search. It also returns a list that you can #' compute with, and carefully uses colour to highlight the most important #' details. #' #' The name `sxp` comes from `SEXP`, the name of the C data structure that #' underlies all R objects. #' #' @param x Object to inspect #' @param max_depth Maximum depth to recurse. Use `max_depth = Inf` (with care!) #' to recurse as deeply as possible. Skipped elements will be shown as `...`.` #' @param expand Optionally, expand components of the true that are usually #' suppressed. Use: #' #' * "character" to show underlying entries in the global string pool. #' * "environment" to show binding components without any side effects (e.g. promises or active bindings). #' * "altrep" to show the underlying data. #' * "call" to show the full AST (but [ast()] is usually superior) #' * "bytecode" to show generated bytecode. #' @family object inspectors #' @export #' @examples #' x <- list( #' TRUE, #' 1L, #' runif(100), #' "3" #' ) #' sxp(x) #' #' # Expand "character" to see underlying CHARSXP entries in the global #' # string pool #' x <- c("banana", "banana", "apple", "banana") #' sxp(x) #' sxp(x, expand = "character") #' #' # Expand altrep to see underlying data #' x <- 1:10 #' sxp(x) #' sxp(x, expand = "altrep") #' #' # Expand environments to see promise expressions without forcing #' e <- new.env(parent = emptyenv()) #' delayedAssign("x", 1 + 1, assign.env = e) #' #' 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)) { abort( sprintf( "`expand` must contain only values from: '%s'.", paste(opts, collapse = "', '") ) ) } obj_inspect_( x, max_depth - 1L, opts[[1]] %in% expand, opts[[2]] %in% expand, opts[[3]] %in% expand, opts[[4]] %in% expand, opts[[5]] %in% expand ) } #' @export format.lobstr_inspector <- function(x, ..., depth = 0, name = NA) { indent <- paste0(rep(" ", depth), collapse = "") id <- crayon::bold(attr(x, "id")) if (!is_testing() && !is_placeholder(x)) { addr <- paste0(":", crayon::silver(attr(x, "addr"))) } else { addr <- "" } type <- attr(x, "type") if (attr(x, "has_seen")) { desc <- paste0("[", attr(x, "id"), addr, "]") } else { if (sexp_is_vector(type)) { length <- paste0("[", attr(x, "length"), "]") } else { length <- NULL } if (!is.null(attr(x, "value"))) { value <- paste0(": ", attr(x, "value")) } else { value <- NULL } if (!is_testing() && !is_placeholder(x)) { no_references <- attr(x, "no_references") maybe_shared <- attr(x, "maybe_shared") if (no_references == 1) { references <- "refs:0" } else if (maybe_shared == 0) { references <- "refs:1" } else { references <- "refs:2+" } } else { references <- NULL } # show altrep, object, named etc sxpinfo <- paste0( if (attr(x, "altrep")) "altrep ", if (attr(x, "object")) "object ", references ) # Placeholders don't show sxpinfo or id (they can't be referenced) if (is_placeholder(x)) { desc <- paste0( "<", crayon::cyan(type), value, ">" ) } else { desc <- paste0( "[", id, addr, "] ", "<", crayon::cyan(type), length, value, "> ", "(", sxpinfo, ")" ) } } name <- if (!identical(name, "")) { paste0(crayon::italic(crayon::silver(name)), " ") } paste0(indent, name, desc) } #' @export print.lobstr_inspector <- function(x, ..., depth = 0, name = "") { cat_line(format(x, depth = depth, name = name)) if (isTRUE(attr(x, "skip"))) { indent <- paste0(rep(" ", depth + 1), collapse = "") cat_line(indent, crayon::silver("...")) } for (i in seq_along(x)) { print(x[[i]], depth = depth + 1, name = names(x)[[i]]) } } sxp_view <- function(x, expand = character()) { if (!"tools:rstudio" %in% search()) { abort("Can only be called from within RStudio") } env <- as.environment("tools:rstudio") old_opt <- options(crayon.enabled = FALSE) on.exit(options(old_opt), add = TRUE) old_fun <- env$.rs.explorer.objectDesc on.exit(env$.rs.addFunction("explorer.objectDesc", old_fun), add = TRUE) assign(".rs.explorer.objectDesc", envir = env, function(x) { if (inherits(x, "lobstr_inspector")) { format.lobstr_inspector(x) } else { old_fun(x) } }) obj <- sxp(x, expand = expand) env$.rs.viewHook(NULL, obj, "Object inspector") # explorer.objectDesc() is called lazily so this is a crude hack Sys.sleep(10) } # helpers ----------------------------------------------------------------- sexp_is_vector <- function(x) { x %in% c( "LGLSXP", "INTSXP", "REALSXP", "STRSXP", "RAWSXP", "CPLXSXP", "VECSXP", "EXPRSXP" ) } # 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") } lobstr/R/cpp11.R0000644000176200001440000000156315163460154013041 0ustar liggesusers# Generated by cpp11: do not edit by hand obj_addr_ <- function(name, env) { .Call(`_lobstr_obj_addr_`, name, env) } obj_addrs_ <- function(x) { .Call(`_lobstr_obj_addrs_`, x) } obj_inspect_ <- function(x, max_depth, expand_char, expand_altrep, expand_env, expand_call, expand_bytecode) { .Call(`_lobstr_obj_inspect_`, x, max_depth, expand_char, expand_altrep, expand_env, expand_call, expand_bytecode) } init_library <- function(env) { invisible(.Call(`_lobstr_init_library`, env)) } v_size <- function(n, element_size) { .Call(`_lobstr_v_size`, n, element_size) } obj_size_ <- function(objects, base_env, sizeof_node, sizeof_vector) { .Call(`_lobstr_obj_size_`, objects, base_env, sizeof_node, sizeof_vector) } obj_csize_ <- function(objects, base_env, sizeof_node, sizeof_vector) { .Call(`_lobstr_obj_csize_`, objects, base_env, sizeof_node, sizeof_vector) } lobstr/R/ast.R0000644000176200001440000000454515105062605012702 0ustar liggesusers#' Display the abstract syntax tree #' #' This is a useful alternative to `str()` for expression objects. #' #' @param x An expression to display. Input is automatically quoted, #' use `!!` to unquote if you have already captured an expression object. #' @family object inspectors #' @export #' @examples #' # Leaves #' ast(1) #' ast(x) #' #' # Simple calls #' ast(f()) #' ast(f(x, 1, g(), h(i()))) #' ast(f()()) #' ast(f(x)(y)) #' #' ast((x + 1)) #' #' # Displaying expression already stored in object #' x <- quote(a + b + c) #' ast(x) #' ast(!!x) #' #' # All operations have this same structure #' ast(if (TRUE) 3 else 4) #' ast(y <- x * 10) #' ast(function(x = 1, y = 2) { x + y } ) #' #' # Operator precedence #' ast(1 * 2 + 3) #' ast(!1 + !1) ast <- function(x) { expr <- enexpr(x) new_raw(ast_tree(expr)) } ast_tree <- function(x, layout = box_chars()) { if (is_quosure(x)) { x <- quo_squash(x) } # base cases if (rlang::is_syntactic_literal(x)) { return(ast_leaf_constant(x)) } else if (is_symbol(x)) { return(ast_leaf_symbol(x)) } else if (!is.pairlist(x) && !is.call(x)) { return(paste0("")) } # recursive case subtrees <- lapply(x, ast_tree, layout = layout) subtrees <- name_subtree(subtrees) n <- length(x) if (n == 0) { character() } else if (n == 1) { str_indent(subtrees[[1]], paste0(layout$n, layout$h), " ") } else { c( str_indent( subtrees[[1]], paste0(layout$n, layout$h), paste0(layout$v, " ") ), unlist(lapply( subtrees[-c(1, n)], str_indent, paste0(layout$j, layout$h), paste0(layout$v, " ") )), str_indent(subtrees[[n]], paste0(layout$l, layout$h), " ") ) } } name_subtree <- function(x) { nm <- names(x) if (is.null(nm)) { return(x) } has_name <- nm != "" label <- paste0(crayon::italic(grey(nm)), " = ") indent <- str_dup(" ", nchar(nm) + 3) x[has_name] <- Map(str_indent, x[has_name], label[has_name], indent[has_name]) x } ast_leaf_symbol <- function(x) { x <- as.character(x) if (!is.syntactic(x)) { x <- encodeString(x, quote = "`") } crayon::bold(crayon::magenta(x)) } ast_leaf_constant <- function(x) { if (is.complex(x)) { paste0(Im(x), "i") } else { deparse(x) } } is.syntactic <- function(x) make.names(x) == x lobstr/R/ref.R0000644000176200001440000000664115105062605012666 0ustar liggesusers#' Display tree of references #' #' This tree display focusses on the distinction between names and values. #' For each reference-type object (lists, environments, and optional character #' vectors), it displays the location of each component. The display #' shows the connection between shared references using a locally unique id. #' #' @param ... One or more objects #' @param character If `TRUE`, show references from character vector in to #' global string pool #' @export #' @family object inspectors #' @examples #' x <- 1:100 #' ref(x) #' #' y <- list(x, x, x) #' ref(y) #' ref(x, y) #' #' e <- new.env() #' e$e <- e #' e$x <- x #' e$y <- list(x, e) #' ref(e) #' #' # Can also show references to global string pool if requested #' ref(c("x", "x", "y")) #' ref(c("x", "x", "y"), character = TRUE) ref <- function(..., character = FALSE) { x <- list(...) seen <- child_env(emptyenv(), `__next_id` = 1) out <- lapply(x, ref_tree, character = character, seen = seen) n <- length(x) if (n > 1) { out[-n] <- lapply(out[-n], function(x) c(x, "")) } new_raw(unlist(out)) } ref_tree <- function( x, character = FALSE, seen = child_env(emptyenv()), layout = box_chars() ) { addr <- obj_addr(x) has_seen <- env_has(seen, addr) id <- obj_id(seen, addr) desc <- obj_desc(addr, type_sum(x), has_seen, id) # Not recursive or already seen if (!has_references(x, character) || has_seen) { return(desc) } # Remove classes to avoid custom methods (note that environments cannot be unclasse()ed) attr(x, "class") <- NULL # recursive cases if (is.list(x)) { subtrees <- lapply( x, ref_tree, layout = layout, seen = seen, character = character ) } else if (is.environment(x)) { subtrees <- lapply( as.list(x, all.names = TRUE), ref_tree, layout = layout, seen = seen, character = character ) } else if (is.character(x)) { subtrees <- ref_tree_chr(x, layout = layout, seen = seen) } subtrees <- name_subtree(subtrees) self <- str_indent(desc, paste0(layout$n, " "), paste0(layout$v, " ")) n <- length(subtrees) if (n == 0) { return(self) } c( self, unlist(lapply( subtrees[-n], str_indent, paste0(layout$j, layout$h), paste0(layout$v, " ") )), str_indent(subtrees[[n]], paste0(layout$l, layout$h), " ") ) } type_sum <- function(x) { if (is_installed("pillar")) { pillar::type_sum(x) } else { typeof(x) } } obj_desc <- function(addr, type, has_seen, id) { if (has_seen) { paste0("[", grey(paste0(id, ":", addr)), "]") } else { paste0("[", crayon::bold(id), ":", addr, "] ", "<", type, ">") } } has_references <- function(x, character = FALSE) { is_list(x) || is.environment(x) || (character && is_character(x)) } ref_tree_chr <- function( x, layout = box_chars(), seen = child_env(emptyenv()) ) { addrs <- obj_addrs(x) has_seen <- logical(length(x)) ids <- integer(length(x)) for (i in seq_along(addrs)) { has_seen[[i]] <- env_has(seen, addrs[[i]]) ids[[i]] <- obj_id(seen, addrs[[i]]) } type <- paste0('string: "', str_truncate(x, 10), '"') out <- Map(obj_desc, addrs, type, has_seen, ids) names(out) <- names(x) out } obj_id <- function(env, ref) { if (env_has(env, ref)) { env_get(env, ref) } else { id <- env_get(env, "__next_id") env_poke(env, "__next_id", id + 1) env_poke(env, ref, id) id } } lobstr/R/src.R0000644000176200001440000005204015145635461012705 0ustar liggesusers#' Display tree of source references #' #' View source reference metadata attached to R objects in a tree structure. #' Shows source file information, line/column locations, and lines of source code. #' #' @param x An R object with source references. Can be: #' - A `srcref` object #' - A list of `srcref` objects #' - A expression vector with attached source references #' - An evaluated closure with attached source references #' - A quoted call with attached source references #' @param max_depth Maximum depth to traverse nested structures (default 5) #' @param max_length Maximum number of srcref nodes to display (default 100) #' @param ... Additional arguments passed to [tree()] #' #' @return Returns a structured list containing the source reference #' information. Print it to view the formatted tree. #' #' @section Overview: #' #' Source references are made of two kinds of objects: #' - `srcref` objects, which contain information about a specific #' location within the source file, such as the line and column numbers. #' - `srcfile` objects, which contain metadata about the source file #' such as its name, path, and encoding. #' #' #' ## Where and when are source references created? #' #' Ultimately the R parser creates source references. The main two entry points #' to the parser are: #' - The R function `parse()`. #' - The frontend hook `ReadConsole`, which powers the console input parser in #' the R CLI and in IDEs. This C-level parser can also be accessed from C code #' via `R_ParseVector()`. #' #' In principle, anything that calls `parse()` may create source references, but #' here are the important direct and indirect callers: #' - `source()` and `sys.source()` which parse and evaluate code. #' - `loadNamespace()` calls `sys.source()` when loading a _source_ package: #' . #' - `R CMD install` creates a lazy-load database from a source package. #' The first step is to call `loadNamespace()`: #' #' #' By default source references are not created but can be enabled by: #' #' - Passing `keep.source = TRUE` explicitly to `parse()`, `source()`, #' `sys.source()`, or `loadNamespace()`. #' - Setting `options(keep.source = TRUE)`. This affects the default arguments #' of the aforementioned functions, as well as the console input parser. #' In interactive sessions, `keep.source` is set to `TRUE` by default: #' . #' - Setting `options(keep.source.pkgs = TRUE)`. This affects loading a package #' from source, and installing a package from source. #' #' #' ## `srcref` objects #' #' `srcref` objects are compact integer vectors describing a character range #' in a source. It records start/end lines and byte/column positions and, #' optionally, the parsed-line numbers if `#line` directives were used. #' #' Lengths of 4, 6, or 8 are allowed: #' - 4: basic (first_line, first_byte, last_line, last_byte). Byte positions #' are within the line. #' - 6: adds columns in Unicode codepoints (first_col, last_col) #' - 8: adds parsed-line numbers (first_parsed, last_parsed) #' #' The "column" information does not represent grapheme clusters, but Unicode #' codepoints. The column cursor is incremented at every UTF-8 lead byte and #' there is no support for encodings other than UTF-8. #' #' The srcref columns are right-boundary positions, meaning that for an #' expression starting at the start of a line, the column will be 1. #' `wholeSrcref` (see below) on the other hand starts at 0, before the first #' character. It might also end 1 character after the last srcref column. #' #' They are attached as attributes (e.g. `attr(x, "srcref")` or `attr(x, #' "wholeSrcref")`), possibly wrapped in a list, to the following objects: #' #' - Expression vectors returned by `parse()` (wrapped in a list) #' - Quoted function calls (unwrapped) #' - Quoted `{` calls (wrapped in a list). This is crucial for debugging: when R #' steps through brace lists, the srcref for the current expression is saved to #' a global variable (`R_Srcref`) so the IDE knows exactly where execution is #' paused. See: . #' - Evaluated closures (unwrapped) #' #' They have a `srcfile` attribute that points to the source file. #' #' Methods: #' - `as.character()`: Retrieves relevant source lines from the `srcfile` #' reference. #' #' #' ### `wholeSrcref` attributes #' #' These are `srcref` objects stored in the `wholeSrcref` attributes of: #' #' - Expression vectors returned by `parse()`, which seems to be the intended #' usage. #' - `{` calls, which seems unintended. #' #' For expression vectors, the `wholeSrcref` spans from the first position #' to the last position and represents the entire document. For braces, they #' span from the first position to the location of the closing brace. There is #' no way to know the location of the opening brace without reparsing, which #' seems odd. It's probably an overlook from `xxexprlist()` calling #' `attachSrcrefs()` in #' . That #' function is also called at the end of parsing, where it's intended for the #' `wholeSrcref` attribute to be attached. #' #' For evaluated closures, the `wholeSrcref` attribute on the body has the same #' unreliable start positions as `{` nodes. #' #' #' ## `srcfile` objects #' #' `srcfile` objects are environments representing information about a #' source file that a source reference points to. They typically refer to #' a file on disk and store the filename, working directory, a timestamp, #' and encoding information. #' #' While it is possible to create bare `srcfile` objects, specialized subclasses #' are much more common. #' #' #' ### `srcfile` #' #' A bare `srcfile` object does not contain any data apart from the file path. #' It lazily loads lines from the file on disk, without any caching. #' #' Fields common to all `srcfile` objects: #' #' - `filename`: The filename of the source file. If relative, the path is #' resolved against `wd`. #' #' - `wd`: The working directory (`getwd()`) at the time the srcfile was created, #' generally at the time of parsing). #' #' - `timestamp`: The timestamp of the source file. Retrieved from `filename` #' with `file.mtime()`. #' #' - `encoding`: The encoding of the source file. #' #' - `Enc`: The encoding of output lines. Used by `getSrcLines()`, which #' calls `iconv()` when `Enc` does not match `encoding`. #' #' - `parseData` (optional): Parser information saved when `keep.source.data` is #' set to `TRUE`. #' #' Implementations: #' - `print()` and `summary()` to print information about the source file. #' - `open()` and `close()` to access the underlying file as a connection. #' #' Helpers: #' - `getSrcLines()`: Retrieves source lines from a `srcfile`. #' #' #' ### `srcfilecopy` #' #' A `srcfilecopy` stores the actual source lines in memory in `$lines`. #' `srcfilecopy` is useful when the original file may change or does not #' exist, because it preserves the exact text used by the parser. #' #' This type of srcfile is the most common. It's created by: #' #' - The R-level `parse()` function when `text` is supplied: #' #' ```r #' # Creates a `""` non-file `srcfilecopy` #' parse(text = "...", keep.source = TRUE) #' ``` #' #' - The console's input parser when `getOption("keep.source")` is `TRUE`. #' #' - `sys.source()` when `keep.source = TRUE`: #' #' ```r #' sys.source(file, keep.source = TRUE) #' ``` #' #' The `srcfilecopy` object is timestamped with the file's last modification time. #' #' #' Fields: #' #' - `filename`: The filename of the source file. If `isFile` is `FALSE`, #' the field is non meaningful. For instance `parse(text = )` sets it to #' `""`, and the console input parser sets it to `""`. #' #' - `isFile`: A logical indicating whether the source file exists. #' #' - `fixedNewlines`: If `TRUE`, `lines` is a character vector of lines with #' no embedded `\n` characters. The `getSrcLines()` helper regularises `lines` #' in this way and sets `fixedNewlines` to `TRUE`. #' #' #' Note that the C-level parser (used directly mainly when parsing console input) #' does not call the R-level constructor and only instantiates the `filename` #' (set to `""`) and `lines` fields. #' #' ### `srcfilealias` #' #' This object wraps an existing `srcfile` object (stored in `original`). It #' allows exposing a different `filename` while delegating the open/close/get #' lines operations to the `srcfile` stored in `original`. #' #' The typical way aliases are created is via `#line *line* *filename*` #' directives where the optional `*filename*` argument is supplied. These #' directives remap the srcref and srcfile of parsed code to a different #' location, for example from a temporary file or generated file to the original #' location on disk. #' #' Created by `install.packages()` when installing a _source_ package with `keep.source.pkgs` set to `TRUE` (see #' ), but #' [only when](https://github.com/r-devel/r-svn/blob/52affc16/src/library/tools/R/admin.R#L308): #' #' - `Encoding` was supplied in `DESCRIPTION` #' - The system locale is not "C" or "POSIX". #' #' The source files are converted to the encoding of the system locale, then #' collated in a single source file with `#line` directives mapping them to their #' original file names (with full paths): #' . #' #' Note that the `filename` of the `original` srcfile incorrectly points to the #' package path in the install destination. #' #' #' Fields: #' #' - `filename`: The virtual file name (or full path) of the parsed code. #' - `original`: The actual `srcfile` the code was parsed from. #' #' @seealso #' - [srcfile()]: Base documentation for `srcref` and `srcfile` objects. #' - [getParseData()]: Parse information stored when `keep.source.data` is `TRUE`. #' - Source References (R Journal): #' #' @export #' @family object inspectors src <- function( x, max_depth = 5L, max_length = 100L, ... ) { seen_srcfiles <- new.env(parent = emptyenv()) seen_srcfiles$.counter <- 0L result <- src_extract(x, seen_srcfiles) if (is.null(result)) { return(invisible(NULL)) } # Ensure result has proper type for tree display if (is.null(attr(result, "srcref_type"))) { result <- as_srcref_tree(result, from = x) } structure( result, max_depth = max_depth, max_length = max_length, tree_args = list(...), class = c("lobstr_srcref", class(result)) ) } #' @export print.lobstr_srcref <- function(x, ...) { max_depth <- attr(x, "max_depth") %||% 5L max_length <- attr(x, "max_length") %||% 100L tree_args <- attr(x, "tree_args") %||% list() # Strip attributes before printing attr(x, "max_depth") <- NULL attr(x, "max_length") <- NULL attr(x, "tree_args") <- NULL # Defaults for `tree()` arguments that are not directly exposed by `src()` tree_args$max_vec_len <- tree_args$max_vec_len %||% 3L inject(tree( x = x, max_depth = max_depth, max_length = max_length, !!!tree_args )) invisible(x) } #' @export tree_label.lobstr_srcref <- function(x, opts) { type <- attr(x, "srcref_type") switch( type, body = "", block = "<{>", srcfile = srcfile_label(x), paste0("<", type, ">") ) } #' @export tree_label.lobstr_srcref_location <- function(x, opts) { as.character(x) } #' @export tree_label.srcref <- function(x, opts) { loc <- srcref_location(x) paste0("") } #' @export tree_label.srcfile <- function(x, opts) { paste0("<", class(x)[1], ": ", utils::getSrcFilename(x), ">") } #' @export tree_label.lobstr_srcfile_ref <- function(x, opts) { paste0("@", as.character(x)) } # Main extraction logic -------------------------------------------------------- src_extract <- function(x, seen_srcfiles) { # Srcref object if (inherits(x, "srcref")) { return(srcref_node(x, seen_srcfiles)) } # List of srcrefs if ( is.list(x) && length(x) > 0 && all(vapply(x, inherits, logical(1), "srcref")) ) { return(srcref_list_node(x, seen_srcfiles)) } # Evaluated closures if (is_closure(x)) { return(function_node(x, seen_srcfiles)) } # Expressions and language objects if (is.expression(x) || is.language(x)) { return(expr_node(x, seen_srcfiles)) } NULL } # Extract standard srcref-related attributes from any object extract_srcref_attrs <- function(x, seen_srcfiles) { attrs <- list() if (!is.null(srcref <- attr(x, "srcref"))) { attrs$`attr("srcref")` <- srcref_attr_node( srcref, seen_srcfiles ) } if (!is.null(srcfile <- attr(x, "srcfile"))) { attrs$`attr("srcfile")` <- srcfile_node(srcfile, seen_srcfiles) } if (!is.null(whole <- attr(x, "wholeSrcref"))) { attrs$`attr("wholeSrcref")` <- srcref_attr_node(whole, seen_srcfiles) } attrs } # A srcref attribute may be a srcref object or a list of srcref objects srcref_attr_node <- function(srcref, seen_srcfiles) { if (inherits(srcref, "srcref")) { return(srcref_node(srcref, seen_srcfiles)) } if (is.list(srcref)) { return(srcref_list_node(srcref, seen_srcfiles)) } NULL } srcref_node <- function(srcref, seen_srcfiles) { info <- srcref_info(srcref) node <- list(location = info$location) if (!is.null(info$bytes)) { node$bytes <- info$bytes } if (!is.null(info$parsed)) { node$parsed <- info$parsed } # Just for completeness but we really don't expect srcref attributes on srcrefs attrs <- extract_srcref_attrs(srcref, seen_srcfiles) node <- c(node, attrs) new_srcref_tree(node, type = "srcref") } srcref_list_node <- function(srcref_list, seen_srcfiles) { srcrefs <- lapply(srcref_list, srcref_node, seen_srcfiles) names(srcrefs) <- paste0("[[", seq_along(srcrefs), "]]") attrs <- extract_srcref_attrs(srcref_list, seen_srcfiles) node <- c(srcrefs, attrs) new_srcref_tree(node, type = "list") } function_node <- function(fun, seen_srcfiles) { node <- extract_srcref_attrs(fun, seen_srcfiles) body <- src_extract(body(fun), seen_srcfiles) if (!is.null(body)) { node$`body()` <- as_srcref_tree(body, from = body(fun)) } if (length(node) == 0) { return(NULL) } new_srcref_tree(node, type = "closure") } expr_node <- function(x, seen_srcfiles) { attrs <- extract_srcref_attrs(x, seen_srcfiles) nested <- extract_nested_srcrefs(x, seen_srcfiles) if (length(attrs) > 0) { # Node has attributes: wrap with proper type node <- c(attrs, nested) return(new_srcref_tree(node, type = node_type(x))) } # No attributes: return bare list for path collapsing, or NULL if empty if (length(nested) > 0) { nested } else { NULL } } extract_nested_srcrefs <- function(x, seen_srcfiles) { if (!is_traversable(x)) { return(list()) } nested <- list() for (i in seq_along(x)) { child <- src_extract(x[[i]], seen_srcfiles) if (!is.null(child)) { nested <- merge_child_result(nested, child, i) } } nested } merge_child_result <- function(nested, child, index) { path <- paste0("[[", index, "]]") if (is_wrapped_node(child)) { nested[[path]] <- child } else { # Collapse paths for bare lists for (name in names(child)) { nested[[paste0(path, name)]] <- child[[name]] } } nested } is_traversable <- function(x) { (is.expression(x) || is.call(x)) && length(x) > 0 } is_wrapped_node <- function(x) { !is.null(attr(x, "srcref_type")) } node_type <- function(x) { if (is.expression(x)) { "expression" } else if (is.call(x) && length(x) > 0) { if (identical(x[[1]], as.symbol("function"))) { "quoted_function" } else if (identical(x[[1]], as.symbol("{"))) { "block" } else { "language" } } else { "language" } } as_srcref_tree <- function(data, ..., from) { if (is_wrapped_node(data)) { data } else { new_srcref_tree(data, type = node_type(from)) } } # Srcfile handling ------------------------------------------------------------- srcfile_node <- function(srcfile, seen_srcfiles) { if (is.null(srcfile)) { return(NULL) } addr <- obj_addr(srcfile) srcfile_class <- class(srcfile)[[1]] # Check if already seen id <- seen_srcfiles[[addr]] if (!is_null(id)) { return(new_srcfile_ref(id, srcfile_class)) } # First occurrence - assign sequential ID seen_srcfiles$.counter <- seen_srcfiles$.counter + 1L id <- sprintf("%03d", seen_srcfiles$.counter) seen_srcfiles[[addr]] <- id info <- as.list.environment(srcfile, all.names = TRUE, sorted = TRUE) # Format timestamp for readability if (!is.null(info$timestamp)) { info$timestamp <- format(info$timestamp) } # Process nested srcfile objects (e.g., 'original' in srcfilealias) if (!is.null(info$original) && inherits(info$original, "srcfile")) { info$original <- srcfile_node(info$original, seen_srcfiles) } # Add source preview for plain srcfiles if (!inherits(srcfile, "srcfilecopy") && !is.null(srcref)) { snippet <- srcfile_lines(srcfile, srcref) if (length(snippet) > 0) { info$`lines (from file)` <- snippet } } # Check for srcref attributes even on srcfile objects attrs <- extract_srcref_attrs(srcfile, seen_srcfiles) info <- c(info, attrs) new_srcref_tree( info, type = "srcfile", srcfile_class = srcfile_class %||% "srcfile", srcfile_id = id ) } srcfile_lines <- function(srcfile, srcref) { if (is.null(srcfile) || !is_srcref(srcref)) { return(character(0)) } max_lines <- 3L first_line <- srcref[[1]] last_line <- min(srcref[[3]], first_line + max_lines - 1L) # Try embedded lines first lines <- srcfile$lines if (!is.null(lines) && length(lines) >= last_line) { return(lines[first_line:last_line]) } # Try reading from file filename <- srcfile$filename directory <- srcfile$wd if (!is.null(filename) && !is.null(directory)) { filepath <- file.path(directory, filename) if (file.exists(filepath)) { all_lines <- tryCatch( readLines(filepath, warn = FALSE), error = function(e) NULL ) if (!is.null(all_lines) && length(all_lines) >= last_line) { return(all_lines[first_line:last_line]) } } } character(0) } srcfile_label <- function(x) { class <- attr(x, "srcfile_class") label <- paste0("<", class, ">") id <- attr(x, "srcfile_id") if (!is.null(id)) { label <- paste0(label, " @", id) } label } # Srcref information extraction ------------------------------------------------ srcref_info <- function(srcref) { if (!inherits(srcref, "srcref")) { abort("Expected a srcref object") } len <- length(srcref) if (!len %in% c(4, 6, 8)) { abort(sprintf("Unexpected srcref length: %d", len)) } first_line <- srcref[[1]] first_byte <- srcref[[2]] last_line <- srcref[[3]] last_byte <- srcref[[4]] first_col <- if (len >= 6) srcref[[5]] else first_byte last_col <- if (len >= 6) srcref[[6]] else last_byte first_parsed <- if (len == 8) srcref[[7]] else first_line last_parsed <- if (len == 8) srcref[[8]] else last_line info <- list( location = new_srcref_location(srcref_location(srcref)) ) # Add byte info if different from columns if (first_byte != first_col || last_byte != last_col) { info$bytes <- sprintf("%d - %d", first_byte, last_byte) } # Add parsed info if different from actual lines if (first_parsed != first_line || last_parsed != last_line) { info$parsed <- new_srcref_location(sprintf( "%d:%d - %d:%d", first_parsed, first_col, last_parsed, last_col )) } info } srcref_location <- function(x) { first_line <- x[[1]] last_line <- x[[3]] first_col <- if (length(x) >= 6) x[[5]] else x[[2]] last_col <- if (length(x) >= 6) x[[6]] else x[[4]] sprintf("%d:%d - %d:%d", first_line, first_col, last_line, last_col) } # Helper functions ------------------------------------------------------------- has_srcref <- function(x) { !is.null(attr(x, "srcref")) || !is.null(attr(x, "wholeSrcref")) || !is.null(attr(x, "srcfile")) } new_srcref_tree <- function(x, type = NULL, ..., class = NULL) { type <- type %||% attr(x, "srcref_type") type <- arg_match( type, c( "block", "body", "closure", "expression", "language", "list", "quoted_function", "srcfile", "srcref" ) ) structure( x, srcref_type = type, ..., class = c(class, "lobstr_srcref") ) } new_srcref_location <- function(x) { structure(x, class = c("lobstr_srcref_location", "character")) } new_srcfile_ref <- function(id, srcfile_class = "srcfile") { structure( id, srcfile_class = srcfile_class, class = "lobstr_srcfile_ref" ) } is_srcref <- function(x) { is.integer(x) && inherits(x, "srcref") && length(x) %in% c(4L, 6L, 8L) } lobstr/R/cst.R0000644000176200001440000000213115104641646012700 0ustar liggesusers#' Call stack tree #' #' Shows the relationship between calls on the stack. This function #' combines the results of [sys.calls()] and [sys.parents()] yielding a display #' that shows how frames on the call stack are related. #' #' @export #' @examples #' # If all evaluation is eager, you get a single tree #' f <- function() g() #' g <- function() h() #' h <- function() cst() #' f() #' #' # You get multiple trees with delayed evaluation #' try(f()) #' #' # Pay attention to the first element of each subtree: each #' # evaluates the outermost call #' f <- function(x) g(x) #' g <- function(x) h(x) #' h <- function(x) x #' try(f(cst())) #' #' # With a little ingenuity you can use it to see how NSE #' # functions work in base R #' with(mtcars, {cst(); invisible()}) #' invisible(subset(mtcars, {cst(); cyl == 0})) #' #' # You can also get unusual trees by evaluating in frames #' # higher up the call stack #' f <- function() g() #' g <- function() h() #' h <- function() eval(quote(cst()), parent.frame(2)) #' f() cst <- function() { x <- rlang::trace_back() print(x, simplify = "none") invisible() } lobstr/R/tree.R0000644000176200001440000003222515143624757013064 0ustar liggesusers#' Pretty tree-like object printing #' #' A cleaner and easier to read replacement for `str` for nested list-like #' objects #' #' @param x A tree like object (list, etc.) #' @param index_unnamed Should children of containers without names have indices #' used as stand-in? #' @param max_depth How far down the tree structure should be printed. E.g. `1` #' means only direct children of the root element will be shown. Useful for #' very deep lists. #' @param max_vec_len How many elements should be printed for vectors? #' @param show_environments Should environments be treated like normal lists and #' recursed into? #' @param hide_scalar_types Should atomic scalars be printed with type and #' length like vectors? E.g. `x <- "a"` would be shown as `x: "a"` #' instead of `x: "a"`. #' @param max_length How many elements should be printed? This is useful in case #' you try and print an object with 100,000 items in it. #' @param val_printer Function that values get passed to before being drawn to #' screen. Can be used to color or generally style output. #' @param class_printer Same as `val_printer` but for the the class types of #' non-atomic tree elements. #' @param show_attributes Should attributes be printed as a child of the list or #' avoided? #' @param remove_newlines Should character strings with newlines in them have #' the newlines removed? Not doing so will mess up the vertical flow of the #' tree but may be desired for some use-cases if newline structure is #' important to understanding object state. #' @param tree_chars List of box characters used to construct tree. Needs #' elements `$h` for horizontal bar, `$hd` for dotted horizontal bar, `$v` for #' vertical bar, `$vd` for dotted vertical bar, `$l` for l-bend, and `$j` for #' junction (or middle child). #' @param ... Ignored (used to force use of names) #' #' @return console output of structure #' #' @examples #' #' x <- list( #' list(id = "a", val = 2), #' list( #' id = "b", #' val = 1, #' children = list( #' list(id = "b1", val = 2.5), #' list( #' id = "b2", #' val = 8, #' children = list( #' list(id = "b21", val = 4) #' ) #' ) #' ) #' ), #' list( #' id = "c", #' val = 8, #' children = list( #' list(id = "c1"), #' list(id = "c2", val = 1) #' ) #' ) #' ) #' #' # Basic usage #' tree(x) #' #' # Even cleaner output can be achieved by not printing indices #' tree(x, index_unnamed = FALSE) #' #' # Limit depth if object is potentially very large #' tree(x, max_depth = 2) #' #' # You can customize how the values and classes are printed if desired #' tree(x, val_printer = function(x) { #' paste0("_", x, "_") #' }) #' @export tree <- function( x, ..., index_unnamed = FALSE, max_depth = 10L, max_length = 1000L, max_vec_len = 10L, show_environments = TRUE, hide_scalar_types = TRUE, val_printer = crayon::blue, class_printer = crayon::silver, show_attributes = FALSE, remove_newlines = TRUE, tree_chars = box_chars() ) { rlang::check_dots_empty() # Pack up the unchanging arguments into a list and send to tree_internal termination_type <- tree_internal( x, opts = list( index_unnamed = index_unnamed, max_depth = max_depth, max_length = max_length, max_vec_len = max_vec_len, show_envs = show_environments, hide_scalar_types = hide_scalar_types, val_printer = val_printer, class_printer = class_printer, show_attributes = show_attributes, remove_newlines = remove_newlines, tree_chars = tree_chars ) ) if (termination_type == "early") { cat("...", "\n") } invisible(x) } # Tree printing internal function # # This is the internal function for the main tree printing code. It wraps the # static options arguments from the user-facing `tree()` into a single opts # list to make recursive calls cleaner. It also has arguments that as it is # called successively but the end-user shouldn't see or use. tree_internal <- function( x, x_id = NULL, branch_hist = character(0), opts, attr_mode = FALSE, counter_env = rlang::new_environment( data = list(n_printed = 0, envs_seen = c()) ) ) { counter_env$n_printed <- counter_env$n_printed + 1 # Stop if we've reached the max number of times printed desired if (counter_env$n_printed > opts$max_length) { return("early") } # Since self-loops can occur in environments check to see if we've seen any # environments before already_seen <- FALSE if (rlang::is_environment(x)) { already_seen <- any(vapply( counter_env$envs_seen, identical, x, FUN.VALUE = logical(1) )) if (!already_seen) { # If this environment is new, add it to the seen counter_env$envs_seen[[length(counter_env$envs_seen) + 1]] <- x } } depth <- length(branch_hist) # Build branch string from branch history # Start with empty spaces branch_chars <- rep_len(" ", depth) branch_chars[branch_hist == "child"] <- paste0(opts$tree_chars$v, " ") branch_chars[grepl("attr", branch_hist, fixed = TRUE)] <- paste0( opts$tree_chars$vd, " " ) # Next update the final element (aka the current step) with the correct branch type last_step <- branch_hist[depth] root_node <- length(branch_hist) == 0 branch_chars[depth] <- if (root_node) { "" } else { paste0( if (grepl("last", last_step)) opts$tree_chars$l else opts$tree_chars$j, if (grepl("attribute", last_step)) { opts$tree_chars$hd } else { opts$tree_chars$h } ) } # Build label label <- paste0( x_id, make_type_abrev(x, opts$hide_scalar_types), if (!rlang::is_null(x_id) && x_id != "") ": ", tree_label(x, opts), if (already_seen) " (Already seen)" ) # Figure out how many children we have (plus attributes if they are being # printed) so we can setup how to proceed x_attributes <- attributes(x) if (attr_mode) { # Filter out "names" attribute as this is already shown by tree x_attributes <- x_attributes[names(x_attributes) != "names"] } has_attributes <- length(x_attributes) > 0 && opts$show_attributes has_children <- has_attributes || length(x) > 1 max_depth_reached <- depth >= opts$max_depth && has_children # Do the actual printing to the console with an optional ellipses to indicate # we've reached the max depth and won't recurse more cat( paste(branch_chars, collapse = ""), label, if (max_depth_reached) "...", "\n", sep = "" ) # ===== Start recursion logic if (already_seen || max_depth_reached) { return("Normal finish") } if (rlang::is_list(x) || is_printable_env(x)) { # Coerce current object to a plain list. This is necessary as some s3 # classes override `[[` and return funky stuff like themselves (see s3 class # "package_version") children <- if (is_printable_env(x)) { # Environments are funky as they don't have names before conversion to list # but do after, so let them handle their conversion. # We use all.names = TRUE in an effort to fully explain the object as.list.environment(x, all.names = TRUE) } else { # By wiping all attributes except for the names we force the object to be # a plain list. This is inspired by the (now depreciated) rlang::as_list(). attributes(x) <- list(names = names(x)) as.list(x) } # Traverse children, if any exist n_children <- length(children) child_names <- names(children) # If children have names, give them the names for (i in seq_along(children)) { id <- child_names[i] if ((rlang::is_null(id) || id == "") && opts$index_unnamed) { id <- crayon::italic(i) } child_type <- if (i < n_children) { "child" } else if (has_attributes) { # We use "attrs" here instead of full "attribute" so a grep for # attributes just gets plain "attribute" or "last-attribute" but a grep # for "attr" gets all attribute related types "pre-attrs" } else { "last-child" } termination_type <- Recall( x = children[[i]], x_id = id, branch_hist = c(branch_hist, child_type), opts = opts, counter_env = counter_env ) if (termination_type == "early") { return(termination_type) } } } # ===== End recursion logic # Add any attributes as an "attr" prefixed children at end if (has_attributes) { n_attributes <- length(x_attributes) for (i in seq_len(n_attributes)) { termination_type <- Recall( x = x_attributes[[i]], x_id = crayon::italic(paste0( "attr(,\"", names(x_attributes)[i], "\")" )), opts = opts, branch_hist = c( branch_hist, paste0(if (i == n_attributes) "last-", "attribute") ), attr_mode = TRUE, # Let tree know this is an attribute counter_env = counter_env ) if (termination_type == "early") { return(termination_type) } } } # If all went smoothly we reach here "Normal finish" } # There are a few environments we don't want to recurse into is_printable_env <- function(x) { is_environment(x) && !(identical(x, rlang::global_env()) || identical(x, rlang::empty_env()) || identical(x, rlang::base_env()) || rlang::is_namespace(x)) } #' Build element or node label in tree #' #' These methods control how the value of a given node is printed. New methods #' can be added if support is needed for a novel class #' #' @inheritParams tree #' @param opts A list of options that directly mirrors the named arguments of #' [tree]. E.g. `list(val_printer = crayon::red)` is equivalent to #' `tree(..., val_printer = crayon::red)`. #' #' @export tree_label <- function(x, opts) { UseMethod("tree_label") } #' @export tree_label.function <- function(x, opts) { func_args <- collapse_and_truncate_vec(methods::formalArgs(x), 5) crayon::italic(paste0("function(", func_args, ")")) } #' @export tree_label.environment <- function(x, opts) { format.default(x) } #' @export tree_label.NULL <- function(x, opts) { "" } #' @export tree_label.character <- function(x, opts) { # Get rid of new-line so they don't break tree flow if (opts$remove_newlines) { x <- gsub("\\n", replacement = "\u21B5", x = x, perl = TRUE) } # Shorten strings if needed max_standalone_length <- 35 max_vec_length <- 15 max_length <- if (length(x) == 1) max_standalone_length else max_vec_length x <- truncate_string(x, max_length) tree_label.default(paste0("\"", x, "\""), opts) } #' @export tree_label.default <- function(x, opts) { if (rlang::is_atomic(x)) { opts$val_printer(collapse_and_truncate_vec(x, opts$max_vec_len)) } else if (rlang::is_function(x)) { # Lots of times function-like functions don't actually trigger the s3 method # for function because they dont have function in their class-list. This # catches those. tree_label.function(x, opts) } else if (rlang::is_environment(x)) { # Environments also tend to have the same trouble as functions. For instance # the srcobject attached to a function's attributes is an environment but # doesn't report as one to s3. tree_label.environment(x, opts) } else if (rlang::is_expression(x) || rlang::is_formula(x)) { paste0(label_class(x, opts), " ", crayon::italic(deparse(x))) } else { # The "base-case" is simply a list-like object. label_class(x, opts) } } collapse_and_truncate_vec <- function(vec, max_length) { vec <- as.character(vec) too_long <- length(vec) > max_length if (too_long) { vec <- utils::head(vec, max_length) vec <- c(vec, "...") } paste0(vec, collapse = ", ") } truncate_string <- function(char_vec, max_length) { ifelse( nchar(char_vec) > max_length, # Since we add an elipses we need to take a bit more than the max length # off. The gsub adds elipses but also makes sure we dont awkwardly end on # a space. gsub( x = substr(char_vec, start = 1, max_length - 3), pattern = "\\s*$", replacement = "...", perl = TRUE ), char_vec ) } make_type_abrev <- function(x, omit_scalars) { if (!rlang::is_atomic(x) || (rlang::is_scalar_atomic(x) && omit_scalars)) { return("") } type_abrev <- switch( typeof(x), logical = "lgl", integer = "int", double = "dbl", character = "chr", complex = "cpl", expression = "expr", raw = "raw", "unknown" ) paste0("<", type_abrev, " [", format(length(x), big.mark = ","), "]>") } # Inspired by waldo:::friendly_type_of(). Prints the class name and hierarchy # encased in angle brackets along with a prefix that tells you what OO system # the object belongs to (if it does.) label_class <- function(x, opts) { if (is_missing(x)) { return("absent") } oo_prefix <- "" class_list <- if (!is.object(x)) { typeof(x) } else if (isS4(x)) { oo_prefix <- "S4" methods::is(x) } else if (inherits(x, "R6")) { oo_prefix <- "R6" setdiff(class(x), "R6") } else { oo_prefix <- "S3" class(x) } opts$class_printer( paste0(oo_prefix, "<", paste(class_list, collapse = "/"), ">") ) } lobstr/R/utils.R0000644000176200001440000000317615105062605013252 0ustar liggesusersis_testing <- function() { identical(Sys.getenv("TESTTHAT"), "true") } # CLI --------------------------------------------------------------------- box_chars <- function() { fancy <- getOption("lobstr.fancy.tree") %||% l10n_info()$`UTF-8` orange <- crayon::make_style("orange") if (fancy) { list( "h" = "\u2500", # - horizontal "hd" = "\u2504", # - horizontal dotted "v" = "\u2502", # | vertical "vd" = "\u250A", # | vertical dotted "l" = "\u2514", # \ leaf "j" = "\u251C", # + junction "n" = orange("\u2588") # X node ) } else { list( "h" = "-", "hd" = "-", # Just use normal chars for dotted "v" = "|", "vd" = "|", "l" = "\\", "j" = "+", "n" = orange("o") ) } } grey <- function(...) { crayon::make_style(grDevices::grey(0.5), grey = TRUE)(...) } # string ----------------------------------------------------------------- str_dup <- function(x, n) { vapply(n, function(i) paste0(rep(x, i), collapse = ""), character(1)) } str_indent <- function(x, first, rest) { if (length(x) == 0) { character() } else if (length(x) == 1) { paste0(first, x) } else { c( paste0(first, x[[1]]), paste0(rest, x[-1L]) ) } } str_truncate <- function(x, n) { too_long <- nchar(x, type = "width") > n x[too_long] <- paste0(substr(x[too_long], 1, n - 3), "...") x } new_raw <- function(x) { structure(x, class = "lobstr_raw") } #' @export print.lobstr_raw <- function(x, ...) { cat(paste(x, "\n", collapse = ""), sep = "") invisible(x) } cat_line <- function(...) { cat(paste0(..., "\n", collapse = "")) } lobstr/R/lobstr.R0000644000176200001440000000022315143621142013404 0ustar liggesusers#' @import rlang #' @useDynLib lobstr, .registration = TRUE NULL .onLoad <- function(libname, pkgname) { init_library(rlang::ns_env(pkgname)) } lobstr/R/lobstr-package.R0000644000176200001440000000013515104641646015007 0ustar liggesusers#' @keywords internal "_PACKAGE" ## usethis namespace: start ## usethis namespace: end NULL lobstr/R/address.R0000644000176200001440000000264213500655217013540 0ustar liggesusers#' Find memory location of objects and their children. #' #' `obj_addr()` gives the address of the value that `x` points to; #' `obj_addrs()` gives the address of the components the list, #' environment, and character vector `x` point to. #' #' `obj_addr()` has been written in such away that it avoids taking #' references to an object. #' #' @param x An object #' @export #' @examples #' # R creates copies lazily #' x <- 1:10 #' y <- x #' obj_addr(x) == obj_addr(y) #' #' y[1] <- 2L #' obj_addr(x) == obj_addr(y) #' #' y <- runif(10) #' obj_addr(y) #' z <- list(y, y) #' obj_addrs(z) #' #' y[2] <- 1.0 #' obj_addrs(z) #' obj_addr(y) #' #' # The address of an object is different every time you create it: #' obj_addr(1:10) #' obj_addr(1:10) #' obj_addr(1:10) obj_addr <- function(x) { x <- enquo(x) addr <- obj_addr_(quo_get_expr(x), quo_get_env(x)) if (is_testing()) { test_addr_get(addr) } else { addr } } #' @export #' @rdname obj_addr obj_addrs <- function(x) { addrs <- obj_addrs_(x) if (is_testing()) { vapply(addrs, test_addr_get, character(1), USE.NAMES = FALSE) } else { addrs } } test_addr <- child_env(emptyenv(), "__next_id" = 1) test_addr_get <- function(addr) { if (env_has(test_addr, addr)) { addr <- env_get(test_addr, addr) } else { addr <- obj_id(test_addr, addr) } sprintf("0x%03i", addr) } test_addr_reset <- function() { env_poke(test_addr, "__next_id", 1) } lobstr/R/mem.R0000644000176200001440000000143113256202040012652 0ustar liggesusers#' How much memory is currently used by R? #' #' `mem_used()` wraps around `gc()` and returns the exact number of bytes #' currently used by R. Note that changes will not match up exactly to #' [obj_size()] as session specific state (e.g. [.Last.value]) adds minor #' variations. #' #' @export #' @examples #' prev_m <- 0; m <- mem_used(); m - prev_m #' #' x <- 1:1e6 #' prev_m <- m; m <- mem_used(); m - prev_m #' obj_size(x) #' #' rm(x) #' prev_m <- m; m <- mem_used(); m - prev_m #' #' prev_m <- m; m <- mem_used(); m - prev_m mem_used <- function() { new_bytes(sum(gc()[, 1] * c(node_size(), 8))) } node_size <- function() { bit <- 8L * .Machine$sizeof.pointer if (!(bit == 32L || bit == 64L)) { stop("Unknown architecture", call. = FALSE) } if (bit == 32L) 28L else 56L } lobstr/src/0000755000176200001440000000000015163704702012353 5ustar liggesuserslobstr/src/size.cpp0000644000176200001440000002362515144564741014047 0ustar liggesusers#include #include #include #include #include #include #include "utils.h" extern "C" { #include } [[cpp11::register]] double v_size(double n, int element_size) { if (n == 0) return 0; double vec_size = std::max(sizeof(SEXP), sizeof(double)); double elements_per_byte = vec_size / element_size; double n_bytes = ceil(n / elements_per_byte); // Rcout << n << " elements, each of " << elements_per_byte << " = " << // n_bytes << "\n"; double size = 0; // Big vectors always allocated in 8 byte chunks if (n_bytes > 16) size = n_bytes * 8; // For small vectors, round to sizes allocated in small vector pool else if (n_bytes > 8) size = 128; else if (n_bytes > 6) size = 64; else if (n_bytes > 4) size = 48; else if (n_bytes > 2) size = 32; else if (n_bytes > 1) size = 16; else if (n_bytes > 0) size = 8; // Size is pointer to struct + struct size return size; } bool is_namespace(cpp11::environment env) { return env == R_BaseNamespace || r_env_has(env, Rf_install(".__NAMESPACE__.")); } // R equivalent // https://github.com/wch/r-source/blob/master/src/library/utils/src/size.c#L41 double obj_size_tree(SEXP x, cpp11::environment base_env, int sizeof_node, int sizeof_vector, std::set& seen, int depth) { // NILSXP is a singleton, so occupies no space. Similarly SPECIAL and // BUILTIN are fixed and unchanging if (TYPEOF(x) == NILSXP || TYPEOF(x) == SPECIALSXP || TYPEOF(x) == BUILTINSXP) return 0; // Don't count objects that we've seen before if (!seen.insert(x).second) return 0; // Rcout << "\n" << std::string(depth * 2, ' '); // Rprintf("type: %s", Rf_type2char(TYPEOF(x))); // Use sizeof(SEXPREC) and sizeof(VECTOR_SEXPREC) computed in R. // CHARSXP are treated as vectors for this purpose double size = (Rf_isVector(x) || TYPEOF(x) == CHARSXP) ? sizeof_vector : sizeof_node; #if defined(R_VERSION) && R_VERSION >= R_Version(3, 5, 0) // Handle ALTREP objects if (ALTREP(x)) { SEXP klass = ALTREP_CLASS(x); size += 3 * sizeof(SEXP); size += obj_size_tree(klass, base_env, sizeof_node, sizeof_vector, seen, depth + 1); size += obj_size_tree(R_altrep_data1(x), base_env, sizeof_node, sizeof_vector, seen, depth + 1); size += obj_size_tree(R_altrep_data2(x), base_env, sizeof_node, sizeof_vector, seen, depth + 1); return size; } #endif // CHARSXPs have fake attributes if (TYPEOF(x) != CHARSXP && ANY_ATTRIB(x)) { SEXP attribs = PROTECT(collect_attribs(x)); for (SEXP node = attribs; node != R_NilValue; node = CDR(node)) { size += sizeof_node; size += obj_size_tree(TAG(node), base_env, sizeof_node, sizeof_vector, seen, depth + 1); size += obj_size_tree(CAR(node), base_env, sizeof_node, sizeof_vector, seen, depth + 1); } UNPROTECT(1); } switch (TYPEOF(x)) { // Vectors ------------------------------------------------------------------- // See details in v_size() // Simple vectors case LGLSXP: case INTSXP: size += v_size(XLENGTH(x), sizeof(int)); break; case REALSXP: size += v_size(XLENGTH(x), sizeof(double)); break; case CPLXSXP: size += v_size(XLENGTH(x), sizeof(Rcomplex)); break; case RAWSXP: size += v_size(XLENGTH(x), 1); break; // Strings case STRSXP: size += v_size(XLENGTH(x), sizeof(SEXP)); for (R_xlen_t i = 0; i < XLENGTH(x); i++) { size += obj_size_tree(STRING_ELT(x, i), base_env, sizeof_node, sizeof_vector, seen, depth + 1); } break; case CHARSXP: size += v_size(LENGTH(x) + 1, 1); break; // Generic vectors case VECSXP: case EXPRSXP: case WEAKREFSXP: size += v_size(XLENGTH(x), sizeof(SEXP)); for (R_xlen_t i = 0; i < XLENGTH(x); ++i) { size += obj_size_tree(VECTOR_ELT(x, i), base_env, sizeof_node, sizeof_vector, seen, depth + 1); } break; // Nodes --------------------------------------------------------------------- // https://github.com/wch/r-source/blob/master/src/include/Rinternals.h#L237-L249 // All have enough space for three SEXP pointers // Linked lists case DOTSXP: case LISTSXP: case LANGSXP: { if (x == R_MissingArg) { // Needed for DOTSXP break; } SEXP cons = x; for (; is_linked_list(cons); cons = CDR(cons)) { if (cons != x) { size += sizeof_node; } size += obj_size_tree(TAG(cons), base_env, sizeof_node, sizeof_vector, seen, depth + 1); size += obj_size_tree(CAR(cons), base_env, sizeof_node, sizeof_vector, seen, depth + 1); } // Handle non-nil CDRs size += obj_size_tree(cons, base_env, sizeof_node, sizeof_vector, seen, depth + 1); break; } case BCODESXP: size += obj_size_tree(TAG(x), base_env, sizeof_node, sizeof_vector, seen, depth + 1); size += obj_size_tree(CAR(x), base_env, sizeof_node, sizeof_vector, seen, depth + 1); size += obj_size_tree(CDR(x), base_env, sizeof_node, sizeof_vector, seen, depth + 1); break; // Environments case ENVSXP: { if (x == R_BaseEnv || x == R_GlobalEnv || x == R_EmptyEnv || x == base_env || is_namespace(x)) return 0; // Iterate over bindings using the environment API (r-lib/lobstr#48) cpp11::sexp syms(r_env_syms(x)); R_xlen_t n = Rf_xlength(syms); // Estimate hash table size: VECSXP with capacity slots. Hash table has // minimum size 29 and resizes at 85% load factor. Non-hashed environments // (e.g. function environments) are smaller but we ignore that here. R_xlen_t capacity = std::max((R_xlen_t)29, (R_xlen_t)std::ceil(n / 0.85)); size += sizeof_vector + v_size(capacity, sizeof(SEXP)); // Each binding is stored in a pairlist node within the hash chain size += n * sizeof_node; for (R_xlen_t i = 0; i < n; ++i) { SEXP sym = VECTOR_ELT(syms, i); size += obj_size_tree(sym, base_env, sizeof_node, sizeof_vector, seen, depth + 1); 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: { size += obj_size_tree(PROTECT(r_env_get(x, sym)), base_env, sizeof_node, sizeof_vector, seen, depth + 1); UNPROTECT(1); break; } case R_ENV_BINDING_TYPE_delayed: // Promise node size += sizeof_node; size += obj_size_tree(r_env_binding_delayed_expr(x, sym), base_env, sizeof_node, sizeof_vector, seen, depth + 1); size += obj_size_tree(r_env_binding_delayed_env(x, sym), base_env, sizeof_node, sizeof_vector, seen, depth + 1); break; case R_ENV_BINDING_TYPE_forced: { // Promise node size += sizeof_node; size += obj_size_tree(r_env_binding_forced_expr(x, sym), base_env, sizeof_node, sizeof_vector, seen, depth + 1); size += obj_size_tree(PROTECT(r_env_get(x, sym)), base_env, sizeof_node, sizeof_vector, seen, depth + 1); UNPROTECT(1); break; } case R_ENV_BINDING_TYPE_active: size += obj_size_tree(r_env_binding_active_fn(x, sym), base_env, sizeof_node, sizeof_vector, seen, depth + 1); break; case R_ENV_BINDING_TYPE_unbound: break; } } size += obj_size_tree(r_env_parent(x), base_env, sizeof_node, sizeof_vector, seen, depth + 1); break; } // Functions case CLOSXP: #if (R_VERSION >= R_Version(4, 5, 0)) size += obj_size_tree(R_ClosureFormals(x), base_env, sizeof_node, sizeof_vector, seen, depth + 1); // R_ClosureBody/BODY is either a bare expression or a byte code that wraps // the expression along with other data. size += obj_size_tree(R_ClosureBody(x), base_env, sizeof_node, sizeof_vector, seen, depth + 1); size += obj_size_tree(R_ClosureEnv(x), base_env, sizeof_node, sizeof_vector, seen, depth + 1); #else size += obj_size_tree(FORMALS(x), base_env, sizeof_node, sizeof_vector, seen, depth + 1); size += obj_size_tree(BODY(x), base_env, sizeof_node, sizeof_vector, seen, depth + 1); size += obj_size_tree(CLOENV(x), base_env, sizeof_node, sizeof_vector, seen, depth + 1); #endif break; case PROMSXP: // Using node-based object accessors: CAR for PRVALUE, CDR for PRCODE, and // TAG for PRENV. TODO: Iterate manually over the environment using // environment accessors. size += obj_size_tree(CAR(x), base_env, sizeof_node, sizeof_vector, seen, depth + 1); size += obj_size_tree(CDR(x), base_env, sizeof_node, sizeof_vector, seen, depth + 1); size += obj_size_tree(TAG(x), base_env, sizeof_node, sizeof_vector, seen, depth + 1); break; case EXTPTRSXP: size += sizeof(void *); // the actual pointer size += obj_size_tree(R_ExternalPtrProtected(x), base_env, sizeof_node, sizeof_vector, seen, depth + 1); size += obj_size_tree(R_ExternalPtrTag(x), base_env, sizeof_node, sizeof_vector, seen, depth + 1); break; case S4SXP: size += obj_size_tree(TAG(x), base_env, sizeof_node, sizeof_vector, seen, depth + 1); break; case SYMSXP: break; default: cpp11::stop("Can't compute size of %s", Rf_type2char(TYPEOF(x))); } // Rprintf("type: %-10s size: %6.0f\n", Rf_type2char(TYPEOF(x)), size); return size; } [[cpp11::register]] double obj_size_(cpp11::list objects, cpp11::environment base_env, int sizeof_node, int sizeof_vector) { std::set seen; double size = 0; int n = objects.size(); for (int i = 0; i < n; ++i) { size += obj_size_tree(objects[i], base_env, sizeof_node, sizeof_vector, seen, 0); } return size; } [[cpp11::register]] cpp11::doubles obj_csize_(cpp11::list objects, cpp11::environment base_env, int sizeof_node, int sizeof_vector) { std::set seen; int n = objects.size(); cpp11::writable::doubles out(n); for (int i = 0; i < n; ++i) { out[i] = obj_size_tree(objects[i], base_env, sizeof_node, sizeof_vector, seen, 0); } return out; } lobstr/src/utils.h0000644000176200001440000000115015145635461013666 0ustar liggesusers#include #include inline std::string obj_addr_(SEXP x) { std::stringstream ss; ss << static_cast(x); return ss.str(); } static inline bool is_linked_list(SEXP x) { switch (TYPEOF(x)) { case DOTSXP: case LISTSXP: case LANGSXP: return true; default: return false; } } // Rf_length() crashes on flexible cells static inline R_xlen_t sxp_length(SEXP x) { if (TYPEOF(x) == LISTSXP) { R_xlen_t i = 0; while (is_linked_list(x)) { ++i; x = CDR(x); } return i; } else { return Rf_length(x); } } SEXP collect_attribs(SEXP x); lobstr/src/cpp11.cpp0000644000176200001440000000700515163460154014005 0ustar liggesusers// Generated by cpp11: do not edit by hand // clang-format off #include "cpp11/declarations.hpp" #include // address.cpp std::string obj_addr_(SEXP name, cpp11::environment env); extern "C" SEXP _lobstr_obj_addr_(SEXP name, SEXP env) { BEGIN_CPP11 return cpp11::as_sexp(obj_addr_(cpp11::as_cpp>(name), cpp11::as_cpp>(env))); END_CPP11 } // address.cpp std::vector obj_addrs_(SEXP x); extern "C" SEXP _lobstr_obj_addrs_(SEXP x) { BEGIN_CPP11 return cpp11::as_sexp(obj_addrs_(cpp11::as_cpp>(x))); END_CPP11 } // inspect.cpp cpp11::list obj_inspect_(SEXP x, double max_depth, bool expand_char, bool expand_altrep, bool expand_env, bool expand_call, bool expand_bytecode); extern "C" SEXP _lobstr_obj_inspect_(SEXP x, SEXP max_depth, SEXP expand_char, SEXP expand_altrep, SEXP expand_env, SEXP expand_call, SEXP expand_bytecode) { BEGIN_CPP11 return cpp11::as_sexp(obj_inspect_(cpp11::as_cpp>(x), cpp11::as_cpp>(max_depth), cpp11::as_cpp>(expand_char), cpp11::as_cpp>(expand_altrep), cpp11::as_cpp>(expand_env), cpp11::as_cpp>(expand_call), cpp11::as_cpp>(expand_bytecode))); END_CPP11 } // lobstr.cpp void init_library(SEXP env); extern "C" SEXP _lobstr_init_library(SEXP env) { BEGIN_CPP11 init_library(cpp11::as_cpp>(env)); return R_NilValue; END_CPP11 } // size.cpp double v_size(double n, int element_size); extern "C" SEXP _lobstr_v_size(SEXP n, SEXP element_size) { BEGIN_CPP11 return cpp11::as_sexp(v_size(cpp11::as_cpp>(n), cpp11::as_cpp>(element_size))); END_CPP11 } // size.cpp double obj_size_(cpp11::list objects, cpp11::environment base_env, int sizeof_node, int sizeof_vector); extern "C" SEXP _lobstr_obj_size_(SEXP objects, SEXP base_env, SEXP sizeof_node, SEXP sizeof_vector) { BEGIN_CPP11 return cpp11::as_sexp(obj_size_(cpp11::as_cpp>(objects), cpp11::as_cpp>(base_env), cpp11::as_cpp>(sizeof_node), cpp11::as_cpp>(sizeof_vector))); END_CPP11 } // size.cpp cpp11::doubles obj_csize_(cpp11::list objects, cpp11::environment base_env, int sizeof_node, int sizeof_vector); extern "C" SEXP _lobstr_obj_csize_(SEXP objects, SEXP base_env, SEXP sizeof_node, SEXP sizeof_vector) { BEGIN_CPP11 return cpp11::as_sexp(obj_csize_(cpp11::as_cpp>(objects), cpp11::as_cpp>(base_env), cpp11::as_cpp>(sizeof_node), cpp11::as_cpp>(sizeof_vector))); END_CPP11 } extern "C" { static const R_CallMethodDef CallEntries[] = { {"_lobstr_init_library", (DL_FUNC) &_lobstr_init_library, 1}, {"_lobstr_obj_addr_", (DL_FUNC) &_lobstr_obj_addr_, 2}, {"_lobstr_obj_addrs_", (DL_FUNC) &_lobstr_obj_addrs_, 1}, {"_lobstr_obj_csize_", (DL_FUNC) &_lobstr_obj_csize_, 4}, {"_lobstr_obj_inspect_", (DL_FUNC) &_lobstr_obj_inspect_, 7}, {"_lobstr_obj_size_", (DL_FUNC) &_lobstr_obj_size_, 4}, {"_lobstr_v_size", (DL_FUNC) &_lobstr_v_size, 2}, {NULL, NULL, 0} }; } extern "C" attribute_visible void R_init_lobstr(DllInfo* dll){ R_registerRoutines(dll, NULL, CallEntries, NULL, NULL); R_useDynamicSymbols(dll, FALSE); R_forceSymbols(dll, TRUE); } lobstr/src/Makevars0000644000176200001440000000003315143621142014035 0ustar liggesusers PKG_CPPFLAGS = -I./rlang lobstr/src/rlang/0000755000176200001440000000000015164116517013460 5ustar liggesuserslobstr/src/rlang/obj.h0000644000176200001440000000502015163457235014404 0ustar liggesusers// IWYU pragma: private; include "rlang.h" #ifndef RLANG_OBJ_H #define RLANG_OBJ_H #include #include "rlang-types.h" #define r_missing_arg R_MissingArg static inline r_ssize r_length(r_obj* x) { return Rf_xlength(x); } static inline enum r_type r_typeof(r_obj* x) { return (enum r_type) TYPEOF(x); } void _r_preserve(r_obj* x); void _r_unpreserve(r_obj* x); static r_unused r_obj* _r_placeholder = NULL; #define r_preserve(X) \ (R_PreserveObject(_r_placeholder = X), \ (_r_preserve)(_r_placeholder), \ (void) NULL) #define r_unpreserve(X) \ (R_ReleaseObject(_r_placeholder = X), \ (_r_unpreserve)(_r_placeholder), \ (void) NULL) static inline void r_mark_shared(r_obj* x) { MARK_NOT_MUTABLE(x); } static inline bool r_is_shared(r_obj* x) { return MAYBE_REFERENCED(x); } static inline void _r_preserve_global(r_obj* x) { (_r_preserve)(x); r_mark_shared(x); } #define r_preserve_global(X) \ (R_PreserveObject(_r_placeholder = X), \ (_r_preserve_global)(_r_placeholder), \ (void) NULL) static inline bool r_is_object(r_obj* x) { return Rf_isObject(x); } static inline bool r_inherits(r_obj* x, const char* tag) { return Rf_inherits(x, tag); } static inline r_obj* r_copy(r_obj* x) { return Rf_duplicate(x); } static inline r_obj* r_clone(r_obj* x) { return Rf_shallow_duplicate(x); } // These also clone names r_obj* r_vec_clone(r_obj* x); r_obj* r_vec_clone_shared(r_obj* x); static inline r_obj* r_type_as_string(enum r_type type) { return Rf_type2str(type); } static inline r_obj* r_type_as_character(enum r_type type) { r_obj* str = KEEP(r_type_as_string(type)); r_obj* out = Rf_ScalarString(str); return FREE(1), out; } static inline const char* r_type_as_c_string(enum r_type type) { return CHAR(Rf_type2str(type)); } static inline enum r_type r_c_str_as_r_type(const char* type) { return (enum r_type) Rf_str2type(type); } enum r_type r_chr_as_r_type(r_obj* type); static inline bool r_is_symbolic(r_obj* x) { return r_typeof(x) == LANGSXP || r_typeof(x) == SYMSXP; } static inline void r_obj_print(r_obj* x) { Rf_PrintValue(x); } static inline bool r_is_identical(r_obj* x, r_obj* y) { // 16 corresponds to base::identical()'s defaults // Do we need less conservative versions? return R_compute_identical(x, y, 16); } r_obj* r_obj_address(r_obj* x); extern r_obj* (*r_obj_encode_utf8)(r_obj* x); r_obj* r_as_label(r_obj* x); #endif lobstr/src/rlang/dyn-array.h0000644000176200001440000001267215163457235015553 0ustar liggesusers// IWYU pragma: private; include "rlang.h" #ifndef RLANG_DYN_ARRAY_H #define RLANG_DYN_ARRAY_H #include "rlang-types.h" #include "c-utils.h" #include "cnd.h" #include "vec.h" struct r_dyn_array { r_obj* shelter; r_ssize count; r_ssize capacity; int growth_factor; r_obj* data; void* v_data; const void* v_data_const; // private: enum r_type type; r_ssize elt_byte_size; void (*barrier_set)(r_obj* x, r_ssize i, r_obj* value); }; struct r_dyn_array* r_new_dyn_vector(enum r_type type, r_ssize capacity); struct r_dyn_array* r_new_dyn_array(r_ssize elt_byte_size, r_ssize capacity); void r_dyn_resize(struct r_dyn_array* p_arr, r_ssize capacity); void r_dyn_push_back(struct r_dyn_array* p_arr, const void* p_elt); r_obj* r_dyn_unwrap(struct r_dyn_array* p_arr); static inline void* r_dyn_pointer(struct r_dyn_array* p_arr, r_ssize i) { if (p_arr->barrier_set) { r_abort("Can't take mutable pointer of barrier vector."); } r_ssize offset = i * p_arr->elt_byte_size; return ((unsigned char*) p_arr->v_data) + offset; } static inline void* r_dyn_begin(struct r_dyn_array* p_arr) { return r_dyn_pointer(p_arr, 0); } static inline void* r_dyn_last(struct r_dyn_array* p_arr) { return r_dyn_pointer(p_arr, p_arr->count - 1); } static inline void* r_dyn_end(struct r_dyn_array* p_arr) { return r_dyn_pointer(p_arr, p_arr->count); } static inline const void* r_dyn_cpointer(struct r_dyn_array* p_arr, r_ssize i) { r_ssize offset = i * p_arr->elt_byte_size; return ((const unsigned char*) p_arr->v_data_const) + offset; } static inline const void* r_dyn_cbegin(struct r_dyn_array* p_arr) { return r_dyn_cpointer(p_arr, 0); } static inline const void* r_dyn_clast(struct r_dyn_array* p_arr) { return r_dyn_cpointer(p_arr, p_arr->count - 1); } static inline const void* r_dyn_cend(struct r_dyn_array* p_arr) { return r_dyn_cpointer(p_arr, p_arr->count); } #define R_DYN_GET(TYPE, X, I) (*((TYPE*) r_dyn_pointer((X), (I)))) #define R_DYN_POKE(TYPE, X, I, VAL) (*((TYPE*) r_dyn_pointer((X), (I))) = (VAL)) static inline int r_dyn_lgl_get(struct r_dyn_array* p_vec, r_ssize i) { return ((const int*) p_vec->v_data_const)[i]; } static inline int r_dyn_int_get(struct r_dyn_array* p_vec, r_ssize i) { return ((const int*) p_vec->v_data_const)[i]; } static inline double r_dyn_dbl_get(struct r_dyn_array* p_vec, r_ssize i) { return ((const double*) p_vec->v_data_const)[i]; } static inline r_complex r_dyn_cpl_get(struct r_dyn_array* p_vec, r_ssize i) { return ((const r_complex*) p_vec->v_data_const)[i]; } static inline char r_dyn_raw_get(struct r_dyn_array* p_vec, r_ssize i) { return ((const char*) p_vec->v_data_const)[i]; } static inline r_obj* r_dyn_chr_get(struct r_dyn_array* p_vec, r_ssize i) { return ((r_obj* const *) p_vec->v_data_const)[i]; } static inline r_obj* r_dyn_list_get(struct r_dyn_array* p_vec, r_ssize i) { return ((r_obj* const *) p_vec->v_data_const)[i]; } static inline void r_dyn_lgl_poke(struct r_dyn_array* p_vec, r_ssize i, int value) { ((int*) p_vec->v_data)[i] = value; } static inline void r_dyn_int_poke(struct r_dyn_array* p_vec, r_ssize i, int value) { ((int*) p_vec->v_data)[i] = value; } static inline void r_dyn_dbl_poke(struct r_dyn_array* p_vec, r_ssize i, double value) { ((double*) p_vec->v_data)[i] = value; } static inline void r_dyn_cpl_poke(struct r_dyn_array* p_vec, r_ssize i, r_complex value) { ((r_complex*) p_vec->v_data)[i] = value; } static inline void r_dyn_raw_poke(struct r_dyn_array* p_vec, r_ssize i, char value) { ((char*) p_vec->v_data)[i] = value; } static inline void r_dyn_chr_poke(struct r_dyn_array* p_vec, r_ssize i, r_obj* value) { r_chr_poke(p_vec->data, i, value); } static inline void r_dyn_list_poke(struct r_dyn_array* p_vec, r_ssize i, r_obj* value) { r_list_poke(p_vec->data, i, value); } static inline void* const * r_dyn_pop_back(struct r_dyn_array* p_arr) { void* const * out = (void* const *) r_dyn_clast(p_arr); --p_arr->count; return out; } static inline r_ssize r__dyn_increment(struct r_dyn_array* p_arr) { r_ssize loc = p_arr->count++; if (p_arr->count > p_arr->capacity) { r_ssize new_capacity = r_ssize_mult(p_arr->capacity, p_arr->growth_factor); r_dyn_resize(p_arr, new_capacity); } return loc; } static inline void r_dyn_lgl_push_back(struct r_dyn_array* p_vec, int elt) { r_ssize loc = r__dyn_increment(p_vec); r_dyn_lgl_poke(p_vec, loc, elt); } static inline void r_dyn_int_push_back(struct r_dyn_array* p_vec, int elt) { r_ssize loc = r__dyn_increment(p_vec); r_dyn_int_poke(p_vec, loc, elt); } static inline void r_dyn_dbl_push_back(struct r_dyn_array* p_vec, double elt) { r_ssize loc = r__dyn_increment(p_vec); r_dyn_dbl_poke(p_vec, loc, elt); } static inline void r_dyn_cpl_push_back(struct r_dyn_array* p_vec, r_complex elt) { r_ssize loc = r__dyn_increment(p_vec); r_dyn_cpl_poke(p_vec, loc, elt); } static inline void r_dyn_raw_push_back(struct r_dyn_array* p_vec, char elt) { r_ssize loc = r__dyn_increment(p_vec); r_dyn_raw_poke(p_vec, loc, elt); } static inline void r_dyn_chr_push_back(struct r_dyn_array* p_vec, r_obj* elt) { KEEP(elt); r_ssize loc = r__dyn_increment(p_vec); r_dyn_chr_poke(p_vec, loc, elt); FREE(1); } static inline void r_dyn_list_push_back(struct r_dyn_array* p_vec, r_obj* elt) { KEEP(elt); r_ssize loc = r__dyn_increment(p_vec); r_dyn_list_poke(p_vec, loc, elt); FREE(1); } #endif lobstr/src/rlang/debug.c0000644000176200001440000000120415163457235014713 0ustar liggesusers#include "rlang.h" void r_sexp_inspect(r_obj* x) { r_obj* call = KEEP(r_parse(".Internal(inspect(x))")); r_eval_with_x(call, x, r_envs.base); FREE(1); } void r_browse(r_obj* x) { r_env_bind(r_envs.global, r_sym(".debug"), x); r_printf("Object saved in `.debug`:\n"); r_obj_print(x); r_obj* frame = KEEP(r_peek_frame()); r_browse_at(frame); FREE(1); } void r_browse_at(r_obj* env) { // The NULL expression is needed because of a limitation in ESS r_parse_eval("{ browser(); NULL }", env); } void r_dbg_str(r_obj* x) { r_obj* call = KEEP(r_parse("str(x)")); r_eval_with_x(call, x, r_ns_env("utils")); FREE(1); } lobstr/src/rlang/arg.h0000644000176200001440000000045715163457235014414 0ustar liggesusers// 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 lobstr/src/rlang/vec-chr.h0000644000176200001440000000355115163457235015170 0ustar liggesusers// IWYU pragma: private; include "rlang.h" #ifndef RLANG_VECTOR_CHR_H #define RLANG_VECTOR_CHR_H #include "globals.h" #include "rlang-types.h" static inline const char* r_str_c_string(r_obj* str) { return CHAR(str); } bool r_chr_has(r_obj* chr, const char* c_string); bool r_chr_has_any(r_obj* chr, const char** c_strings); r_ssize r_chr_detect_index(r_obj* chr, const char* c_string); void r_chr_fill(r_obj* chr, r_obj* value, r_ssize n); static inline r_obj* r_str_as_character(r_obj* x) { return Rf_ScalarString(x); } /* * A symbol is always in the native encoding. This means that UTF-8 * data frame names undergo a lossy translation when they are * transformed to symbols to create a data mask. To deal with this, we * translate all serialised unicode tags back to UTF-8. This way the * UTF-8 -> native -> UTF-8 translation that occurs during the * character -> symbol -> character conversion fundamental for data * masking is transparent and lossless for the end user. * * Starting from R 4.0, `installChar()` warns when translation to * native encoding is lossy. This warning is disruptive for us since * we correctly translate strings behind the scene. To work around * this, we call `translateChar()` which doesn't warn (at least * currently). If the pointers are the same, no translation is * needed and we can call `installChar()`, which preserves the * current encoding of the string. Otherwise we intern the symbol * with `install()` without encoding. */ static inline r_obj* r_str_as_symbol(r_obj* str) { const char* str_native = Rf_translateChar(str); if (str_native == CHAR(str)) { return Rf_installChar(str); } else { return Rf_install(str_native); } } static inline bool r_str_is_name(r_obj* str) { if (str == r_globals.na_str) { return false; } if (str == r_strs.empty) { return false; } return true; } #endif lobstr/src/rlang/arg.c0000644000176200001440000000051715163457235014404 0ustar liggesusers#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"); } lobstr/src/rlang/rlang.h0000644000176200001440000000400315163457235014735 0ustar liggesusers#ifndef RLANG_RLANG_H #define RLANG_RLANG_H /* * `_ISOC99_SOURCE` is defined to avoid warnings on Windows UCRT builds where * usage of `PRIx64` in Microsoft's `printf()` can generate the warnings shown * below. Defining this before including `` forces usage of MinGW's * custom `printf()`, which is C99 compliant. * warning: unknown conversion type character 'l' in format [-Wformat] * warning: too many arguments for format [-Wformat-extra-args] * * The conventional define for this is `__USE_MINGW_ANSI_STDIO`, but according * to the thread below it is recommended to instead use a feature test macro * (such as `_ISOC99_SOURCE`) which will indirectly define the internal * `__USE_MINGW_ANSI_STDIO` macro for us. * https://osdn.net/projects/mingw/lists/archive/users/2019-January/000199.html */ #ifndef _ISOC99_SOURCE #define _ISOC99_SOURCE #endif #define R_NO_REMAP #include // IWYU pragma: export #include // IWYU pragma: export #include // IWYU pragma: export #include "rlang-types.h" // IWYU pragma: export r_obj* r_init_library(r_obj* ns); r_ssize r_arg_as_ssize(r_obj* n, const char* arg); static inline r_ssize r_as_ssize(r_obj* n) { return r_arg_as_ssize(n, "n"); } extern bool _r_use_local_precious_list; // IWYU pragma: begin_exports #include "obj.h" #include "globals.h" #include "arg.h" #include "attrib.h" #include "debug.h" #include "c-utils.h" #include "call.h" #include "cnd.h" #include "dict.h" #include "df.h" #include "dyn-array.h" #include "dyn-list-of.h" #include "dots-info.h" #include "env.h" #include "env-binding.h" #include "eval.h" #include "export.h" #include "fn.h" #include "formula.h" #include "node.h" #include "parse.h" #include "quo.h" #include "session.h" #include "stack.h" #include "state.h" #include "sym.h" #include "vec.h" #include "vec-chr.h" #include "vec-lgl.h" #include "vendor.h" #include "walk.h" // IWYU pragma: end_exports #define r_abort_lazy_call(LAZY, ...) \ r_abort_call(KEEP(r_lazy_eval(LAZY)), __VA_ARGS__) #endif lobstr/src/rlang/parse.c0000644000176200001440000000132515163457235014743 0ustar liggesusers#include "rlang.h" #include static void abort_parse(r_obj* code, const char* why) { if (r_peek_option("rlang__verbose_errors") != r_null) { r_obj_print(code); } r_abort("Internal error: %s", why); } r_obj* r_parse(const char* str) { r_obj* str_ = KEEP(r_chr(str)); ParseStatus status; r_obj* out = KEEP(R_ParseVector(str_, -1, &status, r_null)); if (status != PARSE_OK) { abort_parse(str_, "Parsing failed"); } if (r_length(out) != 1) { abort_parse(str_, "Expected a single expression"); } out = r_list_get(out, 0); FREE(2); return out; } r_obj* r_parse_eval(const char* str, r_obj* env) { r_obj* out = r_eval(KEEP(r_parse(str)), env); FREE(1); return out; } lobstr/src/rlang/dyn-list-of.c0000644000176200001440000001562615163457235016007 0ustar liggesusers#include #include "decl/dyn-list-of-decl.h" #define R_DYN_LOF_GROWTH_FACTOR 2 #define R_DYN_LOF_INIT_SIZE 32 enum shelter_dyn_list_of { SHELTER_DYN_LOF_raw, SHELTER_DYN_LOF_reserve, SHELTER_DYN_LOF_arr_locs, SHELTER_DYN_LOF_extra_array, SHELTER_DYN_LOF_extra_shelter_array, SHELTER_DYN_LOF_moved_arr, SHELTER_DYN_LOF_moved_shelter_arr, SHELTER_DYN_LOF_arrays, SHELTER_DYN_LOF_SIZE }; struct r_dyn_list_of* r_new_dyn_list_of(enum r_type type, r_ssize capacity, r_ssize width) { switch (type) { case R_TYPE_character: case R_TYPE_list: r_abort("Can't create a dynamic list of barrier vectors."); default: break; } r_obj* shelter = KEEP(r_alloc_list(SHELTER_DYN_LOF_SIZE)); r_obj* lof_raw = r_alloc_raw(sizeof(struct r_dyn_list_of)); r_list_poke(shelter, SHELTER_DYN_LOF_raw, lof_raw); struct r_dyn_array* p_moved_arr = r_new_dyn_array(sizeof(struct r_dyn_array*), R_DYN_LOF_INIT_SIZE); r_list_poke(shelter, SHELTER_DYN_LOF_moved_arr, p_moved_arr->shelter); struct r_dyn_array* p_moved_shelter_arr = r_new_dyn_vector(R_TYPE_list, R_DYN_LOF_INIT_SIZE); r_list_poke(shelter, SHELTER_DYN_LOF_moved_shelter_arr, p_moved_shelter_arr->shelter); r_obj* reserve = r_alloc_vector(type, r_ssize_mult(capacity, width)); r_list_poke(shelter, SHELTER_DYN_LOF_reserve, reserve); void* v_reserve = r_vec_begin(reserve); r_obj* arr_locs = r_alloc_raw(sizeof(r_ssize) * capacity); r_list_poke(shelter, SHELTER_DYN_LOF_arr_locs, arr_locs); r_ssize* v_arr_locs = r_raw_begin(arr_locs); R_MEM_SET(r_ssize, v_arr_locs, -1, capacity); struct r_dyn_array* p_arrays = r_new_dyn_array(sizeof(struct r_pair_ptr_ssize), capacity); r_list_poke(shelter, SHELTER_DYN_LOF_arrays, p_arrays->shelter); struct r_dyn_list_of* p_lof = r_raw_begin(lof_raw); *p_lof = (struct r_dyn_list_of) { .shelter = shelter, .count = 0, .capacity = capacity, .growth_factor = R_DYN_LOF_GROWTH_FACTOR, .v_data = r_dyn_begin(p_arrays), // private: .width = width, .type = type, .elt_byte_size = r_vec_elt_sizeof0(type), .reserve = reserve, .v_reserve = v_reserve, .p_moved_arr = p_moved_arr, .p_moved_shelter_arr = p_moved_shelter_arr, .arr_locs = arr_locs, .v_arr_locs = v_arr_locs, .p_arrays = p_arrays, }; FREE(1); return p_lof; } r_obj* r_lof_unwrap(struct r_dyn_list_of* p_lof) { r_obj* out = KEEP(r_alloc_list(p_lof->count)); enum r_type type = p_lof->type; r_ssize n = p_lof->count; struct r_pair_ptr_ssize* v_arrays = r_dyn_begin(p_lof->p_arrays); for (r_ssize i = 0; i < n; ++i) { struct r_pair_ptr_ssize array = v_arrays[i]; r_list_poke(out, i, r_vec_n(type, array.ptr, array.size)); } FREE(1); return out; } static void r_lof_resize(struct r_dyn_list_of* p_lof, r_ssize capacity) { r_ssize count = p_lof->count; // Resize reserve r_obj* reserve = r_vec_resize0(p_lof->type, p_lof->reserve, r_ssize_mult(capacity, p_lof->width)); r_list_poke(p_lof->shelter, SHELTER_DYN_LOF_reserve, reserve); p_lof->reserve = reserve; p_lof->v_reserve = r_vec_begin0(p_lof->type, reserve); p_lof->capacity = capacity; // Resize array indirections r_obj* arr_locs = r_raw_resize(p_lof->arr_locs, r_ssize_mult(sizeof(r_ssize), capacity)); r_list_poke(p_lof->shelter, SHELTER_DYN_LOF_arr_locs, arr_locs); r_ssize* v_arr_locs = r_raw_begin(arr_locs); r_ssize n_new = capacity - count; R_MEM_SET(r_ssize, v_arr_locs + count, -1, n_new); p_lof->arr_locs = arr_locs; p_lof->v_arr_locs = v_arr_locs; // Resize addresses and update them to point to the new memory r_dyn_resize(p_lof->p_arrays, capacity); struct r_pair_ptr_ssize* v_data = r_dyn_begin(p_lof->p_arrays); p_lof->v_data = v_data; unsigned char* v_reserve_u = (unsigned char*) p_lof->v_reserve; r_ssize bytes = p_lof->width * p_lof->elt_byte_size; for (r_ssize i = 0; i < count; ++i) { // Preserve addresses of moved arrays if (v_arr_locs[i] < 0) { r_ssize offset = i * bytes; v_data[i].ptr = v_reserve_u + offset; } } } void r_lof_push_back(struct r_dyn_list_of* p_lof) { r_ssize count = p_lof->count + 1; if (count > p_lof->capacity) { r_ssize new_size = r_ssize_mult(p_lof->capacity, R_DYN_LOF_GROWTH_FACTOR); r_lof_resize(p_lof, new_size); } p_lof->count = count; unsigned char* v_reserve_u = (unsigned char*) p_lof->v_reserve; r_ssize offset = (count - 1) * p_lof->width * p_lof->elt_byte_size; struct r_pair_ptr_ssize info = { .ptr = v_reserve_u + offset, .size = 0 }; r_dyn_push_back(p_lof->p_arrays, &info); } void r_lof_arr_push_back(struct r_dyn_list_of* p_lof, r_ssize i, void* p_elt) { if (i >= p_lof->count) { r_stop_internal("Location %d does not exist.", i); } if (reserve_push_back(p_lof, i, p_elt)) { return; } struct r_dyn_array* p_arr = p_lof->p_moved_arr; r_ssize arr_i = p_lof->v_arr_locs[i]; if (arr_i >= p_arr->count) { r_stop_internal("Location %d does not exist in the extra array", arr_i); } struct r_dyn_array* p_inner_arr = R_DYN_GET(struct r_dyn_array*, p_arr, arr_i); r_dyn_push_back(p_inner_arr, p_elt); // Also update pointer in case of resize R_DYN_POKE(struct r_pair_ptr_ssize, p_lof->p_arrays, i, ((struct r_pair_ptr_ssize) { .ptr = r_dyn_begin(p_inner_arr), .size = p_inner_arr->count })); } static bool reserve_push_back(struct r_dyn_list_of* p_lof, r_ssize i, void* p_elt) { if (p_lof->v_arr_locs[i] >= 0) { return false; } struct r_pair_ptr_ssize* p_arr_info = r_dyn_pointer(p_lof->p_arrays, i); if (p_arr_info->size >= p_lof->width) { // Inner array is getting too big for the reserve. Move it to a // dynamic array. reserve_move(p_lof, i, p_elt); return false; } r_ssize count = ++p_arr_info->size; r_ssize offset = (i * p_lof->width + count - 1) * p_lof->elt_byte_size; void* p = ((unsigned char*) p_lof->v_reserve) + offset; if (p_elt) { r_memcpy(p, p_elt, p_lof->elt_byte_size); } else { r_memset(p, 0, p_lof->elt_byte_size); } return true; } static void reserve_move(struct r_dyn_list_of* p_lof, r_ssize i, void* p_elt) { struct r_dyn_array* p_moved_arr = p_lof->p_moved_arr; r_ssize n = p_lof->width; struct r_dyn_array* p_new = r_new_dyn_vector(p_lof->type, p_lof->width); r_dyn_list_push_back(p_lof->p_moved_shelter_arr, p_new->shelter); r_dyn_push_back(p_moved_arr, &p_new); void* v_new = r_dyn_begin(p_new); void* v_old = R_DYN_GET(struct r_pair_ptr_ssize, p_lof->p_arrays, i).ptr; r_memcpy(v_new, v_old, r_ssize_mult(n, p_lof->elt_byte_size)); p_new->count = n; R_DYN_POKE(struct r_pair_ptr_ssize, p_lof->p_arrays, i, ((struct r_pair_ptr_ssize) { .ptr = v_new, .size = n })); p_lof->v_arr_locs[i] = p_moved_arr->count - 1; } lobstr/src/rlang/node.h0000644000176200001440000000427415163457235014571 0ustar liggesusers// IWYU pragma: private; include "rlang.h" #ifndef RLANG_NODE_H #define RLANG_NODE_H #include "rlang-types.h" static inline r_obj* r_node_car(r_obj* x) { return CAR(x); } static inline r_obj* r_node_cdr(r_obj* x) { return CDR(x); } static inline r_obj* r_node_tag(r_obj* x) { return TAG(x); } static inline r_obj* r_node_caar(r_obj* x) { return CAAR(x); } static inline r_obj* r_node_cadr(r_obj* x) { return CADR(x); } static inline r_obj* r_node_cdar(r_obj* x) { return CDAR(x); } static inline r_obj* r_node_cddr(r_obj* x) { return CDDR(x); } static inline void r_node_poke_car(r_obj* x, r_obj* newcar) { SETCAR(x, newcar); } static inline void r_node_poke_cdr(r_obj* x, r_obj* newcdr) { SETCDR(x, newcdr); } static inline void r_node_poke_tag(r_obj* x, r_obj* tag) { SET_TAG(x, tag); } static inline void r_node_poke_caar(r_obj* x, r_obj* newcaar) { SETCAR(CAR(x), newcaar); } static inline void r_node_poke_cadr(r_obj* x, r_obj* newcar) { SETCADR(x, newcar); } static inline void r_node_poke_cdar(r_obj* x, r_obj* newcdar) { SETCDR(CAR(x), newcdar); } static inline void r_node_poke_cddr(r_obj* x, r_obj* newcdr) { SETCDR(CDR(x), newcdr); } static inline r_obj* r_new_node(r_obj* car, r_obj* cdr) { return Rf_cons(car, cdr); } static inline r_obj* r_new_node3(r_obj* car, r_obj* cdr, r_obj* tag) { r_obj* out = Rf_cons(car, cdr); SET_TAG(out, tag); return out; } r_obj* r_new_pairlist(const struct r_pair* args, int n, r_obj** tail); #define r_pairlist Rf_list1 #define r_pairlist2 Rf_list2 #define r_pairlist3 Rf_list3 #define r_pairlist4 Rf_list4 #define r_pairlist5 Rf_list5 r_obj* r_pairlist_rev(r_obj* node); // Used by `r_attrib_get()` via `r_pairlist_get()`, // so we want it to be fully inlined static inline r_obj* r_pairlist_find(r_obj* node, r_obj* tag) { while (node != r_null) { if (r_node_tag(node) == tag) { return node; } node = r_node_cdr(node); } return r_null; } static inline r_obj* r_pairlist_get(r_obj* node, r_obj* tag) { return r_node_car(r_pairlist_find(node, tag)); } static inline r_obj* r_pairlist_tail(r_obj* x) { r_obj* cdr = r_null; while ((cdr = r_node_cdr(x)) != r_null) { x = cdr; } return x; } r_obj* r_node_tree_clone(r_obj* x); #endif lobstr/src/rlang/cpp/0000755000176200001440000000000015163457235014246 5ustar liggesuserslobstr/src/rlang/cpp/rlang.cpp0000644000176200001440000000002315163457235016050 0ustar liggesusers#include "vec.cpp" lobstr/src/rlang/cpp/vec.cpp0000644000176200001440000000073115163457235015530 0ustar liggesusers#include #include extern "C" { int* r_int_unique0(int* v_data, r_ssize size) { try { return std::unique(v_data, v_data + size); } catch (...) { rcc_abort("r_int_unique0"); } } bool r_list_all_of0(r_obj* const * v_first, r_ssize size, bool (*predicate)(r_obj* x)) { try { return std::all_of(v_first, v_first + size, predicate); } catch (...) { rcc_abort("r_list_all_of"); } } } lobstr/src/rlang/call.h0000644000176200001440000000067215163457235014555 0ustar liggesusers// IWYU pragma: private; include "rlang.h" #ifndef RLANG_LANG_H #define RLANG_LANG_H #include "rlang-types.h" #define r_new_call Rf_lcons #define r_call Rf_lang1 #define r_call2 Rf_lang2 #define r_call3 Rf_lang3 #define r_call4 Rf_lang4 #define r_call5 Rf_lang5 bool r_is_call(r_obj* x, const char* name); bool r_is_call_any(r_obj* x, const char** names, int n); r_obj* r_expr_protect(r_obj* x); r_obj* r_call_clone(r_obj* x); #endif lobstr/src/rlang/fn.c0000644000176200001440000000161415163457235014235 0ustar liggesusers#include "rlang.h" r_obj* rlang_formula_formals = NULL; r_obj* r_as_function(r_obj* x, const char* arg) { switch (r_typeof(x)) { case R_TYPE_closure: case R_TYPE_builtin: case R_TYPE_special: return x; case R_TYPE_call: if (r_node_car(x) == r_syms.tilde && r_node_cddr(x) == r_null) { r_obj* env = r_attrib_get(x, r_syms.dot_environment); if (env == r_null) { r_abort("Can't transform formula to function because it doesn't have an environment."); } return r_new_function(rlang_formula_formals, r_node_cadr(x), env); } // else fallthrough; default: r_abort("Can't convert `%s` to a function", arg); } } void r_init_library_fn(void) { const char* formals_code = "formals(function(..., .x = ..1, .y = ..2, . = ..1) NULL)"; rlang_formula_formals = r_parse_eval(formals_code, r_envs.base); r_preserve_global(rlang_formula_formals); } lobstr/src/rlang/formula.c0000644000176200001440000000343415163457235015301 0ustar liggesusers#include "rlang.h" r_obj* r_f_rhs(r_obj* f) { if (r_typeof(f) != LANGSXP) { r_abort("`x` must be a formula"); } switch (r_length(f)) { case 2: return r_node_cadr(f); case 3: return CADDR(f); default: r_abort("Invalid formula"); } } r_obj* r_f_lhs(r_obj* f) { if (r_typeof(f) != LANGSXP) { r_abort("`x` must be a formula"); } switch (r_length(f)) { case 2: return r_null; case 3: return r_node_cadr(f); default: r_abort("Invalid formula"); } } r_obj* r_f_env(r_obj* f) { return r_attrib_get(f, r_sym(".Environment")); } bool r_f_has_env(r_obj* f) { return r_is_environment(r_f_env(f)); } bool r_is_formula(r_obj* x, int scoped, int lhs) { if (r_typeof(x) != R_TYPE_call) { return false; } if (r_node_car(x) != r_syms.tilde) { return false; } if (scoped >= 0) { bool has_env = r_typeof(r_f_env(x)) == R_TYPE_environment; bool has_class = r_inherits(x, "formula"); if (scoped != (has_env && has_class)) { return false; } } if (lhs >= 0) { int has_lhs = r_length(x) > 2; if (lhs != has_lhs) { return false; } } return true; } r_obj* new_raw_formula(r_obj* lhs, r_obj* rhs, r_obj* env) { static r_obj* tilde_sym = NULL; if (!tilde_sym) { tilde_sym = r_sym("~"); } if (!r_is_environment(env) && env != r_null) { r_abort("`env` must be an environment"); } r_obj* f; r_obj* args; if (lhs == r_null) { args = KEEP(r_pairlist(rhs)); } else { args = KEEP(r_pairlist2(lhs, rhs)); } f = KEEP(r_new_call(tilde_sym, args)); r_attrib_poke(f, r_sym(".Environment"), env); FREE(2); return f; } r_obj* r_new_formula(r_obj* lhs, r_obj* rhs, r_obj* env) { r_obj* f = KEEP(new_raw_formula(lhs, rhs, env)); r_attrib_poke_class(f, r_chr("formula")); FREE(1); return f; } lobstr/src/rlang/globals.c0000644000176200001440000000635615163457235015265 0ustar liggesusers#include "rlang-types.h" #include "sym.h" struct r_globals r_globals; struct r_globals_chrs r_chrs; struct r_globals_classes r_classes; struct r_globals_strs r_strs; struct r_globals_syms r_syms; struct r_globals_envs r_envs; r_obj* r_true = NULL; r_obj* r_false = NULL; void r_init_library_globals(r_obj* ns) { r_preserve_global(r_classes.data_frame = r_chr("data.frame")); const char* v_tibble_class[] = { "tbl_df", "tbl", "data.frame" }; r_preserve_global(r_globals.empty_lgl = r_alloc_logical(0)); r_preserve_global(r_globals.empty_int = r_alloc_integer(0)); r_preserve_global(r_globals.empty_dbl = r_alloc_double(0)); r_preserve_global(r_globals.empty_cpl = r_alloc_complex(0)); r_preserve_global(r_globals.empty_raw = r_alloc_raw(0)); r_preserve_global(r_globals.empty_chr = r_alloc_character(0)); r_preserve_global(r_globals.empty_list = r_alloc_list(0)); r_globals.na_lgl = NA_LOGICAL; r_globals.na_int = NA_INTEGER; r_globals.na_dbl = NA_REAL; r_globals.na_cpl = (r_complex) { .r = NA_REAL, .i = NA_REAL }; r_globals.na_str = NA_STRING; r_preserve_global(r_chrs.empty_string = r_chr("")); r_preserve_global(r_chrs.full = r_chr("full")); r_classes.tibble = r_chr_n(v_tibble_class, R_ARR_SIZEOF(v_tibble_class)); r_preserve_global(r_classes.tibble); r_strs.dots = r_sym_string(r_syms.dots); r_strs.condition = r_sym_string(r_syms.condition); r_strs.empty = r_chr_get(r_chrs.empty_string, 0); r_strs.error = r_sym_string(r_syms.error); r_strs.interrupt = r_sym_string(r_syms.interrupt); r_strs.na = r_globals.na_str; r_strs.message = r_sym_string(r_syms.message); r_strs.warning = r_sym_string(r_syms.warning); r_preserve_global(r_false = r_lgl(0)); r_preserve_global(r_true = r_lgl(1)); r_envs.empty = R_EmptyEnv; r_envs.base = R_BaseEnv; r_envs.global = R_GlobalEnv; r_envs.ns = ns; } void r_init_library_globals_syms(void) { r_syms.abort = r_sym("abort"); r_syms.arg = r_sym("arg"); r_syms.brace = R_BraceSymbol; r_syms.brackets = R_BracketSymbol; r_syms.brackets2 = R_Bracket2Symbol; r_syms.call = r_sym("call"); r_syms.class_ = R_ClassSymbol; r_syms.colon2 = R_DoubleColonSymbol; r_syms.colon3 = R_TripleColonSymbol; r_syms.condition = r_sym("condition"); r_syms.dots = R_DotsSymbol; r_syms.error = r_sym("error"); r_syms.error_arg = r_sym("error_arg"); r_syms.error_call = r_sym("error_call"); r_syms.error_call_flag = r_sym(".__error_call__."); r_syms.expr = r_sym("expr"); r_syms.interrupt = r_sym("interrupt"); r_syms.missing = R_MissingArg; r_syms.message = r_sym("message"); r_syms.names = R_NamesSymbol; r_syms.options = r_sym("options"); r_syms.dim = R_DimSymbol; r_syms.dim_names = R_DimNamesSymbol; r_syms.row_names = R_RowNamesSymbol; r_syms.stack_overflow_error = r_sym("stackOverflowError"); r_syms.warning = r_sym("warning"); r_syms.dot_environment = r_sym(".Environment"); r_syms.dot_fn = r_sym(".fn"); r_syms.dot_x = r_sym(".x"); r_syms.dot_y = r_sym(".y"); r_syms.function = r_sym("function"); r_syms.srcfile = r_sym("srcfile"); r_syms.srcref = r_sym("srcref"); r_syms.tilde = r_sym("~"); r_syms.w = r_sym("w"); r_syms.wholeSrcref = r_sym("wholeSrcref"); r_syms.x = r_sym("x"); r_syms.y = r_sym("y"); r_syms.z = r_sym("z"); } lobstr/src/rlang/env.c0000644000176200001440000001551515163457235014427 0ustar liggesusers#include "rlang.h" #include "decl/env-decl.h" r_obj* rlang_ns_env; r_obj* r_ns_env(const char* pkg) { r_obj* pkg_str = KEEP(r_chr(pkg)); r_obj* ns = R_FindNamespace(pkg_str); FREE(1); return ns; } r_obj* r_base_ns_get(const char* name) { return r_env_get(r_envs.base, r_sym(name)); } r_obj* rlang_ns_get(const char* name) { return r_env_get(rlang_ns_env, r_sym(name)); } r_obj* r_alloc_environment(r_ssize size, r_obj* parent) { #if R_VERSION < R_Version(4, 1, 0) parent = parent ? parent : r_envs.empty; r_node_poke_car(new_env__parent_node, parent); size = size ? size : 29; r_node_poke_car(new_env__size_node, r_int(size)); r_obj* env = r_eval(new_env_call, r_envs.base); // Free for gc r_node_poke_car(new_env__parent_node, r_null); return env; #else const int hash = 1; return R_NewEnv(parent, hash, size); #endif } r_obj* r_env_as_list(r_obj* env) { return eval_with_x(env2list_call, env); } r_obj* r_env_clone(r_obj* env, r_obj* parent) { if (parent == NULL) { parent = r_env_parent(env); } // This better reproduces the behaviour of `list2env()` which in // turn affects how bindings are stored in the hash table and the // default sort of the character vector generated by `names()`. size_t size = R_MAX(r_length(env), 29); r_obj* out = KEEP(r_alloc_environment(size, parent)); r_env_coalesce(out, env); FREE(1); return out; } void r_env_coalesce(r_obj* env, r_obj* from) { r_obj* syms = KEEP(r_env_syms(from)); r_obj* types = KEEP(r_env_binding_types(from, syms)); if (types == r_null) { env_coalesce_plain(env, from, syms); FREE(2); return; } r_ssize n = r_length(syms); r_obj* const * v_syms = r_list_cbegin(syms); enum r_env_binding_type* v_types = (enum r_env_binding_type*) r_int_begin(types); for (r_ssize i = 0; i < n; ++i) { r_obj* sym = v_syms[i]; if (r_env_has(env, sym)) { continue; } switch (v_types[i]) { case R_ENV_BINDING_TYPE_unbound: break; case R_ENV_BINDING_TYPE_value: r_env_bind(env, sym, KEEP(r_env_get(from, sym))); FREE(1); break; case R_ENV_BINDING_TYPE_delayed: r_env_bind_delayed( env, sym, KEEP(r_env_binding_delayed_expr(from, sym)), KEEP(r_env_binding_delayed_env(from, sym)) ); FREE(2); break; case R_ENV_BINDING_TYPE_forced: r_env_bind_forced( env, sym, KEEP(r_env_binding_forced_expr(from, sym)), KEEP(r_env_get(from, sym)) ); FREE(2); break; case R_ENV_BINDING_TYPE_missing: r_env_bind_missing(env, sym); break; case R_ENV_BINDING_TYPE_active: r_env_bind_active(env, sym, KEEP(r_env_binding_active_fn(from, sym))); FREE(1); break; } } FREE(2); return; } static void env_coalesce_plain(r_obj* env, r_obj* from, r_obj* syms) { r_ssize n = r_length(syms); r_obj* const * v_syms = r_list_cbegin(syms); for (r_ssize i = 0; i < n; ++i) { r_obj* sym = v_syms[i]; if (r_env_has(env, sym)) { continue; } r_env_bind(env, sym, KEEP(r_env_get(from, sym))); FREE(1); } return; } r_obj* r_list_as_environment(r_obj* x, r_obj* parent) { parent = parent ? parent : r_envs.empty; return eval_with_xy(list2env_call, x, parent); } #if RLANG_USE_R_EXISTS bool r__env_has(r_obj* env, r_obj* sym) { // `exists("")` errors on older R if (sym == R_MissingArg) { return Rf_findVarInFrame3(env, sym, FALSE) != R_UnboundValue; } r_obj* nm = KEEP(r_sym_as_utf8_character(sym)); r_obj* out = eval_with_xyz(exists_call, env, nm, r_false); FREE(1); return r_as_bool(out); } bool r__env_has_anywhere(r_obj* env, r_obj* sym) { // `exists("")` errors on older R if (sym == R_MissingArg) { return Rf_findVar(sym, env) != R_UnboundValue; } r_obj* nm = KEEP(r_sym_as_utf8_character(sym)); r_obj* out = eval_with_xyz(exists_call, env, nm, r_true); FREE(1); return r_as_bool(out); } #endif bool r_env_inherits(r_obj* env, r_obj* ancestor, r_obj* top) { top = top ? top : r_envs.empty; if (r_typeof(env) != R_TYPE_environment) { r_abort("`env` must be an environment"); } if (r_typeof(ancestor) != R_TYPE_environment) { r_abort("`ancestor` must be an environment"); } if (r_typeof(top) != R_TYPE_environment) { r_abort("`top` must be an environment"); } if (env == r_envs.empty) { return false; } while (env != top && env != r_envs.empty) { if (env == ancestor) { return true; } env = r_env_parent(env); } return env == ancestor; } r_obj* r_env_until(r_obj* env, r_obj* sym, r_obj* last) { r_obj* stop = r_envs.empty; if (last != r_envs.empty) { stop = r_env_parent(last); } while (true) { if (env == r_envs.empty) { return r_envs.empty; } if (r_env_has(env, sym)) { return env; } r_obj* next = r_env_parent(env); if (next == r_envs.empty || next == stop) { return r_envs.empty; } env = next; } } r_obj* r_env_get_anywhere(r_obj* env, r_obj* sym) { env = r_env_until(env, sym, r_envs.empty); return r_env_get(env, sym); } r_obj* r_env_get_until(r_obj* env, r_obj* sym, r_obj* last) { env = r_env_until(env, sym, last); return r_env_get(env, sym); } bool r_env_has_until(r_obj* env, r_obj* sym, r_obj* last) { env = r_env_until(env, sym, last); return r_env_has(env, sym); } bool r_env_has_missing(r_obj* env, r_obj* sym) { // That's a special primitive so no need to protect `sym` r_obj* call = KEEP(r_call2(missing_prim, sym)); r_obj* out = r_eval(call, env); FREE(1); return r_as_bool(out); } void r_init_rlang_ns_env(void) { rlang_ns_env = r_ns_env("rlang"); } void r_init_library_env(void) { #if R_VERSION < R_Version(4, 1, 0) new_env_call = r_parse_eval("as.call(list(new.env, TRUE, NULL, NULL))", r_envs.base); r_preserve(new_env_call); new_env__parent_node = r_node_cddr(new_env_call); new_env__size_node = r_node_cdr(new_env__parent_node); #endif missing_prim = r_parse_eval("missing", r_envs.base); env2list_call = r_parse("as.list.environment(x, all.names = TRUE)"); r_preserve(env2list_call); list2env_call = r_parse("list2env(x, envir = NULL, parent = y, hash = TRUE)"); r_preserve(list2env_call); exists_call = r_parse("exists(y, envir = x, inherits = z)"); r_preserve(exists_call); remove_call = r_parse("remove(list = y, envir = x, inherits = z)"); r_preserve(remove_call); r_methods_ns_env = r_parse_eval("asNamespace('methods')", r_envs.base); } r_obj* rlang_ns_env = NULL; r_obj* r_methods_ns_env = NULL; #if R_VERSION < R_Version(4, 1, 0) static r_obj* new_env_call = NULL; static r_obj* new_env__parent_node = NULL; static r_obj* new_env__size_node = NULL; #endif static r_obj* exists_call = NULL; static r_obj* remove_call = NULL; static r_obj* env2list_call = NULL; static r_obj* list2env_call = NULL; static r_obj* missing_prim = NULL; lobstr/src/rlang/vec-lgl.h0000644000176200001440000000034315163457235015166 0ustar liggesusers// IWYU pragma: private; include "rlang.h" #ifndef RLANG_VECTOR_LGL_H #define RLANG_VECTOR_LGL_H #include "rlang-types.h" r_ssize r_lgl_sum(r_obj* x, bool na_true); r_obj* r_lgl_which(r_obj* x, bool na_propagate); #endif lobstr/src/rlang/c-utils.h0000644000176200001440000001077715163457235015231 0ustar liggesusers// IWYU pragma: private; include "rlang.h" #ifndef RLANG_C_UTILS_H #define RLANG_C_UTILS_H #include "rlang-types.h" #include #include #include #include #include "cnd.h" #define R_ARR_SIZEOF(X) sizeof(X) / sizeof(X[0]) #define R_MIN(a, b) ((a) < (b) ? (a) : (b)) #define R_MAX(a, b) ((a) > (b) ? (a) : (b)) // Like `memset()` with support for multi-byte types #define R_MEM_SET(TYPE, PTR, VALUE, N) do { \ TYPE* v = (PTR); \ TYPE value = (VALUE); \ size_t n = (N); \ for (size_t i = 0; i < n; ++i) { \ v[i] = value; \ } \ } while(0) void* r_shelter_deref(r_obj* x); // Allow integers up to 2^52, same as R_XLEN_T_MAX when long vector // support is enabled #define RLANG_MAX_DOUBLE_INT 4503599627370496 #define RLANG_MIN_DOUBLE_INT -4503599627370496 static inline bool r_dbl_is_whole(double x) { if (x > RLANG_MAX_DOUBLE_INT || x < RLANG_MIN_DOUBLE_INT) { return false; } // C99 guarantees existence of the int_least_N_t types, even on // machines that don't support arithmetic on width N: if (x != (int_least64_t) x) { return false; } return true; } // Adapted from CERT C coding standards static inline intmax_t r__intmax_add(intmax_t x, intmax_t y) { if ((y > 0 && x > (INTMAX_MAX - y)) || (y < 0 && x < (INTMAX_MIN - y))) { r_stop_internal("Values too large to be added."); } return x + y; } static inline intmax_t r__intmax_subtract(intmax_t x, intmax_t y) { if ((y > 0 && x < (INTMAX_MIN + y)) || (y < 0 && x > (INTMAX_MAX + y))) { r_stop_internal("Subtraction resulted in overflow or underflow."); } return x - y; } static inline r_ssize r_ssize_add(r_ssize x, r_ssize y) { intmax_t out = r__intmax_add(x, y); if (out > R_SSIZE_MAX) { r_stop_internal("Result too large for an `r_ssize`."); } return (r_ssize) out; } static inline r_ssize r_ssize_mult(r_ssize x, r_ssize y) { if (x > 0) { if (y > 0) { if (x > (R_SSIZE_MAX / y)) { goto error; } } else { if (y < (R_SSIZE_MIN / x)) { goto error; } } } else { if (y > 0) { if (x < (R_SSIZE_MIN / y)) { goto error; } } else { if ( (x != 0) && (y < (R_SSIZE_MAX / x))) { goto error; } } } return x * y; error: r_stop_internal("Result too large for an `r_ssize`."); } static inline int r_int_min(int x, int y) { return (y < x) ? y : x; } static inline int r_int_max(int x, int y) { return (y < x) ? x : y; } static inline r_ssize r_ssize_min(r_ssize x, r_ssize y) { return (y < x) ? y : x; } static inline r_ssize r_ssize_max(r_ssize x, r_ssize y) { return (y < x) ? x : y; } static inline int r_ssize_as_integer(r_ssize x) { if (x > INT_MAX || x < INT_MIN) { r_stop_internal("Result can't be represented as `int`."); } return (int) x; } static inline double r_ssize_as_double(r_ssize x) { if (x > DBL_MAX || x < -DBL_MAX) { r_stop_internal("Result can't be represented as `double`."); } return (double) x; } static inline r_ssize r_double_as_ssize(double x) { if (x > R_SSIZE_MAX || x < R_SSIZE_MIN) { r_stop_internal("Result can't be represented as `r_ssize`."); } return (r_ssize) x; } static inline double r_double_mult(double x, double y) { double out = x * y; if (!isfinite(out)) { r_stop_internal("Can't multiply double values."); } return out; } // Slightly safer version of `memcpy()` for use with R object memory // // Prefer this over `memcpy()`, especially when providing pointers to R object // memory. As of R 4.5.0, `DATAPTR()` and friends return `(void*) 1` on 0-length // R objects, so we must be extremely careful to never use dereference those // pointers. In particular, it is not safe to call `memcpy(dest, src, 0)` on // some machines (likely with sanitizers active) when either `dest` or `src` // resolve to `(void*) 1`. // // https://github.com/r-lib/vctrs/pull/1968 // https://github.com/r-devel/r-svn/blob/9976c3d7f08c754593d01ba8380afb6be803dde2/src/main/memory.c#L4137-L4150 static inline void r_memcpy(void* dest, const void* src, size_t count) { if (count) { memcpy(dest, src, count); } } // Slightly safer version of `memset()` for use with R object memory // // See `r_memcpy()` for rationale static inline void r_memset(void* dest, int value, size_t count) { if (count) { memset(dest, value, count); } } #endif lobstr/src/rlang/session.c0000644000176200001440000000276015163457235015320 0ustar liggesusers#include "rlang.h" r_obj* eval_with_x(r_obj* call, r_obj* x); static r_obj* is_installed_call = NULL; bool r_is_installed(const char* pkg) { r_obj* installed = eval_with_x(is_installed_call, KEEP(r_chr(pkg))); bool out = *r_lgl_begin(installed); FREE(1); return out; } static r_obj* has_colour_call = NULL; bool r_has_colour(void) { if (!r_is_installed("crayon")) { return false; } return *r_lgl_begin(r_eval(has_colour_call, r_envs.base)); } void r_init_library_session(void) { is_installed_call = r_parse("requireNamespace(x, quietly = TRUE)"); r_preserve(is_installed_call); has_colour_call = r_parse("crayon::has_color()"); r_preserve(has_colour_call); } #ifdef _WIN32 # include # include r_obj* r_getppid(void) { DWORD pid = GetCurrentProcessId(); HANDLE handle = NULL; PROCESSENTRY32W pe = { 0 }; pe.dwSize = sizeof(PROCESSENTRY32W); handle = CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0); if (handle == INVALID_HANDLE_VALUE) { r_abort("Can't query parent pid."); } if (Process32FirstW(handle, &pe)) { do { if (pe.th32ProcessID == pid) { DWORD ppid = pe.th32ParentProcessID; CloseHandle(handle); return r_int(ppid); } } while (Process32NextW(handle, &pe)); } /* Should not get here */ CloseHandle(handle); r_stop_internal("Can't find my own process."); return r_null; } #else # include r_obj* r_getppid(void) { return r_int(getppid()); } #endif lobstr/src/rlang/sym.c0000644000176200001440000000263115163457235014442 0ustar liggesusers#include #include "rlang.h" // In old R versions `as.name()` does not translate to native which // loses the encoding. This symbol constructor always translates. r_obj* r_new_symbol(r_obj* x, int* err) { switch (r_typeof(x)) { case SYMSXP: return x; case R_TYPE_character: if (r_length(x) == 1) { const char* string = Rf_translateChar(r_chr_get(x, 0)); return r_sym(string); } // else fallthrough default: { if (err) { *err = -1; return r_null; } else { const char* type = r_type_as_c_string(r_typeof(x)); r_abort("Can't create a symbol with a %s", type); } }} } bool r_is_symbol(r_obj* x, const char* string) { if (r_typeof(x) != SYMSXP) { return false; } else { return strcmp(CHAR(PRINTNAME(x)), string) == 0; } } bool r_is_symbol_any(r_obj* x, const char** strings, int n) { if (r_typeof(x) != SYMSXP) { return false; } const char* name = CHAR(PRINTNAME(x)); for (int i = 0; i < n; ++i) { if (strcmp(name, strings[i]) == 0) { return true; } } return false; } r_obj* (*r_sym_as_utf8_character)(r_obj* x) = NULL; r_obj* (*r_sym_as_utf8_string)(r_obj* x) = NULL; void r_init_library_sym(void) { r_sym_as_utf8_character = (r_obj* (*)(r_obj*)) r_peek_c_callable("rlang", "rlang_sym_as_character"); r_sym_as_utf8_string = (r_obj* (*)(r_obj*)) r_peek_c_callable("rlang", "rlang_sym_as_string"); } lobstr/src/rlang/vec-lgl.c0000644000176200001440000000556215163457235015171 0ustar liggesusers#include "rlang.h" #include r_ssize r_lgl_sum(r_obj* x, bool na_true) { if (r_typeof(x) != R_TYPE_logical) { r_abort("Internal error: Excepted logical vector in `r_lgl_sum()`"); } const r_ssize n = r_length(x); const int* v_x = r_lgl_cbegin(x); // This can't overflow since `sum` is necessarily smaller or equal // to the vector length expressed in `r_ssize` r_ssize sum = 0; if (na_true) { for (r_ssize i = 0; i < n; ++i) { sum += (bool) v_x[i]; } } else { for (r_ssize i = 0; i < n; ++i) { sum += (v_x[i] == 1); } } return sum; } r_obj* r_lgl_which(r_obj* x, bool na_propagate) { const enum r_type type = r_typeof(x); if (type != R_TYPE_logical) { r_stop_unexpected_type(type); } const r_ssize n = r_length(x); const int* v_x = r_lgl_cbegin(x); const r_ssize out_n = r_lgl_sum(x, na_propagate); if (out_n > INT_MAX) { r_stop_internal("Can't fit result in an integer vector."); } r_obj* out = KEEP(r_alloc_integer(out_n)); int* v_out = r_int_begin(out); r_obj* names = r_names(x); const bool has_names = (names != r_null); if (na_propagate) { if (has_names) { // Mark `NA` locations with negative location for extracting names later for (r_ssize i = 0, j = 0; i < n && j < out_n; ++i) { const int x_elt = v_x[i]; const bool missing = x_elt == r_globals.na_lgl; const int elt = missing * (-i - 1) + !missing * x_elt * (i + 1); v_out[j] = elt; j += (bool) elt; } } else { for (r_ssize i = 0, j = 0; i < n && j < out_n; ++i) { const int x_elt = v_x[i]; const bool missing = x_elt == r_globals.na_lgl; const int elt = missing * r_globals.na_int + !missing * x_elt * (i + 1); v_out[j] = elt; j += (bool) elt; } } } else { for (r_ssize i = 0, j = 0; i < n && j < out_n; ++i) { const int x_elt = v_x[i]; v_out[j] = i + 1; j += (x_elt == 1); } } if (has_names) { r_obj* const* v_names = r_chr_cbegin(names); r_obj* out_names = r_alloc_character(out_n); r_attrib_poke_names(out, out_names); if (na_propagate) { // `v_out` contains negative locations which tells you the location of the // name to extract while also serving as a signal of where `NA`s should go // in the finalized output for (r_ssize i = 0; i < out_n; ++i) { const int loc = v_out[i]; const int abs_loc = abs(loc); const bool same = (loc == abs_loc); v_out[i] = same * loc + !same * r_globals.na_int; r_chr_poke(out_names, i, v_names[abs_loc - 1]); } } else { // `v_out` doesn't contain `NA`, so we can use the locations directly for (r_ssize i = 0; i < out_n; ++i) { const int loc = v_out[i] - 1; r_chr_poke(out_names, i, v_names[loc]); } } } FREE(1); return out; } lobstr/src/rlang/dots-info.c0000644000176200001440000001202615163457235015533 0ustar liggesusers#include #define RLANG_HAS_R_DOTS_API (R_VERSION >= R_Version(4, 6, 0)) #if !RLANG_HAS_R_DOTS_API static bool is_promise(r_obj* x) { return r_typeof(x) == R_TYPE_promise; } static r_obj* promise_expr(r_obj* x) { return PREXPR(x); } static r_obj* promise_env(r_obj* x) { return PRENV(x); } static r_obj* env_dot_find(r_obj* env, r_ssize i) { if (i < 0) { r_abort("indexing '...' with negative index %d", (int) i); } r_obj* dots = Rf_findVarInFrame(env, r_syms.dots); if (dots == R_UnboundValue) { r_abort("'...' used in an incorrect context"); } if (dots == r_syms.missing || r_typeof(dots) != R_TYPE_dots) { r_abort("the ... list contains fewer than %d elements", (int) i + 1); } for (r_ssize j = 0; j < i; ++j) { dots = r_node_cdr(dots); if (dots == r_null) { r_abort("the ... list contains fewer than %d elements", (int) i + 1); } } return r_node_car(dots); } #endif // Dots API - mirrors R-devel PR #209 --- // See https://github.com/r-devel/r-svn/pull/209 // R API: R_DotsExist bool r_env_dots_exist(r_obj* env) { #if RLANG_HAS_R_DOTS_API return R_DotsExist(env); #else r_obj* dots = Rf_findVarInFrame(env, r_syms.dots); return dots != R_UnboundValue && (dots == r_syms.missing || r_typeof(dots) == R_TYPE_dots); #endif } r_obj* r_env_until_dots(r_obj* env) { while (env != r_envs.empty) { if (r_env_dots_exist(env)) { return env; } env = r_env_parent(env); } return r_envs.empty; } // R API: R_DotsLength r_ssize r_env_dots_length(r_obj* env) { #if RLANG_HAS_R_DOTS_API return (r_ssize) R_DotsLength(env); #else r_obj* dots = Rf_findVarInFrame(env, r_syms.dots); if (dots == R_UnboundValue) { r_abort("incorrect context: the current call has no '...' to look in"); } if (dots == r_syms.missing || r_typeof(dots) != R_TYPE_dots) { return 0; } return r_length(dots); #endif } // R API: R_DotsNames // Returns NULL when all dots are unnamed. r_obj* r_env_dots_names(r_obj* env) { #if RLANG_HAS_R_DOTS_API return R_DotsNames(env); #else r_obj* dots = KEEP(Rf_findVarInFrame(env, r_syms.dots)); if (dots == R_UnboundValue) { r_abort("incorrect context: the current call has no '...' to look in"); } r_ssize n = (dots == r_syms.missing || r_typeof(dots) != R_TYPE_dots) ? 0 : r_length(dots); r_obj* out = r_null; for (r_ssize i = 0; i < n; ++i) { r_obj* tag = r_node_tag(dots); if (r_typeof(tag) == R_TYPE_symbol) { if (out == r_null) { out = KEEP(r_alloc_character(n)); } r_chr_poke(out, i, r_sym_string(tag)); } dots = r_node_cdr(dots); } if (out != r_null) { FREE(1); } FREE(1); return out; #endif } // R API: R_DotsElt r_obj* r_env_dot_get(r_obj* env, r_ssize i) { if (r_env_dot_type(env, i) == DOT_TYPE_missing) { return r_missing_arg; } #if RLANG_HAS_R_DOTS_API return R_DotsElt((int)(i + 1), env); #else r_obj* elt = env_dot_find(env, i); return r_eval(elt, env); #endif } // R API: R_GetDotType r_dot_type_t r_env_dot_type(r_obj* env, r_ssize i) { #if RLANG_HAS_R_DOTS_API return (r_dot_type_t) R_GetDotType((int)(i + 1), env); #else r_obj* elt = env_dot_find(env, i); if (elt == r_syms.missing) { return DOT_TYPE_missing; } if (!is_promise(elt)) { return DOT_TYPE_value; } bool forced; rlang_promise_unwrap(elt, &forced); if (forced) { return DOT_TYPE_forced; } return DOT_TYPE_delayed; #endif } // R API: R_DotDelayedExpression r_obj* r_env_dot_delayed_expr(r_obj* env, r_ssize i) { #if RLANG_HAS_R_DOTS_API return R_DotDelayedExpression((int)(i + 1), env); #else r_obj* elt = env_dot_find(env, i); if (!is_promise(elt)) { r_abort("not a delayed ... element"); } bool forced; r_obj* inner = rlang_promise_unwrap(elt, &forced); if (forced) { r_abort("not a delayed ... element"); } return promise_expr(inner); #endif } // R API: R_DotDelayedEnvironment r_obj* r_env_dot_delayed_env(r_obj* env, r_ssize i) { #if RLANG_HAS_R_DOTS_API return R_DotDelayedEnvironment((int)(i + 1), env); #else r_obj* elt = env_dot_find(env, i); if (!is_promise(elt)) { r_abort("not a delayed ... element"); } bool forced; r_obj* inner = rlang_promise_unwrap(elt, &forced); if (forced) { r_abort("not a delayed ... element"); } return promise_env(inner); #endif } // R API: R_DotForcedExpression r_obj* r_env_dot_forced_expr(r_obj* env, r_ssize i) { #if RLANG_HAS_R_DOTS_API return R_DotForcedExpression((int)(i + 1), env); #else r_obj* elt = env_dot_find(env, i); if (!is_promise(elt)) { r_abort("not a forced ... element"); } bool forced; r_obj* inner = rlang_promise_unwrap(elt, &forced); if (!forced) { r_abort("not a forced ... element"); } return promise_expr(inner); #endif } lobstr/src/rlang/stack.c0000644000176200001440000000504515163457235014741 0ustar liggesusers#include "rlang.h" #include "decl/stack-decl.h" void r_on_exit(r_obj* expr, r_obj* frame) { static r_obj* on_exit_prim = NULL; if (!on_exit_prim) { on_exit_prim = r_base_ns_get("on.exit"); } r_obj* args = r_pairlist2(expr, r_lgl(1)); r_obj* lang = KEEP(r_new_call(on_exit_prim, args)); r_eval(lang, frame); FREE(1); } r_obj* r_peek_frame(void) { return r_eval(peek_frame_call, r_envs.base); } r_obj* r_caller_env(r_obj* n) { if (r_typeof(n) != R_TYPE_environment) { r_stop_internal("`n` must be an environment."); } return r_eval(caller_env_call, n); } static r_obj* sys_frame_call = NULL; static r_obj* sys_call_call = NULL; static int* sys_frame_n_addr = NULL; static int* sys_call_n_addr = NULL; r_obj* r_sys_frame(int n, r_obj* frame) { int n_kept = 0; if (!frame) { frame = r_peek_frame(); KEEP_N(frame, &n_kept); } *sys_frame_n_addr = n; SEXP value = r_eval(sys_frame_call, frame); FREE(n_kept); return value; } r_obj* r_sys_call(int n, r_obj* frame) { int n_kept = 0; if (!frame) { frame = r_peek_frame(); KEEP_N(frame, &n_kept); } *sys_call_n_addr = n; SEXP value = r_eval(sys_call_call, frame); FREE(n_kept); return value; } static r_obj* generate_sys_call(const char* name, int** n_addr) { r_obj* sys_n = KEEP(r_int(0)); *n_addr = r_int_begin(sys_n); r_obj* sys_args = KEEP(r_new_node(sys_n, r_null)); r_obj* sys_call = KEEP(r_new_call(r_base_ns_get(name), sys_args)); r_preserve(sys_call); FREE(3); return sys_call; } void r_init_library_stack(void) { // `sys.frame(sys.nframe())` doesn't work because `sys.nframe()` // returns the number of the frame in which evaluation occurs. It // doesn't return the number of frames on the stack. So we'd need // to evaluate it in the last frame on the stack which is what we // are looking for to begin with. We use instead this workaround: // Call `sys.frame()` from a closure to push a new frame on the // stack, and use negative indexing to get the previous frame. r_obj* current_frame_body = KEEP(r_parse("sys.frame(-1)")); r_obj* current_frame_fn = KEEP(r_new_function(r_null, current_frame_body, r_envs.base)); peek_frame_call = r_new_call(current_frame_fn, r_null); r_preserve(peek_frame_call); FREE(2); sys_frame_call = generate_sys_call("sys.frame", &sys_frame_n_addr); sys_call_call = generate_sys_call("sys.call", &sys_call_n_addr); caller_env_call = r_parse("parent.frame()"); r_preserve_global(caller_env_call); } static r_obj* peek_frame_call = NULL; static r_obj* caller_env_call = NULL; lobstr/src/rlang/eval.c0000644000176200001440000001100715163457235014556 0ustar liggesusers#include "rlang.h" r_obj* r_eval_with_x(r_obj* call, r_obj* x, r_obj* parent) { r_obj* env = KEEP(r_alloc_environment(1, parent)); r_env_bind(env, r_syms.x, x); r_obj* out = r_eval(call, env); FREE(1); return out; } r_obj* r_eval_with_xy(r_obj* call, r_obj* x, r_obj* y, r_obj* parent) { r_obj* env = KEEP(r_alloc_environment(2, parent)); r_env_bind(env, r_syms.x, x); r_env_bind(env, r_syms.y, y); r_obj* out = r_eval(call, env); FREE(1); return out; } r_obj* r_eval_with_xyz(r_obj* call, r_obj* x, r_obj* y, r_obj* z, r_obj* parent) { r_obj* env = KEEP(r_alloc_environment(3, parent)); r_env_bind(env, r_syms.x, x); r_env_bind(env, r_syms.y, y); r_env_bind(env, r_syms.z, z); r_obj* out = r_eval(call, env); FREE(1); return out; } r_obj* r_eval_with_wxyz(r_obj* call, r_obj* w, r_obj* x, r_obj* y, r_obj* z, r_obj* parent) { r_obj* env = KEEP(r_alloc_environment(4, parent)); r_env_bind(env, r_syms.w, w); r_env_bind(env, r_syms.x, x); r_env_bind(env, r_syms.y, y); r_env_bind(env, r_syms.z, z); r_obj* out = r_eval(call, env); FREE(1); return out; } // Evaluate call with a preallocated environment containing a single // `x` binding and inheriting from base env. // // Since this has side effects, it should not be used when there is a // chance of recursing into the C library. It should only be used to // evaluate pure R calls or functions from other packages, such as the // base package. static r_obj* shared_x_env; static r_obj* shared_xy_env; static r_obj* shared_xyz_env; r_obj* eval_with_x(r_obj* call, r_obj* x) { r_env_bind(shared_x_env, r_syms.x, x); r_obj* out = KEEP(r_eval(call, shared_x_env)); // Release for gc r_env_bind(shared_x_env, r_syms.x, r_null); FREE(1); return out; } r_obj* eval_with_xy(r_obj* call, r_obj* x, r_obj* y) { r_env_bind(shared_xy_env, r_syms.x, x); r_env_bind(shared_xy_env, r_syms.y, y); r_obj* out = KEEP(r_eval(call, shared_xy_env)); // Release for gc r_env_bind(shared_xy_env, r_syms.x, r_null); r_env_bind(shared_xy_env, r_syms.y, r_null); FREE(1); return out; } r_obj* eval_with_xyz(r_obj* call, r_obj* x, r_obj* y, r_obj* z) { r_env_bind(shared_xyz_env, r_syms.x, x); r_env_bind(shared_xyz_env, r_syms.y, y); r_env_bind(shared_xyz_env, r_syms.z, z); r_obj* out = KEEP(r_eval(call, shared_xyz_env)); // Release for gc r_env_bind(shared_xyz_env, r_syms.x, r_null); r_env_bind(shared_xyz_env, r_syms.y, r_null); r_env_bind(shared_xyz_env, r_syms.z, r_null); FREE(1); return out; } r_obj* r_exec_mask_n(r_obj* fn_sym, r_obj* fn, const struct r_pair* args, int n, r_obj* parent) { r_obj* mask = KEEP(r_alloc_environment(n + 1, parent)); r_obj* call = KEEP(r_exec_mask_n_call_poke(fn_sym, fn, args, n, mask)); r_obj* out = r_eval(call, mask); FREE(2); return out; } r_obj* r_exec_n(r_obj* fn_sym, r_obj* fn, const struct r_pair* args, int n, r_obj* env) { r_obj* call = KEEP(r_exec_mask_n_call_poke(fn_sym, fn, args, n, env)); r_obj* out = r_eval(call, env); FREE(1); return out; } // Create a call from arguments and poke elements with a non-NULL // symbol in `env`. Symbolic arguments are protected from evaluation // with `quote()`. r_obj* r_exec_mask_n_call_poke(r_obj* fn_sym, r_obj* fn, const struct r_pair* args, int n, r_obj* env) { if (fn_sym != r_null) { r_env_bind(env, fn_sym, fn); fn = fn_sym; } r_obj* list = KEEP(r_new_pairlist(args, n, NULL)); r_obj* node = list; while (node != r_null) { r_obj* car = r_node_car(node); r_obj* tag = r_node_tag(node); if (tag == r_null) { // If symbol is not supplied, protect symbolic arguments from // evaluation. If supplied this is not needed because of the // masking. r_node_poke_car(node, r_expr_protect(car)); } else { // If symbol is supplied, assign the value in the environment and // use the symbol instead of the value in the list of arguments r_env_bind(env, tag, car); r_node_poke_car(node, tag); } node = r_node_cdr(node); } r_obj* call = r_new_call(fn, list); FREE(1); return call; } void r_init_library_eval(void) { r_lazy_missing_arg = (struct r_lazy) { .x = r_missing_arg, .env = r_null }; } struct r_lazy r_lazy_null = { 0 }; struct r_lazy r_lazy_missing_arg = { 0 }; lobstr/src/rlang/dyn-array.c0000644000176200001440000000575315163457235015550 0ustar liggesusers#include #include "dyn-array.h" #define R_DYN_ARRAY_GROWTH_FACTOR 2 static r_obj* dyn_array_class = NULL; struct r_dyn_array* r_new_dyn_vector(enum r_type type, r_ssize capacity) { r_obj* shelter = KEEP(r_alloc_list(2)); r_attrib_poke_class(shelter, dyn_array_class); r_obj* vec_raw = r_alloc_raw(sizeof(struct r_dyn_array)); r_list_poke(shelter, 0, vec_raw); r_obj* vec_data = r_alloc_vector(type, capacity); r_list_poke(shelter, 1, vec_data); struct r_dyn_array* p_vec = r_raw_begin(vec_raw); p_vec->shelter = shelter; p_vec->count = 0; p_vec->capacity = capacity; p_vec->growth_factor = R_DYN_ARRAY_GROWTH_FACTOR; p_vec->type = type; p_vec->elt_byte_size = r_vec_elt_sizeof0(type); p_vec->data = vec_data; switch (type) { case R_TYPE_character: p_vec->v_data = NULL; p_vec->barrier_set = &r_chr_poke; break; case R_TYPE_list: p_vec->v_data = NULL; p_vec->barrier_set = &r_list_poke; break; default: p_vec->barrier_set = NULL; p_vec->v_data = r_vec_begin0(type, vec_data); break; } p_vec->v_data_const = r_vec_cbegin0(type, vec_data); FREE(1); return p_vec; } r_obj* r_dyn_unwrap(struct r_dyn_array* p_arr) { if (p_arr->type == R_TYPE_raw) { return r_raw_resize(p_arr->data, p_arr->count * p_arr->elt_byte_size); } else { return r_vec_resize0(p_arr->type, p_arr->data, p_arr->count); } } struct r_dyn_array* r_new_dyn_array(r_ssize elt_byte_size, r_ssize capacity) { r_ssize arr_byte_size = r_ssize_mult(capacity, elt_byte_size); struct r_dyn_array* p_arr = r_new_dyn_vector(R_TYPE_raw, arr_byte_size); p_arr->capacity = capacity; p_arr->elt_byte_size = elt_byte_size; return p_arr; } void r_dyn_push_back(struct r_dyn_array* p_arr, const void* p_elt) { r_ssize loc = r__dyn_increment(p_arr); if (p_arr->barrier_set) { r_obj* value = *((r_obj* const *) p_elt); p_arr->barrier_set(p_arr->data, loc, value); } else if (p_elt) { r_memcpy(r_dyn_last(p_arr), p_elt, p_arr->elt_byte_size); } else { r_memset(r_dyn_last(p_arr), 0, p_arr->elt_byte_size); } } void r_dyn_resize(struct r_dyn_array* p_arr, r_ssize capacity) { enum r_type type = p_arr->type; r_ssize capacity_multiplier = p_arr->type == R_TYPE_raw ? r_ssize_mult(p_arr->elt_byte_size, capacity) : capacity; r_obj* data = r_vec_resize0(type, r_list_get(p_arr->shelter, 1), capacity_multiplier); r_list_poke(p_arr->shelter, 1, data); p_arr->count = r_ssize_min(p_arr->count, capacity); p_arr->capacity = capacity; p_arr->data = data; switch (type) { case R_TYPE_character: case R_TYPE_list: break; default: p_arr->v_data = r_vec_begin0(type, data); break; } p_arr->v_data_const = r_vec_cbegin0(type, data); } void r_init_library_dyn_array(void) { r_preserve_global(dyn_array_class = r_chr("rlang_dyn_array")); } lobstr/src/rlang/env-binding.h0000644000176200001440000000303715163457235016040 0ustar liggesusers// IWYU pragma: private; include "rlang.h" #ifndef RLANG_ENV_BINDING_H #define RLANG_ENV_BINDING_H #include "rlang-types.h" enum r_env_binding_type { R_ENV_BINDING_TYPE_unbound = 0, R_ENV_BINDING_TYPE_value = 1, R_ENV_BINDING_TYPE_missing = 2, R_ENV_BINDING_TYPE_delayed = 3, R_ENV_BINDING_TYPE_forced = 4, R_ENV_BINDING_TYPE_active = 5 }; enum r_env_binding_type r_env_binding_type(r_obj* env, r_obj* sym); r_obj* r_env_binding_types(r_obj* env, r_obj* syms); r_obj* r_env_syms(r_obj* env); r_obj* r_env_get(r_obj* env, r_obj* sym); // Binding constructors static inline void r_env_bind(r_obj* env, r_obj* sym, r_obj* value) { // See rchk concerns in https://github.com/r-lib/rlang/commit/28ce7b01 KEEP(value); Rf_defineVar(sym, value, env); FREE(1); } // Silently ignores bindings that are not defined in `env`. static inline void r_env_unbind(r_obj* env, r_obj* sym) { R_removeVarFromFrame(sym, env); } void r_env_bind_active(r_obj* env, r_obj* sym, r_obj* fn); void r_env_bind_delayed(r_obj* env, r_obj* sym, r_obj* expr, r_obj* eval_env); void r_env_bind_forced(r_obj* env, r_obj* sym, r_obj* expr, r_obj* value); void r_env_bind_missing(r_obj* env, r_obj* sym); // Delayed binding accessors r_obj* r_env_binding_delayed_expr(r_obj* env, r_obj* sym); r_obj* r_env_binding_delayed_env(r_obj* env, r_obj* sym); // Forced binding accessors r_obj* r_env_binding_forced_expr(r_obj* env, r_obj* sym); // Active binding accessors r_obj* r_env_binding_active_fn(r_obj* env, r_obj* sym); void r_init_library_env_binding(void); #endif lobstr/src/rlang/rlang.hpp0000644000176200001440000000065515163457235015306 0ustar liggesusers#ifndef RLANG_RLANG_HPP #define RLANG_RLANG_HPP #include #define R_NO_REMAP #include extern "C" { #include } static inline r_no_return void rcc_abort(const char* fn) { try { throw; } catch (const std::exception& err) { r_abort(err.what()); } catch (...) { r_obj* call = KEEP(r_call(r_sym(fn))); (r_stop_internal)("", -1, call, "Caught unknown C++ exception."); } } #endif lobstr/src/rlang/dyn-list-of.h0000644000176200001440000000325615163457235016010 0ustar liggesusers// IWYU pragma: private; include "rlang.h" #ifndef RLANG_DYN_LIST_OF_H #define RLANG_DYN_LIST_OF_H #include "rlang-types.h" #include "dyn-array.h" struct r_dyn_list_of { r_obj* shelter; r_ssize count; r_ssize capacity; int growth_factor; // Contains the addresses and sizes of each element of the // list-of. If you copy that pointer, consider it invalid after a // push because it might have moved in memory due to a resize. struct r_pair_ptr_ssize* v_data; // private: r_ssize width; enum r_type type; r_ssize elt_byte_size; r_obj* reserve; void* v_reserve; struct r_dyn_array* p_moved_arr; struct r_dyn_array* p_moved_shelter_arr; r_obj* arr_locs; r_ssize* v_arr_locs; struct r_dyn_array* p_arrays; }; struct r_dyn_list_of* r_new_dyn_list_of(enum r_type type, r_ssize capacity, r_ssize width); r_obj* r_lof_unwrap(struct r_dyn_list_of* p_lof); void r_lof_push_back(struct r_dyn_list_of* p_lof); void r_lof_arr_push_back(struct r_dyn_list_of* p_lof, r_ssize i, void* p_elt); static inline void* r_lof_arr_ptr(struct r_dyn_list_of* p_lof, r_ssize i, r_ssize j) { r_ssize offset = j * p_lof->elt_byte_size; struct r_pair_ptr_ssize* v_arrays = (struct r_pair_ptr_ssize*) r_dyn_pointer(p_lof->p_arrays, i); return ((unsigned char*) v_arrays->ptr) + offset; } static inline void* r_lof_arr_ptr_front(struct r_dyn_list_of* p_lof, r_ssize i) { return r_lof_arr_ptr(p_lof, i, 0); } static inline void* r_lof_arr_ptr_back(struct r_dyn_list_of* p_lof, r_ssize i) { return r_lof_arr_ptr(p_lof, i, p_lof->count - 1); } #endif lobstr/src/rlang/stack.h0000644000176200001440000000057515163457235014751 0ustar liggesusers// IWYU pragma: private; include "rlang.h" #ifndef RLANG_STACK_H #define RLANG_STACK_H #include "rlang-types.h" void r_on_exit(r_obj* expr, r_obj* frame); r_obj* r_peek_frame(void); r_obj* r_caller_env(r_obj* n); r_obj* r_sys_frame(int n, r_obj* frame); r_obj* r_sys_call(int n, r_obj* frame); static inline void r_yield_interrupt(void) { R_CheckUserInterrupt(); } #endif lobstr/src/rlang/env.h0000644000176200001440000000476015163457235014434 0ustar liggesusers// IWYU pragma: private; include "rlang.h" #ifndef RLANG_ENV_H #define RLANG_ENV_H #include "rlang-types.h" #include "cnd.h" #include "globals.h" #include "obj.h" #define RLANG_USE_R_EXISTS (R_VERSION < R_Version(4, 2, 0)) extern r_obj* r_methods_ns_env; static inline r_obj* r_env_names(r_obj* env) { return R_lsInternal3(env, TRUE, FALSE); } static inline r_ssize r_env_length(r_obj* env) { if (r_typeof(env) != R_TYPE_environment) { r_abort("Expected an environment"); } return Rf_xlength(env); } static inline r_obj* r_env_parent(r_obj* env) { if (env == r_envs.empty) { r_stop_internal("Can't take the parent of the empty environment."); } #if R_VERSION >= R_Version(4, 5, 0) return R_ParentEnv(env); #else return ENCLOS(env); #endif } static inline bool r_is_environment(r_obj* x) { return TYPEOF(x) == ENVSXP; } static inline bool r_is_namespace(r_obj* x) { return R_IsNamespaceEnv(x); } r_obj* r_env_until(r_obj* env, r_obj* sym, r_obj* last); r_obj* r_env_get_anywhere(r_obj* env, r_obj* sym); r_obj* r_env_get_until(r_obj* env, r_obj* sym, r_obj* last); bool r_env_has_until(r_obj* env, r_obj* sym, r_obj* last); static inline bool r_env_has(r_obj* env, r_obj* sym) { #if RLANG_USE_R_EXISTS bool r__env_has(r_obj*, r_obj*); return r__env_has(env, sym); #else return R_existsVarInFrame(env, sym); #endif } static inline bool r_env_has_anywhere(r_obj* env, r_obj* sym) { #if RLANG_USE_R_EXISTS bool r__env_has_anywhere(r_obj*, r_obj*); return r__env_has_anywhere(env, sym); #else while (env != r_envs.empty) { if (r_env_has(env, sym)) { return true; } env = r_env_parent(env); } return false; #endif } bool r_env_has_missing(r_obj* env, r_obj* sym); r_obj* r_ns_env(const char* pkg); r_obj* r_base_ns_get(const char* name); r_obj* r_alloc_environment(r_ssize size, r_obj* parent); static inline r_obj* r_alloc_empty_environment(r_obj* parent) { // Non-hashed environment. // Very fast and useful when you aren't getting/setting from the result. #if R_VERSION >= R_Version(4, 1, 0) const int hash = 0; const int size = 0; // Not used when `hash = 0` return R_NewEnv(parent, hash, size); #else r_obj* env = Rf_allocSExp(R_TYPE_environment); SET_ENCLOS(env, parent); return env; #endif } r_obj* r_env_as_list(r_obj* x); r_obj* r_list_as_environment(r_obj* x, r_obj* parent); r_obj* r_env_clone(r_obj* env, r_obj* parent); void r_env_coalesce(r_obj* env, r_obj* from); bool r_env_inherits(r_obj* env, r_obj* ancestor, r_obj* top); #endif lobstr/src/rlang/cnd.c0000644000176200001440000001136115163457235014376 0ustar liggesusers#include "rlang.h" #include "decl/cnd-decl.h" #define BUFSIZE 8192 #define INTERP(BUF, FMT, DOTS) \ { \ va_list dots; \ va_start(dots, FMT); \ vsnprintf(BUF, BUFSIZE, FMT, dots); \ va_end(dots); \ \ BUF[BUFSIZE - 1] = '\0'; \ } static r_obj* msg_call = NULL; void r_inform(const char* fmt, ...) { char buf[BUFSIZE]; INTERP(buf, fmt, ...); r_eval_with_x(msg_call, KEEP(r_chr(buf)), r_envs.ns); FREE(1); } static r_obj* wng_call = NULL; void r_warn(const char* fmt, ...) { char buf[BUFSIZE]; INTERP(buf, fmt, ...); r_eval_with_x(wng_call, KEEP(r_chr(buf)), r_envs.ns); FREE(1); } static r_obj* err_call = NULL; void r_abort(const char* fmt, ...) { char buf[BUFSIZE]; INTERP(buf, fmt, ...); r_obj* message = KEEP(r_chr(buf)); // Evaluate in a mask but forward error call to the current frame r_obj* frame = KEEP(r_peek_frame()); r_obj* mask = KEEP(r_alloc_environment(2, frame)); r_env_bind(mask, r_syms.error_call_flag, frame); struct r_pair args[] = { { r_syms.message, message } }; r_exec_n(r_null, r_syms.abort, args, R_ARR_SIZEOF(args), mask); while (1); // No return } r_no_return void r_abort_n(const struct r_pair* args, int n) { r_exec_mask_n(r_null, r_syms.abort, args, n, r_peek_frame()); r_stop_unreachable(); } r_no_return void r_abort_call(r_obj* call, const char* fmt, ...) { char buf[BUFSIZE]; INTERP(buf, fmt, ...); r_obj* message = KEEP(r_chr(buf)); struct r_pair args[] = { { r_syms.message, message }, { r_syms.call, call } }; r_obj* frame = KEEP(r_peek_frame()); r_exec_mask_n(r_null, r_syms.abort, args, R_ARR_SIZEOF(args), frame); r_stop_unreachable(); } void r_cnd_signal(r_obj* cnd) { r_eval_with_x(cnd_signal_call, cnd, r_envs.base); } // For `R_interrupts_suspended` #include #include #ifdef _WIN32 #include void r_interrupt(void) { UserBreak = 1; R_CheckUserInterrupt(); } #else #include void r_interrupt(void) { Rf_onintr(); } #endif enum r_cnd_type r_cnd_type(r_obj* cnd) { r_obj* classes = r_class(cnd); if (r_typeof(cnd) != R_TYPE_list || r_typeof(classes) != R_TYPE_character) { goto error; } r_obj* const * v_classes = r_chr_cbegin(classes); r_ssize n_classes = r_length(classes); for (r_ssize i = n_classes - 2; i >= 0; --i) { r_obj* class_str = v_classes[i]; if (class_str == r_strs.error) { return R_CND_TYPE_error; } if (class_str == r_strs.warning) { return R_CND_TYPE_warning; } if (class_str == r_strs.message) { return R_CND_TYPE_message; } if (class_str == r_strs.interrupt) { return R_CND_TYPE_interrupt; } } if (r_inherits(cnd, "condition")) { return R_CND_TYPE_condition; } error: r_abort("`cnd` is not a condition object."); } void r_init_library_cnd(void) { msg_call = r_parse("message(x)"); r_preserve(msg_call); wng_call = r_parse("warning(x, call. = FALSE)"); r_preserve(wng_call); err_call = r_parse("rlang::abort(x)"); r_preserve(err_call); cnd_signal_call = r_parse("rlang::cnd_signal(x)"); r_preserve(cnd_signal_call); // Silence "'noreturn' attribute does not apply to types warning". // It seems like GCC doesn't handle attributes in casts so we need // to cast through a typedef. // https://stackoverflow.com/questions/9441262/function-pointer-to-attribute-const-function typedef r_no_return void (*r_stop_internal_t)(const char*, int, r_obj*, const char* fmt, ...); r_stop_internal = (r_stop_internal_t) R_GetCCallable("rlang", "rlang_stop_internal2"); r_format_error_arg = (const char* (*)(r_obj*)) r_peek_c_callable("rlang", "rlang_format_error_arg"); r_obj_type_friendly_full = (const char* (*)(r_obj*, bool, bool)) r_peek_c_callable("rlang", "rlang_obj_type_friendly_full"); } r_no_return void (*r_stop_internal)(const char* file, int line, r_obj* call, const char* fmt, ...) = NULL; static r_obj* cnd_signal_call = NULL; const char* (*r_format_error_arg)(r_obj* arg) = NULL; const char* (*r_obj_type_friendly_full)(r_obj* x, bool value, bool length) = NULL; const char* r_format_lazy_error_arg(struct r_lazy arg) { r_obj* ffi_arg = KEEP(r_lazy_eval(arg)); const char* out = r_format_error_arg(ffi_arg); FREE(1); return out; } lobstr/src/rlang/env-binding.c0000644000176200001440000001622715163457235016040 0ustar liggesusers#include "rlang.h" #include "env.h" #include "decl/env-binding-decl.h" // https://bugs.r-project.org/show_bug.cgi?id=18928 #define RLANG_HAS_R_BINDING_API (R_VERSION >= R_Version(4, 6, 0)) #if !RLANG_HAS_R_BINDING_API static inline r_obj* env_find(r_obj* env, r_obj* sym) { return Rf_findVarInFrame3(env, sym, FALSE); } #endif static r_obj* new_binding_types(r_ssize n) { r_obj* types = r_alloc_integer(n); int* types_ptr = r_int_begin(types); r_memset(types_ptr, 0, n * sizeof *types_ptr); return types; } static inline r_obj* binding_as_sym(bool list, r_obj* bindings, r_ssize i) { if (list) { r_obj* out = r_list_get(bindings, i); if (r_typeof(out) != R_TYPE_symbol) { r_abort("Binding must be a symbol."); } return out; } else { return r_str_as_symbol(r_chr_get(bindings, i)); } } static r_ssize detect_special_binding(r_obj* env, r_obj* bindings, bool symbols) { r_ssize n = r_length(bindings); for (r_ssize i = 0; i < n; ++i) { r_obj* sym = binding_as_sym(symbols, bindings, i); enum r_env_binding_type type = r_env_binding_type(env, sym); if (type == R_ENV_BINDING_TYPE_active || type == R_ENV_BINDING_TYPE_delayed) { return i; } } return -1; } // Returns NULL if all values to spare an alloc r_obj* r_env_binding_types(r_obj* env, r_obj* bindings) { if (r_typeof(env) != R_TYPE_environment) { r_abort("Expected environment in promise binding predicate."); } bool symbols; switch (r_typeof(bindings)) { case R_TYPE_list: symbols = true; break; case R_TYPE_character: symbols = false; break; default: r_abort("Internal error: Unexpected `bindings` type in `r_env_binding_types()`"); } r_ssize i = detect_special_binding(env, bindings, symbols); if (i < 0) { return r_null; } r_ssize n = r_length(bindings); r_obj* types = KEEP(new_binding_types(n)); int* types_ptr = r_int_begin(types); // Fill value type for bindings before first special binding for (r_ssize j = 0; j < i; ++j) { *types_ptr = R_ENV_BINDING_TYPE_value; ++types_ptr; } while (i < n) { r_obj* sym = binding_as_sym(symbols, bindings, i); *types_ptr = r_env_binding_type(env, sym); ++i; ++types_ptr; } FREE(1); return types; } // R API: R_envSymbols r_obj* r_env_syms(r_obj* env) { #if RLANG_HAS_R_BINDING_API return R_envSymbols(env); #else // This does an extra alloc, as does the initial implementation in https://github.com/r-devel/r-svn/commit/ee6dc5080845f911d7a884398213d22f3de63fe2 r_obj* nms = KEEP(r_env_names(env)); r_ssize n = r_length(nms); r_obj* out = KEEP(r_alloc_list(n)); r_obj* const * v_nms = r_chr_cbegin(nms); for (r_ssize i = 0; i < n; ++i) { r_list_poke(out, i, r_str_as_symbol(v_nms[i])); } FREE(2); return out; #endif } // Binding type API // Implements future R API from https://bugs.r-project.org/show_bug.cgi?id=18928 enum r_env_binding_type r_env_binding_type(r_obj* env, r_obj* sym) { #if RLANG_HAS_R_BINDING_API switch (R_GetBindingType(sym, env)) { case R_BindingTypeUnbound: return R_ENV_BINDING_TYPE_unbound; case R_BindingTypeValue: return R_ENV_BINDING_TYPE_value; case R_BindingTypeMissing: return R_ENV_BINDING_TYPE_missing; case R_BindingTypeDelayed: return R_ENV_BINDING_TYPE_delayed; case R_BindingTypeForced: return R_ENV_BINDING_TYPE_forced; case R_BindingTypeActive: return R_ENV_BINDING_TYPE_active; } r_stop_unreachable(); #else // Active binding check must come first since `r_env_find()` triggers them if (R_BindingIsActive(sym, env)) { return R_ENV_BINDING_TYPE_active; } r_obj* value = env_find(env, sym); if (value == R_UnboundValue) { return R_ENV_BINDING_TYPE_unbound; } if (value == r_missing_arg) { return R_ENV_BINDING_TYPE_missing; } if (r_typeof(value) == R_TYPE_promise) { bool forced; rlang_promise_unwrap(value, &forced); if (forced) { return R_ENV_BINDING_TYPE_forced; } return R_ENV_BINDING_TYPE_delayed; } return R_ENV_BINDING_TYPE_value; #endif } r_obj* r_env_get(r_obj* env, r_obj* sym) { enum r_env_binding_type type = r_env_binding_type(env, sym); if (type == R_ENV_BINDING_TYPE_unbound) { r_abort("object '%s' not found", r_sym_c_string(sym)); } if (type == R_ENV_BINDING_TYPE_missing) { return r_missing_arg; } #if R_VERSION >= R_Version(4, 5, 0) return R_getVar(sym, env, FALSE); #else r_obj* value = env_find(env, sym); if (r_typeof(value) == R_TYPE_dots) { return value; } // Handles value, delayed, forced, and active bindings return Rf_eval(sym, env); #endif } // Binding constructors void r_env_bind_active(r_obj* env, r_obj* sym, r_obj* fn) { KEEP(fn); r_env_unbind(env, sym); R_MakeActiveBinding(sym, fn, env); FREE(1); } void r_env_bind_delayed(r_obj* env, r_obj* sym, r_obj* expr, r_obj* eval_env) { #if RLANG_HAS_R_BINDING_API R_MakeDelayedBinding(sym, expr, eval_env, env); #else r_obj* promise = KEEP(Rf_allocSExp(PROMSXP)); SET_PRCODE(promise, expr); SET_PRENV(promise, eval_env); SET_PRVALUE(promise, R_UnboundValue); Rf_defineVar(sym, promise, env); FREE(1); #endif } void r_env_bind_forced(r_obj* env, r_obj* sym, r_obj* expr, r_obj* value) { #if RLANG_HAS_R_BINDING_API R_MakeForcedBinding(sym, expr, value, env); #else r_obj* promise = KEEP(Rf_allocSExp(PROMSXP)); SET_PRCODE(promise, expr); SET_PRENV(promise, r_null); SET_PRVALUE(promise, value); Rf_defineVar(sym, promise, env); FREE(1); #endif } void r_env_bind_missing(r_obj* env, r_obj* sym) { #if RLANG_HAS_R_BINDING_API R_MakeMissingBinding(sym, env); #else Rf_defineVar(sym, r_missing_arg, env); #endif } // Delayed binding accessors r_obj* r_env_binding_delayed_expr(r_obj* env, r_obj* sym) { #if RLANG_HAS_R_BINDING_API return R_DelayedBindingExpression(sym, env); #else r_obj* value = env_find(env, sym); if (r_typeof(value) != R_TYPE_promise) { r_abort("not a delayed binding"); } bool forced; r_obj* inner = rlang_promise_unwrap(value, &forced); if (forced) { r_abort("not a delayed binding"); } return R_PromiseExpr(inner); #endif } r_obj* r_env_binding_delayed_env(r_obj* env, r_obj* sym) { #if RLANG_HAS_R_BINDING_API return R_DelayedBindingEnvironment(sym, env); #else r_obj* value = env_find(env, sym); if (r_typeof(value) != R_TYPE_promise) { r_abort("not a delayed binding"); } bool forced; r_obj* inner = rlang_promise_unwrap(value, &forced); if (forced) { r_abort("not a delayed binding"); } return PRENV(inner); #endif } // Forced binding accessors r_obj* r_env_binding_forced_expr(r_obj* env, r_obj* sym) { #if RLANG_HAS_R_BINDING_API return R_ForcedBindingExpression(sym, env); #else r_obj* value = env_find(env, sym); if (r_typeof(value) != R_TYPE_promise) { r_abort("not a forced binding"); } bool forced; r_obj* inner = rlang_promise_unwrap(value, &forced); if (!forced) { r_abort("not a forced binding"); } return R_PromiseExpr(inner); #endif } // Use `r_env_get()` to get the value of a forced binding // Active binding accessors r_obj* r_env_binding_active_fn(r_obj* env, r_obj* sym) { return R_ActiveBindingFunction(sym, env); } lobstr/src/rlang/call.c0000644000176200001440000000223215163457235014542 0ustar liggesusers#include "rlang.h" static r_obj* quote_prim = NULL; bool r_is_call(r_obj* x, const char* name) { if (r_typeof(x) != LANGSXP) { return false; } else { return name == NULL || r_is_symbol(r_node_car(x), name); } } bool r_is_call_any(r_obj* x, const char** names, int n) { if (r_typeof(x) != LANGSXP) { return false; } else { return r_is_symbol_any(r_node_car(x), names, n); } } r_obj* r_expr_protect(r_obj* x) { switch (r_typeof(x)) { case R_TYPE_symbol: case R_TYPE_call: case R_TYPE_promise: return r_call2(quote_prim, x); default: return x; } } static inline bool is_node(r_obj* x) { switch (r_typeof(x)) { case R_TYPE_call: case R_TYPE_pairlist: return true; default: return false; } } r_obj* r_call_clone(r_obj* x) { if (!is_node(x)) { r_abort("Input must be a call."); } x = KEEP(r_clone(x)); r_obj* rest = x; while (rest != r_null) { r_obj* head = r_node_car(rest); if (is_node(head)) { r_node_poke_car(rest, r_call_clone(head)); } rest = r_node_cdr(rest); } FREE(1); return x; } void r_init_library_call(void) { quote_prim = r_base_ns_get("quote"); } lobstr/src/rlang/df.c0000644000176200001440000000271515163457235014226 0ustar liggesusers#include "rlang.h" #include "decl/df-decl.h" r_obj* r_alloc_df_list(r_ssize n_rows, r_obj* names, const enum r_type* v_types, r_ssize types_size) { r_obj* out = KEEP(r_alloc_list(types_size)); if (r_typeof(names) != R_TYPE_character) { r_abort("`names` must be a character vector."); } if (r_length(names) != types_size) { r_abort("`names` must match the number of columns."); } r_attrib_poke_names(out, names); for (r_ssize i = 0; i < types_size; ++i) { // A nil type stands for no column allocation enum r_type type = v_types[i]; if (type != R_TYPE_null) { r_obj* col = r_alloc_vector(type, n_rows); r_list_poke(out, i, col); } } FREE(1); return out; } void r_init_data_frame(r_obj* x, r_ssize n_rows) { init_compact_rownames(x, n_rows); r_attrib_poke(x, r_syms.class_, r_classes.data_frame); } void r_init_tibble(r_obj* x, r_ssize n_rows) { r_init_data_frame(x, n_rows); r_attrib_poke(x, r_syms.class_, r_classes.tibble); } static void init_compact_rownames(r_obj* x, r_ssize n_rows) { r_obj* rn = KEEP(new_compact_rownames(n_rows)); r_attrib_poke(x, r_syms.row_names, rn); FREE(1); } static r_obj* new_compact_rownames(r_ssize n_rows) { if (n_rows <= 0) { return r_globals.empty_int; } r_obj* out = r_alloc_integer(2); int* p_out = r_int_begin(out); p_out[0] = r_globals.na_int; p_out[1] = -n_rows; return out; } lobstr/src/rlang/c-utils.c0000644000176200001440000000103115163457235015203 0ustar liggesusers#include 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); } lobstr/src/rlang/walk.h0000644000176200001440000000745715163457235014610 0ustar liggesusers// IWYU pragma: private; include "rlang.h" #ifndef RLANG_INTERNAL_WALK_H #define RLANG_INTERNAL_WALK_H #include "rlang-types.h" #include "cnd.h" /** * Direction of iteration * * Each non-leaf node of the sexp tree is visited twice: First before * visiting the children, and again after the children have been * visited. See * about * this iteration process. * * There are three directions: * - Incoming: The first time a non-leaf node is visited. * - Leaf: After reaching a leaf node, the direction changes from * incoming to outgoing. * - Outgoing: The second time a non-leaf node is visited on the way back. */ enum r_sexp_it_direction { R_SEXP_IT_DIRECTION_leaf = 0, R_SEXP_IT_DIRECTION_incoming, R_SEXP_IT_DIRECTION_outgoing }; enum r_sexp_it_relation { R_SEXP_IT_RELATION_none = -1, R_SEXP_IT_RELATION_root = 0, R_SEXP_IT_RELATION_attrib, // Nodes R_SEXP_IT_RELATION_node_car, R_SEXP_IT_RELATION_node_cdr, R_SEXP_IT_RELATION_node_tag, R_SEXP_IT_RELATION_symbol_string, R_SEXP_IT_RELATION_symbol_value, R_SEXP_IT_RELATION_symbol_internal, R_SEXP_IT_RELATION_function_fmls, R_SEXP_IT_RELATION_function_body, R_SEXP_IT_RELATION_function_env, R_SEXP_IT_RELATION_environment_frame, R_SEXP_IT_RELATION_environment_enclos, R_SEXP_IT_RELATION_environment_hashtab, R_SEXP_IT_RELATION_promise_value, R_SEXP_IT_RELATION_promise_expr, R_SEXP_IT_RELATION_promise_env, R_SEXP_IT_RELATION_pointer_prot, R_SEXP_IT_RELATION_pointer_tag, // Vectors R_SEXP_IT_RELATION_list_elt, R_SEXP_IT_RELATION_character_elt, R_SEXP_IT_RELATION_expression_elt }; enum r_sexp_it_raw_relation { R_SEXP_IT_RAW_RELATION_root = 0, R_SEXP_IT_RAW_RELATION_attrib, R_SEXP_IT_RAW_RELATION_node_tag, R_SEXP_IT_RAW_RELATION_node_car, R_SEXP_IT_RAW_RELATION_node_cdr, R_SEXP_IT_RAW_RELATION_vector_elt }; struct r_sexp_iterator { r_obj* shelter; bool skip_incoming; r_obj* x; enum r_type type; int depth; r_obj* parent; enum r_sexp_it_relation rel; r_ssize i; enum r_sexp_it_direction dir; /* private: */ struct r_dyn_array* p_stack; }; struct r_sexp_iterator* r_new_sexp_iterator(r_obj* root); bool r_sexp_next(struct r_sexp_iterator* p_it); bool r_sexp_skip(struct r_sexp_iterator* p_it); static inline enum r_sexp_it_raw_relation r_sexp_it_raw_relation(enum r_sexp_it_relation rel) { switch (rel) { case R_SEXP_IT_RELATION_root: return R_SEXP_IT_RAW_RELATION_root; case R_SEXP_IT_RELATION_attrib: return R_SEXP_IT_RAW_RELATION_attrib; case R_SEXP_IT_RELATION_node_car: case R_SEXP_IT_RELATION_symbol_string: case R_SEXP_IT_RELATION_environment_frame: case R_SEXP_IT_RELATION_function_fmls: case R_SEXP_IT_RELATION_promise_value: return R_SEXP_IT_RAW_RELATION_node_car; case R_SEXP_IT_RELATION_node_cdr: case R_SEXP_IT_RELATION_symbol_value: case R_SEXP_IT_RELATION_environment_enclos: case R_SEXP_IT_RELATION_function_body: case R_SEXP_IT_RELATION_promise_expr: case R_SEXP_IT_RELATION_pointer_prot: return R_SEXP_IT_RAW_RELATION_node_cdr; case R_SEXP_IT_RELATION_node_tag: case R_SEXP_IT_RELATION_symbol_internal: case R_SEXP_IT_RELATION_environment_hashtab: case R_SEXP_IT_RELATION_function_env: case R_SEXP_IT_RELATION_promise_env: case R_SEXP_IT_RELATION_pointer_tag: return R_SEXP_IT_RAW_RELATION_node_tag; case R_SEXP_IT_RELATION_list_elt: case R_SEXP_IT_RELATION_character_elt: case R_SEXP_IT_RELATION_expression_elt: return R_SEXP_IT_RAW_RELATION_vector_elt; default: r_abort("Unimplemented type."); } } const char* r_sexp_it_direction_as_c_string(enum r_sexp_it_direction dir); const char* r_sexp_it_relation_as_c_string(enum r_sexp_it_relation rel); const char* r_sexp_it_raw_relation_as_c_string(enum r_sexp_it_raw_relation rel); #endif lobstr/src/rlang/globals.h0000644000176200001440000000361715163457235015267 0ustar liggesusers// IWYU pragma: private; include "rlang.h" #ifndef RLANG_GLOBALS_H #define RLANG_GLOBALS_H #include "rlang-types.h" struct r_globals { r_obj* empty_lgl; r_obj* empty_int; r_obj* empty_dbl; r_obj* empty_cpl; r_obj* empty_raw; r_obj* empty_chr; r_obj* empty_list; int na_lgl; int na_int; double na_dbl; r_complex na_cpl; r_obj* na_str; }; struct r_globals_chrs { r_obj* empty_string; r_obj* full; }; struct r_globals_classes { r_obj* data_frame; r_obj* tibble; }; struct r_globals_strs { r_obj* dots; r_obj* condition; r_obj* empty; r_obj* error; r_obj* interrupt; r_obj* message; r_obj* na; r_obj* warning; }; struct r_globals_syms { r_obj* abort; r_obj* arg; r_obj* brace; r_obj* brackets; r_obj* brackets2; r_obj* call; // `_` is required to avoid conflicts with the C++ keyword `class`. // See https://github.com/r-lib/rlang/pull/1359 for details. r_obj* class_; r_obj* condition; r_obj* dots; r_obj* dot_environment; r_obj* dot_fn; r_obj* dot_x; r_obj* dot_y; r_obj* error; r_obj* error_arg; r_obj* error_call; r_obj* error_call_flag; r_obj* expr; r_obj* function; r_obj* interrupt; r_obj* message; r_obj* missing; r_obj* names; r_obj* options; r_obj* colon2; r_obj* colon3; r_obj* srcfile; r_obj* srcref; r_obj* dim; r_obj* dim_names; r_obj* row_names; r_obj* stack_overflow_error; r_obj* tilde; r_obj* w; r_obj* warning; r_obj* wholeSrcref; r_obj* x; r_obj* y; r_obj* z; }; struct r_globals_envs { r_obj* empty; r_obj* base; r_obj* global; r_obj* ns; // The namespace of the embedding package }; extern struct r_globals r_globals; extern struct r_globals_chrs r_chrs; extern struct r_globals_classes r_classes; extern struct r_globals_strs r_strs; extern struct r_globals_syms r_syms; extern struct r_globals_envs r_envs; extern r_obj* r_true; extern r_obj* r_false; #endif lobstr/src/rlang/walk.c0000644000176200001440000003134015163457235014567 0ustar liggesusers#include #include "walk.h" #define SEXP_STACK_INIT_SIZE 256 enum sexp_iterator_type { SEXP_ITERATOR_TYPE_node, SEXP_ITERATOR_TYPE_pointer, SEXP_ITERATOR_TYPE_vector, SEXP_ITERATOR_TYPE_atomic }; enum sexp_iterator_state { SEXP_ITERATOR_STATE_done, SEXP_ITERATOR_STATE_attrib, SEXP_ITERATOR_STATE_tag, SEXP_ITERATOR_STATE_car, SEXP_ITERATOR_STATE_cdr, SEXP_ITERATOR_STATE_elt }; struct sexp_stack_info { r_obj* x; enum r_type type; const enum sexp_iterator_state* p_state; r_obj* const * v_arr; r_obj* const * v_arr_end; int depth; r_obj* parent; enum r_sexp_it_relation rel; enum r_sexp_it_direction dir; }; #include "decl/walk-decl.h" static const enum sexp_iterator_state node_states[] = { SEXP_ITERATOR_STATE_attrib, SEXP_ITERATOR_STATE_tag, SEXP_ITERATOR_STATE_car, SEXP_ITERATOR_STATE_cdr, SEXP_ITERATOR_STATE_done }; static const enum sexp_iterator_state pointer_states[] = { SEXP_ITERATOR_STATE_attrib, SEXP_ITERATOR_STATE_tag, SEXP_ITERATOR_STATE_cdr, SEXP_ITERATOR_STATE_done }; static const enum sexp_iterator_state vector_states[] = { SEXP_ITERATOR_STATE_attrib, SEXP_ITERATOR_STATE_elt, SEXP_ITERATOR_STATE_done }; static const enum sexp_iterator_state structure_states[] = { SEXP_ITERATOR_STATE_attrib, SEXP_ITERATOR_STATE_done }; static const enum sexp_iterator_state done_state[] = { SEXP_ITERATOR_STATE_done }; struct r_sexp_iterator* r_new_sexp_iterator(r_obj* root) { r_obj* shelter = KEEP(r_alloc_list(3)); r_obj* it = r_alloc_raw(sizeof(struct r_sexp_iterator)); r_list_poke(shelter, 0, it); struct r_sexp_iterator* p_it = r_raw_begin(it); struct r_dyn_array* p_stack = r_new_dyn_array(sizeof(struct sexp_stack_info), SEXP_STACK_INIT_SIZE); r_list_poke(shelter, 1, p_stack->shelter); // Slot 2 holds a pairlist chain of collected attribute pairlists // that need protection for the lifetime of the iterator enum r_type type = r_typeof(root); enum sexp_iterator_type it_type = sexp_iterator_type(type, root); bool has_attrib = sexp_has_attrib(type, root); struct sexp_stack_info root_info = { .x = root, .type = type, .depth = -1, .parent = r_null, .rel = R_SEXP_IT_RELATION_root }; if (it_type == SEXP_ITERATOR_TYPE_atomic && !has_attrib) { root_info.p_state = NULL; root_info.dir = R_SEXP_IT_DIRECTION_leaf; } else { init_incoming_stack_info(&root_info, it_type, has_attrib); } r_dyn_push_back(p_stack, &root_info); *p_it = (struct r_sexp_iterator) { .shelter = shelter, .p_stack = p_stack, .x = r_null, .parent = r_null, }; FREE(1); return p_it; } /* * An incoming node has a state indicating which edge we're at. An * outgoing node just need to be visited again and then popped. A * leaf node is just visited once and then popped. */ bool r_sexp_next(struct r_sexp_iterator* p_it) { struct r_dyn_array* p_stack = p_it->p_stack; if (!p_stack->count) { return false; } struct sexp_stack_info* p_info = (struct sexp_stack_info*) r_dyn_last(p_stack); if (p_it->skip_incoming) { p_it->skip_incoming = false; if (p_it->dir == R_SEXP_IT_DIRECTION_incoming) { r_dyn_pop_back(p_stack); return r_sexp_next(p_it); } } // In the normal case, if we push an "incoming" node on the stack it // means that we have already visited it and we are now visiting its // children. The root node is signalled with a depth of -1 so it can // be visited first before being visited as an incoming node. bool root = (p_info->depth == -1); if (!root && p_info->dir == R_SEXP_IT_DIRECTION_incoming) { return sexp_next_incoming(p_it, p_info); } r_ssize i = -1; if (p_info->v_arr) { i = p_info->v_arr_end - p_info->v_arr; } p_it->x = p_info->x; p_it->type = p_info->type; p_it->depth = p_info->depth; p_it->parent = p_info->parent; p_it->rel = p_info->rel; p_it->i = i; p_it->dir = p_info->dir; if (root) { ++p_it->depth; ++p_info->depth; // Incoming visit for the root node if (p_it->dir == R_SEXP_IT_DIRECTION_incoming) { return true; } } r_dyn_pop_back(p_stack); return true; } static bool sexp_next_incoming(struct r_sexp_iterator* p_it, struct sexp_stack_info* p_info) { enum sexp_iterator_state state = *p_info->p_state; r_obj* x = p_info->x; enum r_type type = p_info->type; struct sexp_stack_info child = { 0 }; child.parent = x; child.depth = p_info->depth + 1; switch (state) { case SEXP_ITERATOR_STATE_attrib: { // Allocates a new pairlist to avoid direct ATTRIB() access. // Could use R_mapAttrib() instead but would require refactoring. r_obj* collected = r_attrib_collect(x); // Protect collected pairlist in the iterator's shelter chain r_obj* chain = r_new_node(collected, r_list_get(p_it->shelter, 2)); r_list_poke(p_it->shelter, 2, chain); child.x = collected; child.rel = R_SEXP_IT_RELATION_attrib; break; } case SEXP_ITERATOR_STATE_elt: child.x = *p_info->v_arr; child.rel = R_SEXP_IT_RELATION_list_elt; break; case SEXP_ITERATOR_STATE_tag: child.x = sexp_node_tag(type, x, &child.rel); break; case SEXP_ITERATOR_STATE_car: child.x = sexp_node_car(type, x, &child.rel); break; case SEXP_ITERATOR_STATE_cdr: child.x = sexp_node_cdr(type, x, &child.rel); break; case SEXP_ITERATOR_STATE_done: r_stop_unreachable(); } child.type = r_typeof(child.x); bool has_attrib = sexp_has_attrib(child.type, child.x); enum sexp_iterator_type it_type = sexp_iterator_type(child.type, child.x); if (it_type == SEXP_ITERATOR_TYPE_atomic && !has_attrib) { child.p_state = NULL; child.dir = R_SEXP_IT_DIRECTION_leaf; } else { init_incoming_stack_info(&child, it_type, has_attrib); // Push incoming node on the stack so it can be visited again, // either to descend its children or to visit it again on the // outgoing trip r_dyn_push_back(p_it->p_stack, &child); } // Bump state for next iteration if (state == SEXP_ITERATOR_STATE_elt) { ++p_info->v_arr; if (p_info->v_arr == p_info->v_arr_end) { p_info->p_state = done_state; } } else { ++p_info->p_state; } // Flip incoming to outgoing if we're done visiting children after // this iteration. We don't leave a done node on the stack because // that would break the invariant that there are remaining nodes to // visit when `n > 0` and that the stack can be popped. if (*p_info->p_state == SEXP_ITERATOR_STATE_done) { p_info->dir = R_SEXP_IT_DIRECTION_outgoing; } r_ssize i = -1; if (child.v_arr) { i = child.v_arr_end - child.v_arr; } p_it->x = child.x; p_it->type = child.type; p_it->depth = child.depth; p_it->parent = child.parent; p_it->rel = child.rel; p_it->i = i; p_it->dir = child.dir; return true; } static inline void init_incoming_stack_info(struct sexp_stack_info* p_info, enum sexp_iterator_type it_type, bool has_attrib) { p_info->dir = R_SEXP_IT_DIRECTION_incoming; switch (it_type) { case SEXP_ITERATOR_TYPE_atomic: p_info->p_state = structure_states; break; case SEXP_ITERATOR_TYPE_node: p_info->p_state = node_states + !has_attrib; break; case SEXP_ITERATOR_TYPE_pointer: p_info->p_state = pointer_states + !has_attrib; break; case SEXP_ITERATOR_TYPE_vector: p_info->v_arr = r_vec_cbegin(p_info->x); p_info->v_arr_end = p_info->v_arr + r_length(p_info->x); p_info->p_state = vector_states + !has_attrib; break; } } static inline enum sexp_iterator_type sexp_iterator_type(enum r_type type, r_obj* x) { switch (type) { case R_TYPE_closure: case R_TYPE_environment: case R_TYPE_promise: case R_TYPE_pairlist: case R_TYPE_call: case R_TYPE_dots: return SEXP_ITERATOR_TYPE_node; case R_TYPE_pointer: return SEXP_ITERATOR_TYPE_pointer; case R_TYPE_list: case R_TYPE_expression: case R_TYPE_character: if (r_length(x)) { return SEXP_ITERATOR_TYPE_vector; } else { return SEXP_ITERATOR_TYPE_atomic; } default: return SEXP_ITERATOR_TYPE_atomic; } } static inline bool sexp_has_attrib(enum r_type type, r_obj* x) { // Strings have private data stored in attributes if (type == R_TYPE_string) { return false; } else { return r_attrib_has_any(x); } } static inline r_obj* sexp_node_car(enum r_type type, r_obj* x, enum r_sexp_it_relation* p_rel) { switch (type) { case R_TYPE_closure: *p_rel = R_SEXP_IT_RELATION_function_fmls; return r_fn_formals(x); case R_TYPE_environment: *p_rel = R_SEXP_IT_RELATION_environment_frame; return FRAME(x); case R_TYPE_promise: *p_rel = R_SEXP_IT_RELATION_promise_value; return PRVALUE(x); case R_TYPE_pairlist: case R_TYPE_call: case R_TYPE_dots: *p_rel = R_SEXP_IT_RELATION_node_car; return CAR(x); case R_TYPE_pointer: default: *p_rel = -1; return r_null; } } static inline r_obj* sexp_node_cdr(enum r_type type, r_obj* x, enum r_sexp_it_relation* p_rel) { switch (type) { case R_TYPE_closure: *p_rel = R_SEXP_IT_RELATION_function_body; return r_fn_body(x); case R_TYPE_environment: *p_rel = R_SEXP_IT_RELATION_environment_enclos; return r_env_parent(x); case R_TYPE_promise: *p_rel = R_SEXP_IT_RELATION_promise_expr; return PREXPR(x); case R_TYPE_pointer: *p_rel = R_SEXP_IT_RELATION_pointer_prot; return EXTPTR_PROT(x); case R_TYPE_pairlist: case R_TYPE_call: case R_TYPE_dots: *p_rel = R_SEXP_IT_RELATION_node_cdr; return CDR(x); default: *p_rel = -1; return r_null; } } static inline r_obj* sexp_node_tag(enum r_type type, r_obj* x, enum r_sexp_it_relation* p_rel) { switch (type) { case R_TYPE_closure: *p_rel = R_SEXP_IT_RELATION_function_env; return r_fn_env(x); case R_TYPE_environment: *p_rel = R_SEXP_IT_RELATION_environment_hashtab; return HASHTAB(x); case R_TYPE_promise: *p_rel = R_SEXP_IT_RELATION_promise_env; return PRENV(x); case R_TYPE_pointer: *p_rel = R_SEXP_IT_RELATION_pointer_tag; return EXTPTR_TAG(x); case R_TYPE_pairlist: case R_TYPE_call: case R_TYPE_dots: *p_rel = R_SEXP_IT_RELATION_node_tag; return TAG(x); default: *p_rel = -1; return r_null; } } const char* r_sexp_it_direction_as_c_string(enum r_sexp_it_direction dir) { switch (dir) { case R_SEXP_IT_DIRECTION_leaf: return "leaf"; case R_SEXP_IT_DIRECTION_incoming: return "incoming"; case R_SEXP_IT_DIRECTION_outgoing: return "outgoing"; default: r_stop_unreachable(); } } const char* r_sexp_it_relation_as_c_string(enum r_sexp_it_relation rel) { switch (rel) { case R_SEXP_IT_RELATION_root: return "root"; case R_SEXP_IT_RELATION_attrib: return "attrib"; case R_SEXP_IT_RELATION_node_car: return "node_car"; case R_SEXP_IT_RELATION_node_cdr: return "node_cdr"; case R_SEXP_IT_RELATION_node_tag: return "node_tag"; case R_SEXP_IT_RELATION_symbol_string: return "symbol_string"; case R_SEXP_IT_RELATION_symbol_value: return "symbol_value"; case R_SEXP_IT_RELATION_symbol_internal: return "symbol_internal"; case R_SEXP_IT_RELATION_function_fmls: return "function_fmls"; case R_SEXP_IT_RELATION_function_body: return "function_body"; case R_SEXP_IT_RELATION_function_env: return "function_env"; case R_SEXP_IT_RELATION_environment_frame: return "environment_frame"; case R_SEXP_IT_RELATION_environment_enclos: return "environment_enclos"; case R_SEXP_IT_RELATION_environment_hashtab: return "environment_hashtab"; case R_SEXP_IT_RELATION_promise_value: return "promise_value"; case R_SEXP_IT_RELATION_promise_expr: return "promise_expr"; case R_SEXP_IT_RELATION_promise_env: return "promise_env"; case R_SEXP_IT_RELATION_pointer_prot: return "pointer_prot"; case R_SEXP_IT_RELATION_pointer_tag: return "pointer_tag"; case R_SEXP_IT_RELATION_list_elt: return "list_elt"; case R_SEXP_IT_RELATION_character_elt: return "character_elt"; case R_SEXP_IT_RELATION_expression_elt: return "expression_elt"; case R_SEXP_IT_RELATION_none: r_stop_internal("r_sexp_it_relation_as_c_string", "Found `R_SEXP_IT_RELATION_none`."); default: r_stop_unreachable(); } } const char* r_sexp_it_raw_relation_as_c_string(enum r_sexp_it_raw_relation rel) { switch (rel) { case R_SEXP_IT_RAW_RELATION_root: return "root"; case R_SEXP_IT_RAW_RELATION_attrib: return "attrib"; case R_SEXP_IT_RAW_RELATION_node_car: return "node_car"; case R_SEXP_IT_RAW_RELATION_node_cdr: return "node_cdr"; case R_SEXP_IT_RAW_RELATION_node_tag: return "node_tag"; case R_SEXP_IT_RAW_RELATION_vector_elt: return "vector_elt"; default: r_stop_unreachable(); } } lobstr/src/rlang/quo.c0000644000176200001440000000113215163457235014431 0ustar liggesusers#include "rlang.h" r_obj* (*r_quo_get_expr)(r_obj* quo); r_obj* (*r_quo_set_expr)(r_obj* quo, r_obj* expr); r_obj* (*r_quo_get_env)(r_obj* quo); r_obj* (*r_quo_set_env)(r_obj* quo, r_obj* env); void r_init_library_quo(void) { r_quo_get_expr = (r_obj* (*)(r_obj*)) r_peek_c_callable("rlang", "rlang_quo_get_expr"); r_quo_set_expr = (r_obj* (*)(r_obj*, r_obj*)) r_peek_c_callable("rlang", "rlang_quo_set_expr"); r_quo_get_env = (r_obj* (*)(r_obj*)) r_peek_c_callable("rlang", "rlang_quo_get_env"); r_quo_set_env = (r_obj* (*)(r_obj*, r_obj*)) r_peek_c_callable("rlang", "rlang_quo_set_env"); } lobstr/src/rlang/vec-chr.c0000644000176200001440000000356015163457235015163 0ustar liggesusers#include #include "rlang.h" r_ssize r_chr_detect_index(r_obj* chr, const char* c_string) { r_ssize n = r_length(chr); for (r_ssize i = 0; i != n; ++i) { const char* cur = CHAR(r_chr_get(chr, i)); if (strcmp(cur, c_string) == 0) { return i; } } return -1; } bool r_chr_has(r_obj* chr, const char* c_string) { r_ssize idx = r_chr_detect_index(chr, c_string); return idx >= 0; } bool r_chr_has_any(r_obj* chr, const char** c_strings) { r_ssize n = r_length(chr); for (r_ssize i = 0; i != n; ++i) { const char* cur = CHAR(r_chr_get(chr, i)); while (*c_strings) { if (strcmp(cur, *c_strings) == 0) { return true; } ++c_strings; } } return false; } void r_chr_fill(r_obj* chr, r_obj* value, r_ssize n) { for (r_ssize i = 0; i < n; ++i) { r_chr_poke(chr, i, value); } } static void validate_chr_setter(r_obj* chr, r_obj* r_string) { if (r_typeof(chr) != R_TYPE_character) { r_abort("`chr` must be a character vector"); } if (r_typeof(r_string) != R_TYPE_string) { r_abort("`r_string` must be an internal R string"); } } // From rlang/vec.c void r_vec_poke_n(r_obj* x, r_ssize offset, r_obj* y, r_ssize from, r_ssize n); r_obj* chr_prepend(r_obj* chr, r_obj* r_string) { if (chr == r_null) { return r_str_as_character(r_string); } else { validate_chr_setter(chr, r_string); } int n = r_length(chr); r_obj* out = KEEP(r_alloc_character(n + 1)); r_vec_poke_n(out, 1, chr, 0, n); r_chr_poke(out, 0, r_string); FREE(1); return out; } r_obj* chr_append(r_obj* chr, r_obj* r_str) { if (chr == r_null) { return r_str_as_character(r_str); } validate_chr_setter(chr, r_str); int n = r_length(chr); r_obj* out = KEEP(r_alloc_character(n + 1)); r_vec_poke_n(out, 0, chr, 0, n); r_chr_poke(out, n, r_str); FREE(1); return out; } lobstr/src/rlang/formula.h0000644000176200001440000000043515163457235015304 0ustar liggesusers// IWYU pragma: private; include "rlang.h" #ifndef RLANG_FORMULA_H #define RLANG_FORMULA_H #include "rlang-types.h" bool r_is_formula(r_obj* x, int scoped, int lhs); r_obj* r_f_rhs(r_obj* f); r_obj* r_f_lhs(r_obj* f); r_obj* r_f_env(r_obj* f); bool r_f_has_env(r_obj* f); #endif lobstr/src/rlang/state.h0000644000176200001440000000107215163457235014755 0ustar liggesusers// IWYU pragma: private; include "rlang.h" #ifndef RLANG_STATE_H #define RLANG_STATE_H #include "call.h" #include "eval.h" #include "globals.h" #include "node.h" #include "rlang-types.h" #include "sym.h" static inline r_obj* r_peek_option(const char* name) { return Rf_GetOption1(Rf_install(name)); } static inline void r_poke_option(const char* name, r_obj* value) { r_obj* args = KEEP(r_new_node(value, r_null)); r_node_poke_tag(args, r_sym(name)); r_obj* call = KEEP(r_new_call(r_syms.options, args)); r_eval(call, r_envs.base); FREE(2); } #endif lobstr/src/rlang/vec.c0000644000176200001440000002032615163457235014410 0ustar liggesusers#include "rlang.h" #include #include r_obj* r_chr_n(const char* const * strings, r_ssize n) { r_obj* out = KEEP(r_alloc_character(n)); for (r_ssize i = 0; i < n; ++i) { r_chr_poke(out, i, r_str(strings[i])); } FREE(1); return out; } #define RESIZE(R_TYPE, C_TYPE, CONST_DEREF, DEREF) \ do { \ r_ssize old_size = r_length(x); \ if (old_size == new_size) { \ return x; \ } \ if (!ALTREP(x) && new_size < old_size) { \ return vec_shrink(x, new_size, old_size); \ } \ \ const C_TYPE* p_x = CONST_DEREF(x); \ r_obj* out = KEEP(r_alloc_vector(R_TYPE, new_size)); \ C_TYPE* p_out = DEREF(out); \ \ r_ssize cpy_size = (new_size > old_size) ? old_size : new_size; \ r_memcpy(p_out, p_x, cpy_size * sizeof(C_TYPE)); \ \ FREE(1); \ return out; \ } while (0) #define RESIZE_BARRIER(R_TYPE, CONST_DEREF, SET) \ do { \ r_ssize old_size = r_length(x); \ if (old_size == new_size) { \ return x; \ } \ if (!ALTREP(x) && new_size < old_size) { \ return vec_shrink(x, new_size, old_size); \ } \ \ r_obj* const * p_x = CONST_DEREF(x); \ r_obj* out = KEEP(r_alloc_vector(R_TYPE, new_size)); \ \ r_ssize cpy_size = (new_size > old_size) ? old_size : new_size; \ for (r_ssize i = 0; i < cpy_size; ++i) { \ SET(out, i, p_x[i]); \ } \ \ FREE(1); \ return out; \ } while (0) // Assumption on older R: `new_size` smaller than `old_size` static inline r_obj* vec_shrink(r_obj* x, r_ssize new_size, r_ssize old_size) { #if R_VERSION >= R_Version(4, 6, 0) if (R_isResizable(x)) { R_resizeVector(x, new_size); return x; } else { return Rf_xlengthgets(x, new_size); } #else SETLENGTH(x, new_size); SET_TRUELENGTH(x, old_size); SET_GROWABLE_BIT(x); return x; #endif } // Compared to `Rf_xlengthgets()` this does not initialise the new // extended locations with `NA` r_obj* r_lgl_resize(r_obj* x, r_ssize new_size) { RESIZE(R_TYPE_logical, int, r_lgl_cbegin, r_lgl_begin); } r_obj* r_int_resize(r_obj* x, r_ssize new_size) { RESIZE(R_TYPE_integer, int, r_int_cbegin, r_int_begin); } r_obj* r_dbl_resize(r_obj* x, r_ssize new_size) { RESIZE(R_TYPE_double, double, r_dbl_cbegin, r_dbl_begin); } r_obj* r_cpl_resize(r_obj* x, r_ssize new_size) { RESIZE(R_TYPE_complex, r_complex, r_cpl_cbegin, r_cpl_begin); } r_obj* r_raw_resize(r_obj* x, r_ssize new_size) { RESIZE(R_TYPE_raw, unsigned char, r_raw_cbegin, r_raw_begin); } r_obj* r_chr_resize(r_obj* x, r_ssize new_size) { RESIZE_BARRIER(R_TYPE_character, r_chr_cbegin, r_chr_poke); } r_obj* r_list_resize(r_obj* x, r_ssize new_size) { RESIZE_BARRIER(R_TYPE_list, r_list_cbegin, r_list_poke); } #undef RESIZE #undef RESIZE_BARRIER r_obj* r_list_compact(r_obj* x) { r_ssize n = r_length(x); r_obj* inc = KEEP(r_alloc_logical(n)); int* v_inc = r_int_begin(inc); r_obj* const * v_x = r_list_cbegin(x); r_ssize new_n = 0; for (r_ssize i = 0; i < n; ++i) { v_inc[i] = v_x[i] != r_null; new_n += v_inc[i]; } r_obj* out = KEEP(r_alloc_list(new_n)); for (r_ssize i = 0, count = 0; i < n; ++i) { if (v_inc[i]) { r_list_poke(out, count, v_x[i]); ++count; } } FREE(2); return out; } r_obj* r_list_of_as_ptr_ssize(r_obj* xs, enum r_type type, struct r_pair_ptr_ssize** p_v_out) { if (r_typeof(xs) != R_TYPE_list) { r_abort("`xs` must be a list."); } r_ssize n = r_length(xs); r_obj* shelter = KEEP(r_alloc_raw(sizeof(struct r_pair_ptr_ssize) * n)); struct r_pair_ptr_ssize* v_out = r_raw_begin(shelter); r_obj* const * v_xs = r_list_cbegin(xs); for (r_ssize i = 0; i < n; ++i) { r_obj* x = v_xs[i]; if (r_typeof(x) != type) { r_abort("`xs` must be a list of vectors of type `%s`.", r_type_as_c_string(type)); } v_out[i] = (struct r_pair_ptr_ssize) { .ptr = r_int_begin(x), .size = r_length(x) }; } FREE(1); *p_v_out = v_out; return shelter; } // FIXME: Does this have a place in the library? void r_vec_poke_n(r_obj* x, r_ssize offset, r_obj* y, r_ssize from, r_ssize n) { if ((r_length(x) - offset) < n) { r_abort("Can't copy data to `x` because it is too small"); } if ((r_length(y) - from) < n) { r_abort("Can't copy data from `y` because it is too small"); } switch (r_typeof(x)) { case R_TYPE_logical: { int* src_data = r_lgl_begin(y); int* dest_data = r_lgl_begin(x); for (r_ssize i = 0; i != n; ++i) dest_data[i + offset] = src_data[i + from]; break; } case R_TYPE_integer: { int* src_data = r_int_begin(y); int* dest_data = r_int_begin(x); for (r_ssize i = 0; i != n; ++i) dest_data[i + offset] = src_data[i + from]; break; } case R_TYPE_double: { double* src_data = r_dbl_begin(y); double* dest_data = r_dbl_begin(x); for (r_ssize i = 0; i != n; ++i) dest_data[i + offset] = src_data[i + from]; break; } case R_TYPE_complex: { r_complex* src_data = r_cpl_begin(y); r_complex* dest_data = r_cpl_begin(x); for (r_ssize i = 0; i != n; ++i) dest_data[i + offset] = src_data[i + from]; break; } case R_TYPE_raw: { unsigned char* src_data = RAW(y); unsigned char* dest_data = RAW(x); for (r_ssize i = 0; i != n; ++i) dest_data[i + offset] = src_data[i + from]; break; } case R_TYPE_character: { r_obj* elt; for (r_ssize i = 0; i != n; ++i) { elt = r_chr_get(y, i + from); r_chr_poke(x, i + offset, elt); } break; } case R_TYPE_list: { r_obj* elt; for (r_ssize i = 0; i != n; ++i) { elt = r_list_get(y, i + from); r_list_poke(x, i + offset, elt); } break; } default: r_abort("Copy requires vectors"); } } void r_vec_poke_range(r_obj* x, r_ssize offset, r_obj* y, r_ssize from, r_ssize to) { r_vec_poke_n(x, offset, y, from, to - from + 1); } bool _r_is_finite(r_obj* x) { r_ssize n = r_length(x); switch(r_typeof(x)) { case R_TYPE_integer: { const int* p_x = r_int_cbegin(x); for (r_ssize i = 0; i < n; ++i) { if (p_x[i] == r_globals.na_int) { return false; } } break; } case R_TYPE_double: { const double* p_x = r_dbl_cbegin(x); for (r_ssize i = 0; i < n; ++i) { if (!isfinite(p_x[i])) { return false; } } break; } case R_TYPE_complex: { const r_complex* p_x = r_cpl_cbegin(x); for (r_ssize i = 0; i < n; ++i) { if (!isfinite(p_x[i].r) || !isfinite(p_x[i].i)) { return false; } } break; } default: r_abort("Internal error: expected a numeric vector"); } return true; } lobstr/src/rlang/session.h0000644000176200001440000000032715163457235015322 0ustar liggesusers// IWYU pragma: private; include "rlang.h" #ifndef RLANG_SESSION_H #define RLANG_SESSION_H #include "rlang-types.h" bool r_is_installed(const char* pkg); bool r_has_colour(void); r_obj* r_getppid(void); #endif lobstr/src/rlang/export.h0000644000176200001440000000072215163457235015157 0ustar liggesusers// IWYU pragma: private; include "rlang.h" #ifndef RLANG_EXPORT_H #define RLANG_EXPORT_H #include "rlang-types.h" typedef DL_FUNC r_void_fn; static inline r_void_fn r_peek_c_callable(const char* pkg, const char* callable) { return R_GetCCallable(pkg, callable); } static inline r_obj* r_new_fn_ptr(r_void_fn p) { return R_MakeExternalPtrFn(p, r_null, r_null); } static inline r_void_fn r_fn_ptr_addr(r_obj* p) { return R_ExternalPtrAddrFn(p); } #endif lobstr/src/rlang/export.c0000644000176200001440000000046315163457235015154 0ustar liggesusers#include "rlang.h" #include "export.h" #include r_obj* rlang_namespace(const char* ns) { r_obj* ns_string = KEEP(Rf_mkString(ns)); r_obj* call = KEEP(r_sym("getNamespace")); call = KEEP(Rf_lang2(call, ns_string)); r_obj* ns_env = r_eval(call, R_BaseEnv); FREE(3); return ns_env; } lobstr/src/rlang/df.h0000644000176200001440000000060315163457235014225 0ustar liggesusers// IWYU pragma: private; include "rlang.h" #ifndef RLANG_DF_H #define RLANG_DF_H #include "rlang-types.h" r_obj* r_alloc_df_list(r_ssize n_rows, r_obj* names, const enum r_type* v_types, r_ssize types_size); void r_init_data_frame(r_obj* x, r_ssize n_nows); void r_init_tibble(r_obj* x, r_ssize n_rows); #endif lobstr/src/rlang/dict.c0000644000176200001440000002024515163457235014556 0ustar liggesusers#include #include "dict.h" #define DICT_LOAD_THRESHOLD 0.75 #define DICT_GROWTH_FACTOR 2 static size_t size_round_power_2(size_t size); #include "decl/dict-decl.h" #define DICT_DEREF(D) r_list_cbegin(D) #define DICT_KEY(V) r_list_get(V, 0) #define DICT_VALUE(V) r_list_get(V, 1) #define DICT_CDR(V) r_list_get(V, 2) #define DICT_POKE_KEY(D, K) r_list_poke(D, 0, K) #define DICT_POKE_VALUE(D, V) r_list_poke(D, 1, V) #define DICT_POKE_CDR(D, N) r_list_poke(D, 2, N) #define V_DICT_KEY(V) (V)[0] #define V_DICT_VALUE(V) (V)[1] #define V_DICT_CDR(V) (V)[2] static r_obj* new_dict_node(r_obj* key, r_obj* value) { r_obj* bucket = r_alloc_list(3); DICT_POKE_KEY(bucket, key); DICT_POKE_VALUE(bucket, value); return bucket; } struct r_dict* r_new_dict(r_ssize size) { if (size <= 0) { r_abort("`size` of dictionary must be positive."); } size = size_round_power_2(size); r_obj* shelter = KEEP(r_alloc_list(2)); r_obj* dict_raw = r_alloc_raw0(sizeof(struct r_dict)); r_list_poke(shelter, 0, dict_raw); struct r_dict* p_dict = r_raw_begin(dict_raw); p_dict->shelter = shelter; p_dict->buckets = r_alloc_list(size); r_list_poke(shelter, 1, p_dict->buckets); p_dict->p_buckets = r_list_cbegin(p_dict->buckets); p_dict->n_buckets = size; r_attrib_poke(shelter, r_syms.class_, r_chr("rlang_dict")); FREE(1); return p_dict; } void r_dict_resize(struct r_dict* p_dict, r_ssize size) { if (size < 0) { size = p_dict->n_buckets * DICT_GROWTH_FACTOR; } struct r_dict* p_new_dict = r_new_dict(size); KEEP(p_new_dict->shelter); r_ssize n = r_length(p_dict->buckets); r_obj* const * p_buckets = p_dict->p_buckets; for (r_ssize i = 0; i < n; ++i) { r_obj* bucket = p_buckets[i]; while (bucket != r_null) { r_obj* const * v_bucket = DICT_DEREF(bucket); r_obj* key = V_DICT_KEY(v_bucket); r_obj* value = V_DICT_VALUE(v_bucket); r_dict_put(p_new_dict, key, value); bucket = V_DICT_CDR(v_bucket); } } // Update all data in place except the shelter and the raw sexp // which must stay validly protected by the callers r_obj* old_shelter = p_dict->shelter; r_list_poke(old_shelter, 1, r_list_get(p_new_dict->shelter, 1)); r_memcpy(p_dict, p_new_dict, sizeof(*p_dict)); p_dict->shelter = old_shelter; FREE(1); } static size_t size_round_power_2(size_t size) { size_t out = 1; while (out < size) { out <<= 1; } return out; } static r_ssize dict_hash(const struct r_dict* p_dict, r_obj* key) { uint64_t hash = r_xxh3_64bits(&key, sizeof(r_obj*)); return hash % p_dict->n_buckets; } // Returns previous value of `key` if it existed or a C `NULL` r_obj* r_dict_poke(struct r_dict* p_dict, r_obj* key, r_obj* value) { r_ssize hash; r_obj* parent; r_obj* node = dict_find_node_info(p_dict, key, &hash, &parent); if (node != r_null) { r_obj* old = DICT_VALUE(node); DICT_POKE_VALUE(node, value); return old; } else { dict_push(p_dict, hash, parent, key, value); return NULL; } } // Returns `false` if `key` already exists in the dictionary, `true` // otherwise bool r_dict_put(struct r_dict* p_dict, r_obj* key, r_obj* value) { r_ssize hash; r_obj* parent; r_obj* node = dict_find_node_info(p_dict, key, &hash, &parent); if (node != r_null) { return false; } else { dict_push(p_dict, hash, parent, key, value); return true; } } static void dict_push(struct r_dict* p_dict, r_ssize hash, r_obj* parent, r_obj* key, r_obj* value) { r_obj* node = KEEP(new_dict_node(key, value)); if (parent == r_null) { // Empty bucket r_list_poke(p_dict->buckets, hash, node); } else { DICT_POKE_CDR(parent, node); } ++p_dict->n_entries; float load = (float) p_dict->n_entries / (float) p_dict->n_buckets; if (!p_dict->prevent_resize && load > DICT_LOAD_THRESHOLD) { r_dict_resize(p_dict, -1); } FREE(1); } // Returns `true` if key existed and was deleted. Returns `false` if // the key could not be deleted because it did not exist in the dict. bool r_dict_del(struct r_dict* p_dict, r_obj* key) { r_ssize hash; r_obj* parent; r_obj* node = dict_find_node_info(p_dict, key, &hash, &parent); if (node == r_null) { return false; } r_obj* node_cdr = DICT_CDR(node); if (parent == r_null) { r_list_poke(p_dict->buckets, hash, node_cdr); } else { DICT_POKE_CDR(parent, node_cdr); } return true; } bool r_dict_has(struct r_dict* p_dict, r_obj* key) { return dict_find_node(p_dict, key) != r_null; } r_obj* r_dict_get(struct r_dict* p_dict, r_obj* key) { r_obj* out = r_dict_get0(p_dict, key); if (!out) { r_abort("Can't find key in dictionary."); } return out; } /* The 0-suffixed variant returns a C `NULL` if the object doesn't exist. The regular variant throws an error in that case. */ r_obj* r_dict_get0(struct r_dict* p_dict, r_obj* key) { r_obj* node = dict_find_node(p_dict, key); if (node == r_null) { return NULL; } else { return DICT_VALUE(node); } } static r_obj* dict_find_node(struct r_dict* p_dict, r_obj* key) { r_ssize i = dict_hash(p_dict, key); r_obj* bucket = p_dict->p_buckets[i]; while (bucket != r_null) { r_obj* const * v_bucket = DICT_DEREF(bucket); if (V_DICT_KEY(v_bucket) == key) { return bucket; } bucket = V_DICT_CDR(v_bucket); } return r_null; } // Also returns hash and parent node if any static r_obj* dict_find_node_info(struct r_dict* p_dict, r_obj* key, r_ssize* hash, r_obj** parent) { r_ssize i = dict_hash(p_dict, key); *hash = i; r_obj* bucket = p_dict->p_buckets[i]; *parent = r_null; while (bucket != r_null) { r_obj* const * v_bucket = DICT_DEREF(bucket); if (V_DICT_KEY(v_bucket) == key) { return bucket; } *parent = bucket; bucket = V_DICT_CDR(v_bucket); } return r_null; } struct r_dict_iterator* r_new_dict_iterator(struct r_dict* p_dict) { r_obj* shelter = r_alloc_raw(sizeof(struct r_dict_iterator)); struct r_dict_iterator* p_it = r_raw_begin(shelter); p_it->shelter = shelter; p_it->key = r_null; p_it->value = r_null; p_it->i = 0; p_it->n = p_dict->n_buckets; p_it->v_buckets = p_dict->p_buckets; if (p_it->n == 0) { r_stop_internal("Empty dictionary."); } p_it->node = p_it->v_buckets[0]; return p_it; } bool r_dict_next(struct r_dict_iterator* p_it) { if (p_it->v_buckets == NULL) { return false; } r_obj* node = p_it->node; while (node == r_null) { r_ssize i = ++p_it->i; if (i >= p_it->n) { p_it->v_buckets = NULL; return false; } node = p_it->v_buckets[i]; p_it->node = node; } r_obj* const * v_node = DICT_DEREF(node); p_it->key = V_DICT_KEY(v_node); p_it->value = V_DICT_VALUE(v_node); p_it->node = V_DICT_CDR(v_node); return true; } static const char* v_dict_it_df_names_c_strings[] = { "key", "value" }; static const enum r_type v_dict_it_df_types[] = { R_TYPE_list, R_TYPE_list }; enum dict_it_df_locs { DICT_IT_DF_LOCS_key, DICT_IT_DF_LOCS_value }; #define DICT_IT_DF_SIZE R_ARR_SIZEOF(v_dict_it_df_types) r_obj* r_dict_as_df_list(struct r_dict* p_dict) { r_obj* nms = KEEP(r_chr_n(v_dict_it_df_names_c_strings, DICT_IT_DF_SIZE)); r_obj* out = KEEP(r_alloc_df_list(p_dict->n_entries, nms, v_dict_it_df_types, DICT_IT_DF_SIZE)); r_obj* key = r_list_get(out, DICT_IT_DF_LOCS_key); r_obj* value = r_list_get(out, DICT_IT_DF_LOCS_value); struct r_dict_iterator* p_it = r_new_dict_iterator(p_dict); KEEP(p_it->shelter); for (r_ssize i = 0; r_dict_next(p_it); ++i) { r_list_poke(key, i, p_it->key); r_list_poke(value, i, p_it->value); } FREE(3); return out; } r_obj* r_dict_as_list(struct r_dict* p_dict) { r_obj* out = KEEP(r_alloc_list(p_dict->n_entries)); struct r_dict_iterator* p_it = r_new_dict_iterator(p_dict); KEEP(p_it->shelter); for (r_ssize i = 0; r_dict_next(p_it); ++i) { r_list_poke(out, i, p_it->value); } FREE(2); return out; } lobstr/src/rlang/rlang.c0000644000176200001440000000611215163457235014733 0ustar liggesusers#include #include #include "arg.c" #include "attrib.c" #include "call.c" #include "cnd.c" #include "c-utils.c" #include "debug.c" #include "dict.c" #include "df.c" #include "dots-info.c" #include "dyn-array.c" #include "dyn-list-of.c" #include "env.c" #include "env-binding.c" #include "eval.c" #include "export.c" #include "fn.c" #include "formula.c" #include "globals.c" #include "node.c" #include "obj.c" #include "parse.c" #include "quo.c" #include "session.c" #include "stack.c" #include "sym.c" #include "vec.c" #include "vec-chr.c" #include "vec-lgl.c" #include "vendor.c" #ifdef RLANG_USE_PRIVATE_ACCESSORS #include "walk.c" #endif // Allows long vectors to be indexed with doubles r_ssize r_arg_as_ssize(r_obj* n, const char* arg) { switch (r_typeof(n)) { case R_TYPE_double: { if (r_length(n) != 1) { goto invalid; } double out = r_dbl_get(n, 0); if (out > R_SSIZE_MAX) { r_abort("`%s` is too large a number.", arg); } if (out != (int_least64_t) out) { r_abort("`%s` must be a whole number, not a decimal number.", arg); } return (r_ssize) floor(out); } case R_TYPE_integer: { if (r_length(n) != 1) { goto invalid; } return (r_ssize) r_int_get(n, 0); } invalid: default: r_abort("`%s` must be a scalar integer or double.", arg); } } static r_obj* shared_x_env; static r_obj* shared_xy_env; static r_obj* shared_xyz_env; // This *must* be called before making any calls to the functions // provided in the library. Register this function in your init file // and `.Call()` it from your `.onLoad()` hook. r_obj* r_init_library(r_obj* ns) { if (!R_IsNamespaceEnv(ns)) { Rf_errorcall(r_null, "Can't initialise rlang library.\n" "x `ns` must be a namespace environment."); } // Local precious lists are disabled by default because rchk // requires the base precious list and we don't want to // double-preserve. Still enable it on CI to get that part of the // code tested. _r_use_local_precious_list = getenv("RLIB_USE_LOCAL_PRECIOUS_LIST") || getenv("CI"); // Need to be first r_init_library_vendor(); // Needed for xxh used in `r_preserve()` r_init_library_globals_syms(); r_init_library_obj(ns); r_init_library_globals(ns); shared_x_env = r_parse_eval("new.env(hash = FALSE, parent = baseenv(), size = 1L)", r_envs.base); r_preserve(shared_x_env); shared_xy_env = r_parse_eval("new.env(hash = FALSE, parent = baseenv(), size = 1L)", r_envs.base); r_preserve(shared_xy_env); shared_xyz_env = r_parse_eval("new.env(hash = FALSE, parent = baseenv(), size = 1L)", r_envs.base); r_preserve(shared_xyz_env); r_init_library_sym(); r_init_library_eval(); r_init_library_env(); r_init_rlang_ns_env(); r_init_library_arg(); r_init_library_call(); r_init_library_cnd(); r_init_library_dyn_array(); r_init_library_fn(); r_init_library_quo(); r_init_library_session(); r_init_library_stack(); // Return a SEXP so the init function can be called from R return r_null; } bool _r_use_local_precious_list = false; lobstr/src/rlang/rlang-types.h0000644000176200001440000000767315163457235016117 0ustar liggesusers// IWYU pragma: private; include "rlang.h" #ifndef RLANG_RLANG_TYPES_H #define RLANG_RLANG_TYPES_H #define R_NO_REMAP #include // IWYU pragma: export #include // IWYU pragma: export #include // IWYU pragma: export #include // IWYU pragma: export // Use `r_visible` to mark your init function. Then users can compile // with `-fvisibility=hidden -DHAVE_VISIBILITY_ATTRIBUTE` to link to // your library (as opposed to dynamically loading it) without risking // symbol clashes. #define r_visible attribute_visible extern #ifdef __GNUC__ # define r_unused __attribute__ ((unused)) #else # define r_unused #endif #define r_no_return __attribute__ ((noreturn)) typedef struct SEXPREC r_obj; typedef Rcomplex r_complex; typedef R_xlen_t r_ssize; #define R_SSIZE_MAX R_XLEN_T_MAX #define R_SSIZE_MIN (-R_XLEN_T_MAX) #ifdef LONG_VECTOR_SUPPORT # define R_PRI_SSIZE "td" #else # define R_PRI_SSIZE "d" #endif enum r_type { R_TYPE_null = 0, R_TYPE_symbol = 1, R_TYPE_pairlist = 2, R_TYPE_closure = 3, R_TYPE_environment = 4, R_TYPE_promise = 5, R_TYPE_call = 6, R_TYPE_special = 7, R_TYPE_builtin = 8, R_TYPE_string = 9, R_TYPE_logical = 10, R_TYPE_integer = 13, R_TYPE_double = 14, R_TYPE_complex = 15, R_TYPE_character = 16, R_TYPE_dots = 17, R_TYPE_any = 18, R_TYPE_list = 19, R_TYPE_expression = 20, R_TYPE_bytecode = 21, R_TYPE_pointer = 22, R_TYPE_weakref = 23, R_TYPE_raw = 24, R_TYPE_s4 = 25, R_TYPE_new = 30, R_TYPE_free = 31, R_TYPE_function = 99 }; #define r_null R_NilValue struct r_pair { r_obj* x; r_obj* y; }; struct r_triple { r_obj* x; r_obj* y; r_obj* z; }; struct r_pair_ptr_ssize { void* ptr; r_ssize size; }; struct r_pair_callback { r_obj* (*fn)(void* data); void* data; }; struct r_lazy { r_obj* x; r_obj* env; }; #define KEEP PROTECT #define FREE UNPROTECT #define KEEP2(x, y) (KEEP(x), KEEP(y)) #define KEEP_N(x, n) (++(*n), KEEP(x)) #define r_keep_loc PROTECT_INDEX #define KEEP_AT REPROTECT #define KEEP_HERE PROTECT_WITH_INDEX #define KEEP_WHILE(X, EXPR) do { \ KEEP(X); \ EXPR; \ FREE(1); \ } while (0) #define RLANG_ASSERT(condition) ((void)sizeof(char[1 - 2*!(condition)])) // Polyfills for R API #if R_VERSION < R_Version(4, 5, 0) static inline int ANY_ATTRIB(SEXP x) { return ATTRIB(x) != R_NilValue; } static inline void CLEAR_ATTRIB(SEXP x) { SET_ATTRIB(x, R_NilValue); SET_OBJECT(x, 0); UNSET_S4_OBJECT(x); } #endif #if R_VERSION < R_Version(4, 6, 0) static inline bool rlang_promise_is_forced(r_obj* x) { return PRVALUE(x) != R_UnboundValue; } // Unwrap nested promises to the innermost one. // Sets `*forced` to TRUE if the innermost promise is forced. // Uses Floyd's cycle detection to guard against promise loops. static inline r_obj* rlang_promise_unwrap(r_obj* x, bool *forced) { r_obj* slow = x; bool advance_slow = false; while (TRUE) { r_obj* expr = PREXPR(x); if (TYPEOF(expr) != PROMSXP) { *forced = rlang_promise_is_forced(x); return x; } x = expr; if (x == slow) { Rf_error("Cycle detected in promise chain"); } if (advance_slow) { slow = PREXPR(slow); } advance_slow = !advance_slow; } } #endif #if R_VERSION < R_Version(4, 6, 0) static inline SEXP R_mapAttrib(SEXP x, SEXP (*FUN)(SEXP, SEXP, void *), void *data) { PROTECT_INDEX api; SEXP a = ATTRIB(x); SEXP val = NULL; PROTECT_WITH_INDEX(a, &api); while (a != R_NilValue) { SEXP tag = PROTECT(TAG(a)); SEXP attr = PROTECT(CAR(a)); val = FUN(tag, attr, data); UNPROTECT(2); if (val != NULL) break; REPROTECT(a = CDR(a), api); } UNPROTECT(1); return val; } #endif #endif lobstr/src/rlang/quo.h0000644000176200001440000000050315163457235014437 0ustar liggesusers// IWYU pragma: private; include "rlang.h" #ifndef RLANG_QUO_H #define RLANG_QUO_H #include "rlang-types.h" extern r_obj* (*r_quo_get_expr)(r_obj* quo); extern r_obj* (*r_quo_set_expr)(r_obj* quo, r_obj* expr); extern r_obj* (*r_quo_get_env)(r_obj* quo); extern r_obj* (*r_quo_set_env)(r_obj* quo, r_obj* env); #endif lobstr/src/rlang/dict.h0000644000176200001440000000246315163457235014565 0ustar liggesusers// IWYU pragma: private; include "rlang.h" #ifndef RLANG_DICT_H #define RLANG_DICT_H #include "rlang-types.h" /** * This is a simple hash table of `r_obj*`. It is structured like R * environments and uses xxhash for hashing. */ struct r_dict { r_obj* shelter; /* private: */ r_obj* buckets; r_obj* const * p_buckets; r_ssize n_buckets; r_ssize n_entries; // For testing collisions bool prevent_resize; }; struct r_dict* r_new_dict(r_ssize size); r_obj* r_dict_poke(struct r_dict* p_dict, r_obj* key, r_obj* value); bool r_dict_put(struct r_dict* p_dict, r_obj* key, r_obj* value); bool r_dict_del(struct r_dict* p_dict, r_obj* key); bool r_dict_has(struct r_dict* p_dict, r_obj* key); r_obj* r_dict_get(struct r_dict* p_dict, r_obj* key); r_obj* r_dict_get0(struct r_dict* p_dict, r_obj* key); // Pass a negative size to resize by the default growth factor void r_dict_resize(struct r_dict* p_dict, r_ssize size); r_obj* r_dict_as_df_list(struct r_dict* p_dict); r_obj* r_dict_as_list(struct r_dict* p_dict); struct r_dict_iterator { r_obj* shelter; r_obj* key; r_obj* value; /* private: */ r_ssize i; r_ssize n; r_obj* const * v_buckets; r_obj* node; }; struct r_dict_iterator* r_new_dict_iterator(struct r_dict* p_dict); bool r_dict_next(struct r_dict_iterator* p_it); #endif lobstr/src/rlang/decl/0000755000176200001440000000000015163704702014365 5ustar liggesuserslobstr/src/rlang/decl/walk-decl.h0000644000176200001440000000162615163457235016414 0ustar liggesusersstatic inline enum sexp_iterator_type sexp_iterator_type(enum r_type type, r_obj* x); static inline bool sexp_has_attrib(enum r_type type, r_obj* x); static inline r_obj* sexp_node_car(enum r_type type, r_obj* x, enum r_sexp_it_relation* p_rel); static inline r_obj* sexp_node_cdr(enum r_type type, r_obj* x, enum r_sexp_it_relation* p_rel); static inline r_obj* sexp_node_tag(enum r_type type, r_obj* x, enum r_sexp_it_relation* p_rel); static inline void init_incoming_stack_info(struct sexp_stack_info* p_info, enum sexp_iterator_type it_type, bool has_attrib); static bool sexp_next_incoming(struct r_sexp_iterator* p_it, struct sexp_stack_info* p_info); lobstr/src/rlang/decl/obj-decl.h0000644000176200001440000000023315163457235016221 0ustar liggesusersstatic r_obj* new_precious_stack(r_obj* x); static int push_precious(r_obj* stack); static int pop_precious(r_obj* stack); static r_obj* as_label_call; lobstr/src/rlang/decl/df-decl.h0000644000176200001440000000016215163457235016041 0ustar liggesusersstatic void init_compact_rownames(r_obj* x, r_ssize n_rows); static r_obj* new_compact_rownames(r_ssize n_rows); lobstr/src/rlang/decl/dyn-list-of-decl.h0000644000176200001440000000024415163457235017616 0ustar liggesusersstatic bool reserve_push_back(struct r_dyn_list_of* p_lof, r_ssize i, void* p_elt); static void reserve_move(struct r_dyn_list_of* p_lof, r_ssize i, void* p_elt); lobstr/src/rlang/decl/dict-decl.h0000644000176200001440000000062615163457235016400 0ustar liggesusersstatic r_obj* dict_find_node_info(struct r_dict* dict, r_obj* key, r_ssize* hash, r_obj** parent); static r_obj* dict_find_node(struct r_dict* dict, r_obj* key); static void dict_push(struct r_dict* p_dict, r_ssize hash, r_obj* parent, r_obj* key, r_obj* value); lobstr/src/rlang/decl/env-decl.h0000644000176200001440000000101015163457235016231 0ustar liggesusersr_obj* eval_with_x(r_obj* call, r_obj* x); r_obj* eval_with_xy(r_obj* call, r_obj* x, r_obj* y); r_obj* eval_with_xyz(r_obj* call, r_obj* x, r_obj* y, r_obj* z); #if R_VERSION < R_Version(4, 1, 0) static r_obj* new_env_call; static r_obj* new_env__parent_node; static r_obj* new_env__size_node; #endif static r_obj* exists_call; static r_obj* remove_call; static r_obj* env2list_call; static r_obj* list2env_call; static r_obj* missing_prim; static void env_coalesce_plain(r_obj* env, r_obj* from, r_obj* nms); lobstr/src/rlang/decl/cnd-decl.h0000644000176200001440000000003715163457235016215 0ustar liggesusersstatic r_obj* cnd_signal_call; lobstr/src/rlang/decl/env-binding-decl.h0000644000176200001440000000003415163457235017646 0ustar liggesusersextern r_obj* rlang_ns_env; lobstr/src/rlang/decl/stack-decl.h0000644000176200001440000000016415163457235016557 0ustar liggesusers// From env.c r_obj* rlang_ns_get(const char* name); static r_obj* peek_frame_call; static r_obj* caller_env_call; lobstr/src/rlang/node.c0000644000176200001440000000255515163457235014564 0ustar liggesusers#include "rlang.h" r_obj* r_new_pairlist(const struct r_pair* args, int n, r_obj** tail) { r_obj* shelter = KEEP(r_new_node(R_NilValue, R_NilValue)); r_obj* node = shelter; for (int i = 0; i < n; ++i) { struct r_pair arg = args[i]; r_obj* tag = arg.x; r_obj* car = arg.y; r_obj* cdr = r_new_node(car, r_null); r_node_poke_tag(cdr, tag); r_node_poke_cdr(node, cdr); node = cdr; } if (n && tail) { *tail = node; } FREE(1); return r_node_cdr(shelter); } // Shallow copy of a node tree. Other objects are not cloned. r_obj* r_node_tree_clone(r_obj* x) { enum r_type type = r_typeof(x); if (type != R_TYPE_pairlist && type != R_TYPE_call) { return x; } x = KEEP(r_clone(x)); r_obj* rest = x; while (rest != r_null) { r_obj* head = r_node_car(rest); enum r_type head_type = r_typeof(head); if (head_type == R_TYPE_pairlist || head_type == R_TYPE_call) { r_node_poke_car(rest, r_node_tree_clone(head)); } rest = r_node_cdr(rest); } FREE(1); return x; } r_obj* r_pairlist_rev(r_obj* node) { if (node == r_null) { return node; } r_obj* prev = r_null; r_obj* tail = node; r_obj* next; while (tail != r_null) { next = r_node_cdr(tail); r_node_poke_cdr(tail, prev); prev = tail; tail = next; } return prev; } lobstr/src/rlang/cnd.h0000644000176200001440000000440015163457235014377 0ustar liggesusers// IWYU pragma: private; include "rlang.h" #ifndef RLANG_CND_H #define RLANG_CND_H #include "rlang-types.h" #include "obj.h" void r_inform(const char* fmt, ...); void r_warn(const char* fmt, ...); void r_interrupt(void); void r_no_return r_abort(const char* fmt, ...); void r_no_return r_abort_n(const struct r_pair* args, int n); void r_no_return r_abort_call(r_obj* call, const char* fmt, ...); // Formats input as an argument, using cli if available. Returns a // vmax-protected string. extern const char* (*r_format_error_arg)(r_obj* arg); const char* r_format_lazy_error_arg(struct r_lazy arg); // Return vmax-protected strings extern const char* (*r_obj_type_friendly_full)(r_obj* x, bool value, bool length); static inline const char* r_obj_type_friendly(r_obj* x) { return r_obj_type_friendly_full(x, true, false); } extern r_no_return void (*r_stop_internal)(const char* file, int line, r_obj* call, const char* fmt, ...); r_obj* r_peek_frame(void); #define r_stop_internal(...) \ (r_stop_internal)(__FILE__, __LINE__, r_peek_frame(), \ __VA_ARGS__) #define r_stop_unreachable() \ (r_stop_internal)(__FILE__, __LINE__, r_peek_frame(), \ "Reached the unreachable") #define r_stop_unimplemented_type(TYPE) \ (r_stop_internal)(__FILE__, __LINE__, r_peek_frame(), \ "Unimplemented type `%s`.", Rf_type2char(TYPE)) #define r_stop_unexpected_type(TYPE) \ (r_stop_internal)(__FILE__, __LINE__, r_peek_frame(), \ "Unexpected type `%s`.", Rf_type2char(TYPE)) static inline bool r_is_condition(r_obj* x) { return r_typeof(x) == R_TYPE_list && r_inherits(x, "condition"); } void r_cnd_signal(r_obj* cnd); void r_cnd_inform(r_obj* cnd, bool mufflable); void r_cnd_warn(r_obj* cnd, bool mufflable); void r_cnd_abort(r_obj* cnd, bool mufflable); enum r_cnd_type { R_CND_TYPE_condition = 0, R_CND_TYPE_message = 1, R_CND_TYPE_warning = 2, R_CND_TYPE_error = 3, R_CND_TYPE_interrupt = 4 }; enum r_cnd_type r_cnd_type(r_obj* cnd); #endif lobstr/src/rlang/obj.c0000644000176200001440000000576015163457235014412 0ustar liggesusers#include "rlang.h" #define PRECIOUS_DICT_INIT_SIZE 256 static struct r_dict* p_precious_dict = NULL; #include "decl/obj-decl.h" r_obj* r_vec_clone(r_obj* x) { r_obj* out = KEEP(r_clone(x)); r_obj* names = r_names(x); if (names != r_null) { r_attrib_poke_names(out, r_clone(names)); } FREE(1); return out; } r_obj* r_vec_clone_shared(r_obj* x) { if (r_is_shared(x)) { return r_vec_clone(x); } r_obj* names = r_names(x); if (names != r_null && r_is_shared(names)) { r_attrib_poke_names(x, r_clone(names)); return x; } return x; } void (_r_preserve)(r_obj* x) { if (!_r_use_local_precious_list) { return; } r_obj* stack = r_dict_get0(p_precious_dict, x); if (!stack) { stack = KEEP(new_precious_stack(x)); r_dict_put(p_precious_dict, x, stack); FREE(1); } push_precious(stack); } void (_r_unpreserve)(r_obj* x) { if (!_r_use_local_precious_list) { return; } r_obj* stack = r_dict_get0(p_precious_dict, x); if (!stack) { r_abort("Can't unpreserve `x` because it was not being preserved."); } int n = pop_precious(stack); if (n < 0) { r_stop_internal("`n` unexpectedly < 0."); } if (n == 0) { r_dict_del(p_precious_dict, x); } } static r_obj* new_precious_stack(r_obj* x) { r_obj* stack = KEEP(r_alloc_list(2)); // Store (0) protection count and (1) element to protect r_list_poke(stack, 0, r_int(0)); r_list_poke(stack, 1, x); FREE(1); return stack; } static int push_precious(r_obj* stack) { r_obj* n = r_list_get(stack, 0); int* p_n = r_int_begin(n); return ++(*p_n); } static int pop_precious(r_obj* stack) { r_obj* n = r_list_get(stack, 0); int* p_n = r_int_begin(n); return --(*p_n); } // For unit tests struct r_dict* rlang__precious_dict(void) { return p_precious_dict; } enum r_type r_chr_as_r_type(r_obj* type) { if (!r_is_string(type)) { r_abort("`type` must be a character string."); } return r_c_str_as_r_type(r_chr_get_c_string(type, 0)); } const char* obj_address_formatter = "%p"; r_obj* r_obj_address(r_obj* x) { static char buf[1000]; snprintf(buf, 1000, obj_address_formatter, (void*) x); return Rf_mkChar(buf); } r_obj* (*r_obj_encode_utf8)(r_obj* x) = NULL; r_obj* r_as_label(r_obj* x) { return r_eval_with_x(as_label_call, x, r_ns_env("rlang")); } void r_init_library_obj(r_obj* ns) { p_precious_dict = r_new_dict(PRECIOUS_DICT_INIT_SIZE); KEEP(p_precious_dict->shelter); r_env_bind(ns, r_sym(".__rlang_lib_precious_dict__."), p_precious_dict->shelter); FREE(1); // The Microsoft C library doesn't implement the hexadecimal // formatter correctly const char* null_addr = r_str_c_string(r_obj_address(r_null)); if (null_addr[0] != '0' || null_addr[1] != 'x') { obj_address_formatter = "0x%p"; } r_obj_encode_utf8 = (r_obj* (*)(r_obj*)) r_peek_c_callable("rlang", "rlang_obj_encode_utf8"); as_label_call = r_parse("as_label(x)"); r_preserve_global(as_label_call); } static r_obj* as_label_call = NULL; lobstr/src/rlang/vendor.c0000644000176200001440000000032115163457235015121 0ustar liggesusers#include "rlang.h" uint64_t (*r_xxh3_64bits)(const void*, size_t); void r_init_library_vendor(void) { r_xxh3_64bits = (uint64_t (*)(const void*, size_t)) r_peek_c_callable("rlang", "rlang_xxh3_64bits"); } lobstr/src/rlang/attrib.c0000644000176200001440000000223715163457235015121 0ustar liggesusers#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); } lobstr/src/rlang/parse.h0000644000176200001440000000031715163457235014750 0ustar liggesusers// IWYU pragma: private; include "rlang.h" #ifndef RLANG_PARSE_H #define RLANG_PARSE_H #include "rlang-types.h" r_obj* r_parse(const char* str); r_obj* r_parse_eval(const char* str, r_obj* env); #endif lobstr/src/rlang/vec.h0000644000176200001440000003046115163457235014416 0ustar liggesusers// IWYU pragma: private; include "rlang.h" #ifndef RLANG_VECTOR_H #define RLANG_VECTOR_H #include #include "rlang-types.h" #include "c-utils.h" #include "cnd.h" #include "globals.h" #include "obj.h" static inline int* r_lgl_begin(r_obj* x) { return LOGICAL(x); } static inline int* r_int_begin(r_obj* x) { return INTEGER(x); } static inline double* r_dbl_begin(r_obj* x) { return REAL(x); } static inline r_complex* r_cpl_begin(r_obj* x) { return COMPLEX(x); } static inline void* r_raw_begin(r_obj* x) { return RAW(x); } static inline const int* r_int_cbegin(r_obj* x) { return (const int*) INTEGER(x); } static inline const int* r_lgl_cbegin(r_obj* x) { return (const int*) LOGICAL(x); } static inline const double* r_dbl_cbegin(r_obj* x) { return (const double*) REAL(x); } static inline const r_complex* r_cpl_cbegin(r_obj* x) { return (const r_complex*) COMPLEX(x); } static inline const void* r_raw_cbegin(r_obj* x) { return (const void*) RAW(x); } static inline r_obj* const * r_chr_cbegin(r_obj* x) { return STRING_PTR_RO(x); } static inline r_obj* const * r_list_cbegin(r_obj* x) { #if (R_VERSION >= R_Version(4, 5, 0)) return VECTOR_PTR_RO(x); #else return ((r_obj* const *) DATAPTR_RO(x)); #endif } static inline void* r_vec_begin0(enum r_type type, r_obj* x) { switch (type) { case R_TYPE_logical: return r_lgl_begin(x); case R_TYPE_integer: return r_int_begin(x); case R_TYPE_double: return r_dbl_begin(x); case R_TYPE_complex: return r_cpl_begin(x); case R_TYPE_raw: return r_raw_begin(x); default: r_stop_unimplemented_type(type); } } static inline void* r_vec_begin(r_obj* x) { return r_vec_begin0(r_typeof(x), x); } static inline const void* r_vec_cbegin0(enum r_type type, r_obj* x) { switch (type) { case R_TYPE_logical: return r_lgl_cbegin(x); case R_TYPE_integer: return r_int_cbegin(x); case R_TYPE_double: return r_dbl_cbegin(x); case R_TYPE_complex: return r_cpl_cbegin(x); case R_TYPE_raw: return r_raw_cbegin(x); case R_TYPE_character: return r_chr_cbegin(x); case R_TYPE_list: return r_list_cbegin(x); default: r_stop_unimplemented_type(type); } } static inline const void* r_vec_cbegin(r_obj* x) { return r_vec_cbegin0(r_typeof(x), x); } static inline int r_vec_elt_sizeof0(enum r_type type) { switch (type) { case R_TYPE_logical: return sizeof(int); case R_TYPE_integer: return sizeof(int); case R_TYPE_double: return sizeof(double); case R_TYPE_complex: return sizeof(r_complex); case R_TYPE_raw: return sizeof(char); case R_TYPE_character: return sizeof(r_obj*); case R_TYPE_list: return sizeof(r_obj*); default: r_stop_unimplemented_type(type); } } static inline int r_vec_elt_sizeof(r_obj* x) { return r_vec_elt_sizeof0(r_typeof(x)); } static inline int r_lgl_get(r_obj* x, r_ssize i) { return LOGICAL(x)[i]; } static inline int r_int_get(r_obj* x, r_ssize i) { return INTEGER(x)[i]; } static inline double r_dbl_get(r_obj* x, r_ssize i) { return REAL(x)[i]; } static inline r_complex r_cpl_get(r_obj* x, r_ssize i) { return COMPLEX(x)[i]; } static inline char r_raw_get(r_obj* x, r_ssize i) { return RAW(x)[i]; } static inline r_obj* r_chr_get(r_obj* x, r_ssize i) { return STRING_ELT(x, i); } static inline const char* r_chr_get_c_string(r_obj* x, r_ssize i) { return CHAR(r_chr_get(x, i)); } static inline r_obj* r_list_get(r_obj* x, r_ssize i) { return VECTOR_ELT(x, i); } static inline void r_lgl_poke(r_obj* x, r_ssize i, int y) { LOGICAL(x)[i] = y; } static inline void r_int_poke(r_obj* x, r_ssize i, int y) { INTEGER(x)[i] = y; } static inline void r_dbl_poke(r_obj* x, r_ssize i, double y) { REAL(x)[i] = y; } static inline void r_cpl_poke(r_obj* x, r_ssize i, r_complex y) { COMPLEX(x)[i] = y; } static inline void r_raw_poke(r_obj* x, r_ssize i, char y) { RAW(x)[i] = y; } static inline void r_chr_poke(r_obj* x, r_ssize i, r_obj* y) { SET_STRING_ELT(x, i, y); } static inline void r_list_poke(r_obj* x, r_ssize i, r_obj* y) { SET_VECTOR_ELT(x, i, y); } #define r_chr_poke(X, I, Y) SET_STRING_ELT(X, I, Y) #define r_list_poke(X, I, Y) SET_VECTOR_ELT(X, I, Y) static inline r_obj* r_alloc_vector(enum r_type type, r_ssize n) { #if R_VERSION >= R_Version(4, 6, 0) return R_allocResizableVector(type, n); #else return Rf_allocVector(type, n); #endif } static inline r_obj* r_alloc_logical(r_ssize n) { #if R_VERSION >= R_Version(4, 6, 0) return R_allocResizableVector(R_TYPE_logical, n); #else return Rf_allocVector(R_TYPE_logical, n); #endif } static inline r_obj* r_alloc_integer(r_ssize n) { #if R_VERSION >= R_Version(4, 6, 0) return R_allocResizableVector(R_TYPE_integer, n); #else return Rf_allocVector(R_TYPE_integer, n); #endif } static inline r_obj* r_alloc_double(r_ssize n) { #if R_VERSION >= R_Version(4, 6, 0) return R_allocResizableVector(R_TYPE_double, n); #else return Rf_allocVector(R_TYPE_double, n); #endif } static inline r_obj* r_alloc_complex(r_ssize n) { #if R_VERSION >= R_Version(4, 6, 0) return R_allocResizableVector(R_TYPE_complex, n); #else return Rf_allocVector(R_TYPE_complex, n); #endif } static inline r_obj* r_alloc_raw(r_ssize n) { #if R_VERSION >= R_Version(4, 6, 0) return R_allocResizableVector(R_TYPE_raw, n); #else return Rf_allocVector(R_TYPE_raw, n); #endif } static inline r_obj* r_alloc_character(r_ssize n) { #if R_VERSION >= R_Version(4, 6, 0) return R_allocResizableVector(R_TYPE_character, n); #else return Rf_allocVector(R_TYPE_character, n); #endif } static inline r_obj* r_alloc_list(r_ssize n) { #if R_VERSION >= R_Version(4, 6, 0) return R_allocResizableVector(R_TYPE_list, n); #else return Rf_allocVector(R_TYPE_list, n); #endif } static inline r_obj* r_alloc_raw0(r_ssize n) { r_obj* out = r_alloc_raw(n); unsigned char* p_out = (unsigned char*) r_raw_begin(out); r_memset(p_out, 0, n); return out; } static inline r_obj* r_lgl(bool x) { return Rf_ScalarLogical(x); } static inline r_obj* r_int(int x) { return Rf_ScalarInteger(x); } static inline r_obj* r_dbl(double x) { return Rf_ScalarReal(x); } static inline r_obj* r_cpl(r_complex x) { return Rf_ScalarComplex(x); } static inline r_obj* r_raw(char x) { return Rf_ScalarRaw(x); } static inline r_obj* r_str(const char* c_string) { return Rf_mkCharCE(c_string, CE_UTF8); } static inline r_obj* r_chr(const char* c_string) { r_obj* out = KEEP(r_alloc_character(1)); r_chr_poke(out, 0, r_str(c_string)); FREE(1); return out; } static inline r_obj* r_list(r_obj* x) { r_obj* out = r_alloc_list(1); r_list_poke(out, 0, x); return out; } r_obj* r_chr_n(const char* const * strings, r_ssize n); static inline r_obj* r_len(r_ssize x) { if (x > INT_MAX) { return r_dbl(x); } else { return r_int(x); } } // FIXME: Redundant with `r_lgl()` static inline r_obj* r_shared_lgl(bool x) { if (x) { return r_true; } else { return r_false; } } static inline bool _r_has_correct_length(r_obj* x, r_ssize n) { return n < 0 || r_length(x) == n; } extern bool _r_is_finite(r_obj* x); static inline bool _r_is_double(r_obj* x, r_ssize n, int finite) { if (r_typeof(x) != R_TYPE_double || !_r_has_correct_length(x, n)) { return false; } if (finite >= 0 && (bool) finite != _r_is_finite(x)) { return false; } return true; } static inline bool _r_is_complex(r_obj* x, r_ssize n, int finite) { if (r_typeof(x) != R_TYPE_complex || !_r_has_correct_length(x, n)) { return false; } if (finite >= 0 && (bool) finite != _r_is_finite(x)) { return false; } return true; } static inline bool r_is_bool(r_obj* x) { return r_typeof(x) == R_TYPE_logical && r_length(x) == 1 && r_lgl_get(x, 0) != r_globals.na_lgl; } static inline bool r_is_int(r_obj* x) { return r_typeof(x) == R_TYPE_integer && r_length(x) == 1 && r_int_get(x, 0) != r_globals.na_int; } static inline bool r_is_true(r_obj* x) { return r_is_bool(x) && r_lgl_get(x, 0); } static inline bool r_is_false(r_obj* x) { return r_is_bool(x) && !r_lgl_get(x, 0); } static inline bool r_is_string(r_obj* x) { return r_typeof(x) == R_TYPE_character && r_length(x) == 1 && r_chr_get(x, 0) != R_NaString; } static inline bool r_arg_as_bool(r_obj* x, const char* arg) { if (!r_is_bool(x)) { r_abort("`%s` must be `TRUE` or `FALSE`.", arg); } return r_lgl_get(x, 0); } static inline bool r_as_bool(r_obj* x) { return r_arg_as_bool(x, "x"); } static inline int r_arg_as_int(r_obj* x, const char* arg) { if (!r_is_int(x)) { r_abort("`%s` must be a single integer value.", arg); } return r_int_get(x, 0); } static inline int r_as_int(r_obj* x) { return r_arg_as_int(x, "x"); } static inline double r_arg_as_double(r_obj* x, const char* arg) { // TODO: Coercion of int and lgl values if (!_r_is_double(x, 1, -1)) { r_abort("`%s` must be a single double value.", arg); } return r_dbl_get(x, 0); } static inline double r_as_double(r_obj* x) { return r_arg_as_double(x, "x"); } static inline r_complex r_arg_as_complex(r_obj* x, const char* arg) { if (!_r_is_complex(x, 1, 1)) { r_abort("`%s` must be a single complex value.", arg); } return r_cpl_get(x, 0); } static inline r_complex r_as_complex(r_obj* x) { return r_arg_as_complex(x, "x"); } static inline char r_arg_as_char(r_obj* x, const char* arg) { if (r_typeof(x) != R_TYPE_raw && r_length(x) != 1) { r_abort("`%s` must be a single raw value.", arg); } return r_raw_get(x, 0); } static inline char r_as_char(r_obj* x) { return r_arg_as_char(x, "x"); } r_obj* r_lgl_resize(r_obj* x, r_ssize new_size); r_obj* r_int_resize(r_obj* x, r_ssize new_size); r_obj* r_dbl_resize(r_obj* x, r_ssize new_size); r_obj* r_cpl_resize(r_obj* x, r_ssize new_size); r_obj* r_raw_resize(r_obj* x, r_ssize new_size); r_obj* r_chr_resize(r_obj* x, r_ssize new_size); r_obj* r_list_resize(r_obj* x, r_ssize new_size); static inline r_obj* r_vec_resize0(enum r_type type, r_obj* x, r_ssize new_size) { switch (type) { case R_TYPE_logical: return r_lgl_resize(x, new_size); case R_TYPE_integer: return r_int_resize(x, new_size); case R_TYPE_double: return r_dbl_resize(x, new_size); case R_TYPE_complex: return r_cpl_resize(x, new_size); case R_TYPE_raw: return r_raw_resize(x, new_size); case R_TYPE_character: return r_chr_resize(x, new_size); case R_TYPE_list: return r_list_resize(x, new_size); default: r_stop_unimplemented_type(type); } } static inline r_obj* r_vec_resize(r_obj* x, r_ssize new_size) { return r_vec_resize0(r_typeof(x), x, new_size); } static inline r_obj* r_vec_n(enum r_type type, void* v_src, r_ssize n) { switch (type) { case R_TYPE_logical: case R_TYPE_integer: case R_TYPE_double: case R_TYPE_complex: case R_TYPE_raw: { r_obj* out = r_alloc_vector(type, n); r_memcpy(r_vec_begin(out), v_src, n * r_vec_elt_sizeof0(type)); return out; } case R_TYPE_character: case R_TYPE_list: r_abort("TODO: barrier types in `r_vec_n()`"); default: r_stop_unimplemented_type(type); } } static inline r_obj* r_lgl_n(int* v_src, r_ssize n) { return r_vec_n(R_TYPE_logical, v_src, n); } static inline r_obj* r_int_n(int* v_src, r_ssize n) { return r_vec_n(R_TYPE_integer, v_src, n); } static inline r_obj* r_dbl_n(int* v_src, r_ssize n) { return r_vec_n(R_TYPE_double, v_src, n); } static inline r_obj* r_cpl_n(int* v_src, r_ssize n) { return r_vec_n(R_TYPE_complex, v_src, n); } static inline r_obj* r_raw_n(int* v_src, r_ssize n) { return r_vec_n(R_TYPE_raw, v_src, n); } static inline r_obj* r_copy_in_raw(const void* src, size_t size) { r_obj* out = r_alloc_raw(size); r_memcpy(r_raw_begin(out), src, size); return out; } static inline void r_int_fill_iota0(int* p_x, int start, r_ssize n) { for (r_ssize i = 0; i < n; ++i) { p_x[i] = start++; } } static inline void r_int_fill_iota(r_obj* x) { r_int_fill_iota0(r_int_begin(x), 0, r_length(x)); } r_obj* r_list_compact(r_obj* x); r_obj* r_list_of_as_ptr_ssize(r_obj* xs, enum r_type type, struct r_pair_ptr_ssize** p_v_out); // From cpp/vec.cpp int* r_int_unique0(int* v_data, r_ssize size); bool r_list_all_of0(r_obj* const * v_first, r_ssize size, bool (*predicate)(r_obj* x)); static inline int* r_int_unique(r_obj* x) { return r_int_unique0(r_int_begin(x), r_length(x)); } static inline bool r_list_all_of(r_obj* x, bool (*predicate)(r_obj* x)) { return r_list_all_of0(r_list_cbegin(x), r_length(x), predicate); } #endif lobstr/src/rlang/fn.h0000644000176200001440000000246415163457235014246 0ustar liggesusers// IWYU pragma: private; include "rlang.h" #ifndef RLANG_FN_H #define RLANG_FN_H #include "rlang-types.h" #include "obj.h" static inline r_obj* r_fn_formals(r_obj* fn) { #if R_VERSION >= R_Version(4, 5, 0) return R_ClosureFormals(fn); #else return FORMALS(fn); #endif } // Identical to `R_BytecodeExpr(R_ClosureBody(fn))`, which we always want // since it matches the R level `body()` static inline r_obj* r_fn_body(r_obj* fn) { return R_ClosureExpr(fn); } static inline r_obj* r_fn_env(r_obj* fn) { #if R_VERSION >= R_Version(4, 5, 0) return R_ClosureEnv(fn); #else return CLOENV(fn); #endif } static inline r_obj* r_new_function(r_obj* formals, r_obj* body, r_obj* env) { #if R_VERSION >= R_Version(4, 5, 0) return R_mkClosure(formals, body, env); #else SEXP fn = Rf_allocSExp(R_TYPE_closure); SET_FORMALS(fn, formals); SET_BODY(fn, body); SET_CLOENV(fn, env); return fn; #endif } r_obj* r_as_function(r_obj* x, const char* arg); static inline bool r_is_function(r_obj* x) { switch (r_typeof(x)) { case R_TYPE_closure: case R_TYPE_builtin: case R_TYPE_special: return true; default: return false; } } static inline bool r_is_primitive(r_obj* x) { switch (r_typeof(x)) { case R_TYPE_builtin: case R_TYPE_special: return true; default: return false; } } #endif lobstr/src/rlang/debug.h0000644000176200001440000000040515163457235014722 0ustar liggesusers// IWYU pragma: private; include "rlang.h" #ifndef RLANG_DEBUG_H #define RLANG_DEBUG_H #include "rlang-types.h" #define r_printf Rprintf void r_sexp_inspect(r_obj* x); void r_browse(r_obj* x); void r_browse_at(r_obj* env); void r_dbg_str(r_obj* x); #endif lobstr/src/rlang/eval.h0000644000176200001440000001146715163457235014575 0ustar liggesusers// IWYU pragma: private; include "rlang.h" #ifndef RLANG_EVAL_H #define RLANG_EVAL_H #include "rlang-types.h" #include "c-utils.h" #include "call.h" static inline r_obj* r_eval(r_obj* expr, r_obj* env) { return Rf_eval(expr, env); } r_obj* r_eval_with_x(r_obj* call, r_obj* x, r_obj* parent); r_obj* r_eval_with_xy(r_obj* call, r_obj* x, r_obj* y, r_obj* parent); r_obj* r_eval_with_xyz(r_obj* call, r_obj* x, r_obj* y, r_obj* z, r_obj* parent); r_obj* r_eval_with_wxyz(r_obj* call, r_obj* w, r_obj* x, r_obj* y, r_obj* z, r_obj* parent); r_obj* r_exec_mask_n(r_obj* fn_sym, r_obj* fn, const struct r_pair* args, int n, r_obj* parent); r_obj* r_exec_n(r_obj* fn_sym, r_obj* fn, const struct r_pair* args, int n, r_obj* env); r_obj* r_exec_mask_n_call_poke(r_obj* fn_sym, r_obj* fn, const struct r_pair* args, int n, r_obj* env); static inline r_obj* r_exec_mask1(r_obj* fn_sym, r_obj* fn, r_obj* x_sym, r_obj* x, r_obj* env) { struct r_pair args[] = { { x_sym, x } }; return r_exec_mask_n(fn_sym, fn, args, R_ARR_SIZEOF(args), env); } static inline r_obj* r_exec_mask2(r_obj* fn_sym, r_obj* fn, r_obj* x1_sym, r_obj* x1, r_obj* x2_sym, r_obj* x2, r_obj* env) { struct r_pair args[] = { { x1_sym, x1 }, { x2_sym, x2 } }; return r_exec_mask_n(fn_sym, fn, args, R_ARR_SIZEOF(args), env); } static inline r_obj* r_exec_mask3(r_obj* fn_sym, r_obj* fn, r_obj* x1_sym, r_obj* x1, r_obj* x2_sym, r_obj* x2, r_obj* x3_sym, r_obj* x3, r_obj* env) { struct r_pair args[] = { { x1_sym, x1 }, { x2_sym, x2 }, { x3_sym, x3 } }; return r_exec_mask_n(fn_sym, fn, args, R_ARR_SIZEOF(args), env); } static inline r_obj* r_exec_mask4(r_obj* fn_sym, r_obj* fn, r_obj* x1_sym, r_obj* x1, r_obj* x2_sym, r_obj* x2, r_obj* x3_sym, r_obj* x3, r_obj* x4_sym, r_obj* x4, r_obj* env) { struct r_pair args[] = { { x1_sym, x1 }, { x2_sym, x2 }, { x3_sym, x3 }, { x4_sym, x4 } }; return r_exec_mask_n(fn_sym, fn, args, R_ARR_SIZEOF(args), env); } static inline r_obj* r_exec_mask5(r_obj* fn_sym, r_obj* fn, r_obj* x1_sym, r_obj* x1, r_obj* x2_sym, r_obj* x2, r_obj* x3_sym, r_obj* x3, r_obj* x4_sym, r_obj* x4, r_obj* x5_sym, r_obj* x5, r_obj* env) { struct r_pair args[] = { { x1_sym, x1 }, { x2_sym, x2 }, { x3_sym, x3 }, { x4_sym, x4 }, { x5_sym, x5 } }; return r_exec_mask_n(fn_sym, fn, args, R_ARR_SIZEOF(args), env); } static inline r_obj* r_exec_mask6(r_obj* fn_sym, r_obj* fn, r_obj* x1_sym, r_obj* x1, r_obj* x2_sym, r_obj* x2, r_obj* x3_sym, r_obj* x3, r_obj* x4_sym, r_obj* x4, r_obj* x5_sym, r_obj* x5, r_obj* x6_sym, r_obj* x6, r_obj* env) { struct r_pair args[] = { { x1_sym, x1 }, { x2_sym, x2 }, { x3_sym, x3 }, { x4_sym, x4 }, { x5_sym, x5 }, { x6_sym, x6 } }; return r_exec_mask_n(fn_sym, fn, args, R_ARR_SIZEOF(args), env); } static inline r_obj* r_exec_mask7(r_obj* fn_sym, r_obj* fn, r_obj* x1_sym, r_obj* x1, r_obj* x2_sym, r_obj* x2, r_obj* x3_sym, r_obj* x3, r_obj* x4_sym, r_obj* x4, r_obj* x5_sym, r_obj* x5, r_obj* x6_sym, r_obj* x6, r_obj* x7_sym, r_obj* x7, r_obj* env) { struct r_pair args[] = { { x1_sym, x1 }, { x2_sym, x2 }, { x3_sym, x3 }, { x4_sym, x4 }, { x5_sym, x5 }, { x6_sym, x6 }, { x7_sym, x7 } }; return r_exec_mask_n(fn_sym, fn, args, R_ARR_SIZEOF(args), env); } static inline r_obj* r_lazy_eval(struct r_lazy lazy) { if (!lazy.env) { // Unitialised lazy variable return r_null; } else if (lazy.env == r_null) { // Forced lazy variable return lazy.x; } else { return r_eval(lazy.x, lazy.env); } } extern struct r_lazy r_lazy_null; extern struct r_lazy r_lazy_missing_arg; static inline r_obj* r_lazy_eval_protect(struct r_lazy lazy) { r_obj* out = KEEP(r_lazy_eval(lazy)); out = r_expr_protect(out); FREE(1); return out; } static inline bool r_lazy_is_null(struct r_lazy call) { return !call.x && !call.env; } #endif lobstr/src/rlang/dots-info.h0000644000176200001440000000121315163457235015534 0ustar liggesusers#ifndef RLANG_DOTS_INFO_H #define RLANG_DOTS_INFO_H #include "rlang-types.h" typedef enum { DOT_TYPE_value = 0, DOT_TYPE_missing = 1, DOT_TYPE_delayed = 2, DOT_TYPE_forced = 3 } r_dot_type_t; bool r_env_dots_exist(r_obj* env); r_ssize r_env_dots_length(r_obj* env); r_obj* r_env_dots_names(r_obj* env); r_obj* r_env_dot_get(r_obj* env, r_ssize i); r_dot_type_t r_env_dot_type(r_obj* env, r_ssize i); r_obj* r_env_dot_delayed_expr(r_obj* env, r_ssize i); r_obj* r_env_dot_delayed_env(r_obj* env, r_ssize i); r_obj* r_env_dot_forced_expr(r_obj* env, r_ssize i); r_obj* r_env_until_dots(r_obj* env); #endif /* RLANG_DOTS_INFO_H */ lobstr/src/rlang/sym.h0000644000176200001440000000125315163457235014446 0ustar liggesusers// IWYU pragma: private; include "rlang.h" #ifndef RLANG_SYM_H #define RLANG_SYM_H #include "rlang-types.h" // The results of `r_sym_as_` functions must be protected extern r_obj* (*r_sym_as_utf8_character)(r_obj* x); extern r_obj* (*r_sym_as_utf8_string)(r_obj* x); r_obj* r_new_symbol(r_obj* x, int* err); static inline r_obj* r_sym(const char* c_string) { return Rf_install(c_string); } static inline r_obj* r_sym_string(r_obj* sym) { return PRINTNAME(sym); } static inline const char* r_sym_c_string(r_obj* sym) { return CHAR(PRINTNAME(sym)); } bool r_is_symbol(r_obj* sym, const char* string); bool r_is_symbol_any(r_obj* x, const char** strings, int n); #endif lobstr/src/rlang/vendor.h0000644000176200001440000000023415163457235015131 0ustar liggesusers// IWYU pragma: private; include "rlang.h" #ifndef RLANG_VENDOR_H #define RLANG_VENDOR_H extern uint64_t (*r_xxh3_64bits)(const void*, size_t); #endif lobstr/src/rlang/attrib.h0000644000176200001440000000363415163457235015130 0ustar liggesusers// 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 lobstr/src/address.cpp0000644000176200001440000000322215143623341014500 0ustar liggesusers#include "utils.h" #include #include #include extern "C" { #include } [[cpp11::register]] std::string obj_addr_(SEXP name, cpp11::environment env) { return obj_addr_(Rf_eval(name, env)); } [[cpp11::register]] std::vector obj_addrs_(SEXP x) { int n = Rf_length(x); std::vector out; switch(TYPEOF(x)) { case STRSXP: for (int i = 0; i < n; ++i) { out.push_back(obj_addr_(STRING_ELT(x, i))); } break; case VECSXP: for (int i = 0; i < n; ++i) { out.push_back(obj_addr_(VECTOR_ELT(x, i))); } break; case ENVSXP: { 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_delayed_expr(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; } default: cpp11::stop( "`x` must be a list, environment, or character vector, not a %s.", Rf_type2char(TYPEOF(x)) ); } return out; } lobstr/src/rlang.c0000644000176200001440000000025315163457235013630 0ustar liggesusers// 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" lobstr/src/inspect.cpp0000644000176200001440000003475215144564741014545 0ustar liggesusers#include #include #include #include #include #include #include "utils.h" extern "C" { #include } struct Expand { bool alrep; bool charsxp; bool env; bool call; bool bytecode; }; class GrowableList { cpp11::writable::list data_; cpp11::writable::strings names_; R_xlen_t n_; public: GrowableList(R_xlen_t size = 10) : data_(size), names_(size), n_(0) { } void push_back(const char* string, SEXP x) { int n_protected = 0; if (Rf_xlength(data_) == n_) { data_ = PROTECT(Rf_xlengthgets(data_, n_ * 2)); n_protected++; names_ = PROTECT(Rf_xlengthgets(names_, n_ * 2)); n_protected++; } SEXP string_ = PROTECT(Rf_mkChar(string)); n_protected++; SET_STRING_ELT(names_, n_, string_); SET_VECTOR_ELT(data_, n_, x); n_++; UNPROTECT(n_protected); } cpp11::list vector() { if (Rf_xlength(data_) != n_) { data_ = Rf_xlengthgets(data_, n_); names_ = Rf_xlengthgets(names_, n_); } Rf_setAttrib(data_, R_NamesSymbol, names_); return data_; } }; SEXP collect_attribs(SEXP x); bool is_namespace(cpp11::environment env); SEXP obj_children_(SEXP x, std::map& seen, double max_depth, Expand expand); // Convert SEXPTYPE to uppercase name (e.g. REALSXP, ENVSXP) const char* sexptype_name(SEXPTYPE type) { switch (type) { case NILSXP: return "NILSXP"; case SYMSXP: return "SYMSXP"; case LISTSXP: return "LISTSXP"; case CLOSXP: return "CLOSXP"; case ENVSXP: return "ENVSXP"; case PROMSXP: return "PROMSXP"; case LANGSXP: return "LANGSXP"; case SPECIALSXP: return "SPECIALSXP"; case BUILTINSXP: return "BUILTINSXP"; case CHARSXP: return "CHARSXP"; case LGLSXP: return "LGLSXP"; case INTSXP: return "INTSXP"; case REALSXP: return "REALSXP"; case CPLXSXP: return "CPLXSXP"; case STRSXP: return "STRSXP"; case DOTSXP: return "DOTSXP"; case ANYSXP: return "ANYSXP"; case VECSXP: return "VECSXP"; case EXPRSXP: return "EXPRSXP"; case BCODESXP: return "BCODESXP"; case EXTPTRSXP: return "EXTPTRSXP"; case WEAKREFSXP: return "WEAKREFSXP"; case RAWSXP: return "RAWSXP"; #if R_VERSION >= R_Version(4, 5, 0) case OBJSXP: return "OBJSXP"; #else case S4SXP: return "S4SXP"; #endif default: return "UNKNOWN"; } } struct InspectorParams { // Empty string indicates a placeholder node (synthetic entry, not a real R object). // The R formatter uses this to skip address and refs display. const char* addr = ""; int id = 0; bool has_seen = false; // Type string (e.g. "ENVSXP", "missing"). Use Rf_type2char() for real objects. const char* type = "NILSXP"; double length = 0; bool altrep = false; int maybe_shared = 0; int no_references = 0; bool object = false; // Shown as `` (e.g. symbol name, env name) const char* value = NULL; }; SEXP new_inspector_node(SEXP children, const InspectorParams& params) { Rf_setAttrib(children, Rf_install("addr"), PROTECT(Rf_mkString(params.addr))); Rf_setAttrib(children, Rf_install("has_seen"), PROTECT(Rf_ScalarLogical(params.has_seen))); Rf_setAttrib(children, Rf_install("id"), PROTECT(Rf_ScalarInteger(params.id))); Rf_setAttrib(children, Rf_install("type"), PROTECT(Rf_mkString(params.type))); Rf_setAttrib(children, Rf_install("length"), PROTECT(Rf_ScalarReal(params.length))); Rf_setAttrib(children, Rf_install("altrep"), PROTECT(Rf_ScalarLogical(params.altrep))); Rf_setAttrib(children, Rf_install("maybe_shared"), PROTECT(Rf_ScalarInteger(params.maybe_shared))); Rf_setAttrib(children, Rf_install("no_references"), PROTECT(Rf_ScalarInteger(params.no_references))); Rf_setAttrib(children, Rf_install("object"), PROTECT(Rf_ScalarInteger(params.object))); Rf_setAttrib(children, Rf_install("class"), PROTECT(Rf_mkString("lobstr_inspector"))); UNPROTECT(10); if (params.value != NULL) { Rf_setAttrib(children, Rf_install("value"), PROTECT(Rf_mkString(params.value))); UNPROTECT(1); } return children; } // Create a placeholder inspector node for synthetic entries (e.g. promise bindings) SEXP new_placeholder_inspector( const char* type, std::map& seen, const char* value = NULL) { SEXP out = PROTECT(Rf_allocVector(VECSXP, 0)); InspectorParams params; params.id = seen.size() + 1; params.type = type; params.value = value; new_inspector_node(out, params); UNPROTECT(1); return out; } bool is_altrep(SEXP x) { #if defined(R_VERSION) && R_VERSION >= R_Version(3, 5, 0) return ALTREP(x); #else return false; #endif } SEXP obj_inspect_(SEXP x, std::map& seen, double max_depth, Expand& expand) { int id; SEXP children; bool has_seen; if (seen.count(x)) { has_seen = true; id = seen[x]; children = PROTECT(Rf_allocVector(VECSXP, 0)); } else { has_seen = false; id = seen.size() + 1; seen[x] = id; children = PROTECT(obj_children_(x, seen, max_depth, expand)); } // Compute optional value for display const char* value = NULL; if (TYPEOF(x) == SYMSXP && PRINTNAME(x) != R_NilValue) { value = CHAR(PRINTNAME(x)); } else if (TYPEOF(x) == ENVSXP) { if (x == R_GlobalEnv) { value = "global"; } else if (x == R_EmptyEnv) { value = "empty"; } else if (x == R_BaseEnv) { value = "base"; } else { if (R_PackageEnvName(x) != R_NilValue) value = CHAR(STRING_ELT(R_PackageEnvName(x), 0)); } } std::string addr = obj_addr_(x); InspectorParams params; params.addr = addr.c_str(); params.id = id; params.has_seen = has_seen; params.type = sexptype_name(TYPEOF(x)); params.length = sxp_length(x); params.altrep = is_altrep(x); params.maybe_shared = MAYBE_SHARED(x); params.no_references = NO_REFERENCES(x); params.object = Rf_isObject(x); params.value = value; new_inspector_node(children, params); UNPROTECT(1); return children; } inline void recurse( GrowableList* children, std::map& seen, const char* name, SEXP child, double max_depth, Expand& expand) { SEXP descendents = PROTECT(obj_inspect_(child, seen, max_depth - 1, expand)); children->push_back(name, descendents); UNPROTECT(1); } SEXP obj_children_( SEXP x, std::map& seen, double max_depth, Expand expand) { GrowableList children; bool skip = false; // Handle ALTREP objects if (expand.alrep && is_altrep(x)) { #if defined(R_VERSION) && R_VERSION >= R_Version(3, 5, 0) SEXP klass = ALTREP_CLASS(x); recurse(&children, seen, "_class", klass, max_depth, expand); recurse(&children, seen, "_data1", R_altrep_data1(x), max_depth, expand); recurse(&children, seen, "_data2", R_altrep_data2(x), max_depth, expand); #endif } else if (max_depth <= 0) { switch (TYPEOF(x)) { // Non-recursive types case NILSXP: case SPECIALSXP: case BUILTINSXP: case LGLSXP: case INTSXP: case REALSXP: case CPLXSXP: case RAWSXP: case CHARSXP: case SYMSXP: skip = false; break; default: skip = true; }; } else { switch (TYPEOF(x)) { // Non-recursive types case NILSXP: case SPECIALSXP: case BUILTINSXP: case LGLSXP: case INTSXP: case REALSXP: case CPLXSXP: case RAWSXP: case CHARSXP: case SYMSXP: break; // Strings case STRSXP: if (expand.charsxp) { for (R_xlen_t i = 0; i < XLENGTH(x); i++) { recurse(&children, seen, "", STRING_ELT(x, i), max_depth, expand); } } break; // Recursive vectors case VECSXP: case EXPRSXP: case WEAKREFSXP: { SEXP names = PROTECT(Rf_getAttrib(x, R_NamesSymbol)); if (TYPEOF(names) == STRSXP) { for (R_xlen_t i = 0; i < XLENGTH(x); ++i) { recurse(&children, seen, CHAR(STRING_ELT(names, i)), VECTOR_ELT(x, i), max_depth, expand); } } else { for (R_xlen_t i = 0; i < XLENGTH(x); ++i) { recurse(&children, seen, "", VECTOR_ELT(x, i), max_depth, expand); } } UNPROTECT(1); break; } // Linked lists case LANGSXP: if (!expand.call) { skip = true; break; } case DOTSXP: case LISTSXP: { if (x == R_MissingArg) { // Needed for DOTSXP break; } SEXP cons = x; for (; is_linked_list(cons); cons = CDR(cons)) { SEXP tag = TAG(cons); if (TYPEOF(tag) == NILSXP) { recurse(&children, seen, "", CAR(cons), max_depth, expand); } else if (TYPEOF(tag) == SYMSXP) { recurse(&children, seen, CHAR(PRINTNAME(tag)), CAR(cons), max_depth, expand); } else { // TODO: add index? needs to be a list? recurse(&children, seen, "_tag", tag, max_depth, expand); recurse(&children, seen, "_car", CAR(cons), max_depth, expand); } } if (cons != R_NilValue) { recurse(&children, seen, "_cdr", cons, max_depth, expand); } break; } case BCODESXP: if (!expand.bytecode) { skip = true; break; } recurse(&children, seen, "_tag", TAG(x), max_depth, expand); recurse(&children, seen, "_car", CAR(x), max_depth, expand); recurse(&children, seen, "_cdr", CDR(x), max_depth, expand); break; // Environments case ENVSXP: { if (x == R_BaseEnv || x == R_GlobalEnv || x == R_EmptyEnv || is_namespace(x)) break; 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); const char* name = CHAR(PRINTNAME(sym)); enum r_env_binding_type type = r_env_binding_type(x, sym); switch (type) { case R_ENV_BINDING_TYPE_value: { recurse(&children, seen, name, PROTECT(r_env_get(x, sym)), max_depth, expand); UNPROTECT(1); break; } case R_ENV_BINDING_TYPE_missing: { SEXP missing = PROTECT(new_placeholder_inspector("missing", seen)); children.push_back(name, missing); UNPROTECT(1); break; } case R_ENV_BINDING_TYPE_delayed: { SEXP promise = PROTECT(new_placeholder_inspector("PROMSXP", seen)); children.push_back(name, promise); UNPROTECT(1); if (expand.env) { recurse(&children, seen, "_code", r_env_binding_delayed_expr(x, sym), max_depth, expand); recurse(&children, seen, "_env", r_env_binding_delayed_env(x, sym), max_depth, expand); } break; } case R_ENV_BINDING_TYPE_forced: { SEXP promise = PROTECT(new_placeholder_inspector("PROMSXP", seen)); children.push_back(name, promise); UNPROTECT(1); if (expand.env) { recurse(&children, seen, "_value", PROTECT(r_env_get(x, sym)), max_depth, expand); UNPROTECT(1); recurse(&children, seen, "_code", r_env_binding_forced_expr(x, sym), max_depth, expand); } break; } case R_ENV_BINDING_TYPE_active: { SEXP active = PROTECT(new_placeholder_inspector("CLOSXP", seen, "active")); children.push_back(name, active); UNPROTECT(1); if (expand.env) { recurse(&children, seen, "_fn", r_env_binding_active_fn(x, sym), max_depth, expand); } break; } case R_ENV_BINDING_TYPE_unbound: break; } } recurse(&children, seen, "_enclos", r_env_parent(x), max_depth, expand); break; } // Functions case CLOSXP: #if (R_VERSION >= R_Version(4, 5, 0)) recurse(&children, seen, "_formals", R_ClosureFormals(x), max_depth, expand); recurse(&children, seen, "_body", R_ClosureBody(x), max_depth, expand); recurse(&children, seen, "_env", R_ClosureEnv(x), max_depth, expand); #else recurse(&children, seen, "_formals", FORMALS(x), max_depth, expand); recurse(&children, seen, "_body", BODY(x), max_depth, expand); recurse(&children, seen, "_env", CLOENV(x), max_depth, expand); #endif break; case PROMSXP: // Using node-based object accessors: CAR for PRVALUE, CDR for PRCODE, and // TAG for PRENV. TODO: Iterate manually over the environment using // environment accessors. recurse(&children, seen, "_value", CAR(x), max_depth, expand); recurse(&children, seen, "_code", CDR(x), max_depth, expand); recurse(&children, seen, "_env", TAG(x), max_depth, expand); break; case EXTPTRSXP: recurse(&children, seen, "_prot", R_ExternalPtrProtected(x), max_depth, expand); recurse(&children, seen, "_tag", R_ExternalPtrTag(x), max_depth, expand); break; case S4SXP: recurse(&children, seen, "_tag", TAG(x), max_depth, expand); break; default: cpp11::stop("Don't know how to handle type %s", Rf_type2char(TYPEOF(x))); } } // CHARSXPs have fake attributes so don't inspecct them if (max_depth > 0 && TYPEOF(x) != CHARSXP && ANY_ATTRIB(x)) { recurse(&children, seen, "_attrib", PROTECT(collect_attribs(x)), max_depth, expand); UNPROTECT(1); } SEXP out = PROTECT(children.vector()); if (skip) { Rf_setAttrib(out, Rf_install("skip"), PROTECT(Rf_ScalarLogical(skip))); UNPROTECT(1); } UNPROTECT(1); return out; } // Collect attributes into a pairlist SEXP collect_attribs(SEXP x) { SEXP sentinel = PROTECT(Rf_cons(R_NilValue, R_NilValue)); SEXP tail = sentinel; R_mapAttrib(x, [](SEXP tag, SEXP val, void* data) -> SEXP { SEXP* tail = (SEXP*)data; SEXP node = Rf_cons(val, R_NilValue); SETCDR(*tail, node); SET_TAG(node, tag); *tail = node; return NULL; }, &tail); UNPROTECT(1); return CDR(sentinel); } [[cpp11::register]] cpp11::list obj_inspect_(SEXP x, double max_depth, bool expand_char = false, bool expand_altrep = false, bool expand_env = false, bool expand_call = false, bool expand_bytecode = false) { std::map seen; Expand expand = {expand_altrep, expand_char, expand_env, expand_call}; return obj_inspect_(x, seen, max_depth, expand); } lobstr/src/lobstr.cpp0000644000176200001440000000020415143625165014363 0ustar liggesusers#include extern "C" { #include } [[cpp11::register]] void init_library(SEXP env) { r_init_library(env); } lobstr/NAMESPACE0000644000176200001440000000151315143624757013014 0ustar liggesusers# Generated by roxygen2: do not edit by hand S3method("[",lobstr_bytes) S3method(c,lobstr_bytes) S3method(format,lobstr_bytes) S3method(format,lobstr_inspector) S3method(print,lobstr_bytes) S3method(print,lobstr_inspector) S3method(print,lobstr_raw) S3method(print,lobstr_srcref) S3method(tree_label,"NULL") S3method(tree_label,"function") S3method(tree_label,character) S3method(tree_label,default) S3method(tree_label,environment) S3method(tree_label,lobstr_srcfile_ref) S3method(tree_label,lobstr_srcref) S3method(tree_label,lobstr_srcref_location) S3method(tree_label,srcfile) S3method(tree_label,srcref) export(ast) export(cst) export(mem_used) export(obj_addr) export(obj_addrs) export(obj_size) export(obj_sizes) export(ref) export(src) export(sxp) export(tree) export(tree_label) import(rlang) useDynLib(lobstr, .registration = TRUE) lobstr/LICENSE0000644000176200001440000000005415104641646012572 0ustar liggesusersYEAR: 2023 COPYRIGHT HOLDER: lobstr authors lobstr/NEWS.md0000644000176200001440000000443315163463361012671 0ustar liggesusers# lobstr 1.2.1 * Fixes for CRAN checks. # lobstr 1.2.0 * New `src()` function for exploring srcref and srcfile objects. We've documented all we know about srcrefs in `?src`. * `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. * General progress towards conformance to the public C API of R. # lobstr 1.1.3 * Changes for compliance with R's public API. The main consequence is that lobstr no longer reports the `truelength` property of vectors. We also changed the `named` indicator to `refs:n`, where `n` can take the values: `0` (corresponding to `NO_REFERENCES` returning 1), `1` (corresponding to both `NO_REFERENCES` `MAYBE_SHARED` returning 0), and `2+` (`MAYBE_SHARED` returning 1). # lobstr 1.1.2 * Switched to cpp11 from Rcpp. * Relicensed as MIT (#51). * `obj_size()` and `sxp()` now support non-nil terminated pairlists. * `obj_size()` now displays large objects with KB, MB, etc (#57, #60), and no longer returns NA for objects larger than 2^31 bytes (#45). * `obj_sizes()` now computes relative sizes correctly (without meaningless floating point differences). * `ref()` lists all contents of environments even those with names beginning with `.` (@krlmlr, #53). * New, experimental `tree()` function as alternative to `str()` (#56). # lobstr 1.1.1 * Fix PROTECT error. * Remove UTF-8 characters from comments # lobstr 1.1.0 * `ref()` now handles custom classes properly (@yutannihilation, #36) * `sxp()` is a new tool for displaying the underlying C representation of an object (#38). * `obj_size()` now special cases the ALTREP "deferred string vectors" which previously crashed due to the way in which they abuse the pairlist type (#35). # lobstr 1.0.1 * `ast()` prints scalar integer and complex more accurately (#24) * `obj_addr()` no longer increments the reference count of its input (#25) * `obj_size()` now correctly computes size of ALTREP objects on R 3.5.0 (#32) lobstr/README.md0000644000176200001440000000433115105575565013055 0ustar liggesusers # lobstr lobstr website [![CRAN status](https://www.r-pkg.org/badges/version/lobstr)](https://cran.r-project.org/package=lobstr) [![R-CMD-check](https://github.com/r-lib/lobstr/actions/workflows/R-CMD-check.yaml/badge.svg)](https://github.com/r-lib/lobstr/actions/workflows/R-CMD-check.yaml) [![Codecov test coverage](https://codecov.io/gh/r-lib/lobstr/graph/badge.svg)](https://app.codecov.io/gh/r-lib/lobstr) lobstr provides tools in the same vein as `str()`, which allow you to dig into the detail of an object. ## Installation Install the released version of lobstr from CRAN: ``` r install.packages("lobstr") ``` You can install the development version with: ``` r # install.packages("pak") pak::pak("r-lib/lobstr") ``` ## Example ### Abstract syntax trees `ast()` draws the abstract syntax tree of R expressions: ``` r ast(a + b + c) #> █─`+` #> ├─█─`+` #> │ ├─a #> │ └─b #> └─c ast(function(x = 1) { if (x > 0) print("Hi!") }) #> █─`function` #> ├─█─x = 1 #> ├─█─`{` #> │ └─█─`if` #> │ ├─█─`>` #> │ │ ├─x #> │ │ └─0 #> │ └─█─print #> │ └─"Hi!" #> └─NULL ``` ### References `ref()` shows hows objects can be shared across data structures by digging into the underlying \_\_ref\_\_erences: ``` r x <- 1:1e6 y <- list(x, x, x) ref(y) #> █ [1:0x126225d88] #> ├─[2:0x1114afb90] #> ├─[2:0x1114afb90] #> └─[2:0x1114afb90] e <- rlang::env() e$self <- e ref(e) #> █ [1:0x126563548] #> └─self = [1:0x126563548] ``` A related tool is `obj_size()`, which computes the size of an object taking these shared references into account: ``` r obj_size(x) #> 680 B obj_size(y) #> 760 B ``` ### Call stack trees `cst()` shows how frames on the call stack are connected: ``` r f <- function(x) g(x) g <- function(x) h(x) h <- function(x) x f(cst()) #> ▆ #> 1. ├─f(cst()) #> 2. │ └─g(x) #> 3. │ └─h(x) #> 4. └─lobstr::cst() ``` lobstr/man/0000755000176200001440000000000015145635461012344 5ustar liggesuserslobstr/man/lobstr-package.Rd0000644000176200001440000000167315104641646015535 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/lobstr-package.R \docType{package} \name{lobstr-package} \alias{lobstr} \alias{lobstr-package} \title{lobstr: Visualize R Data Structures with Trees} \description{ \if{html}{\figure{logo.png}{options: style='float: right' alt='logo' width='120'}} A set of tools for inspecting and understanding R data structures inspired by str(). Includes ast() for visualizing abstract syntax trees, ref() for showing shared references, cst() for showing call stack trees, and obj_size() for computing object sizes. } \seealso{ Useful links: \itemize{ \item \url{https://lobstr.r-lib.org/} \item \url{https://github.com/r-lib/lobstr} \item Report bugs at \url{https://github.com/r-lib/lobstr/issues} } } \author{ \strong{Maintainer}: Hadley Wickham \email{hadley@posit.co} Other contributors: \itemize{ \item Posit Software, PBC [copyright holder, funder] } } \keyword{internal} lobstr/man/tree.Rd0000644000176200001440000000576715143624757013615 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/tree.R \name{tree} \alias{tree} \title{Pretty tree-like object printing} \usage{ tree( x, ..., index_unnamed = FALSE, max_depth = 10L, max_length = 1000L, max_vec_len = 10L, show_environments = TRUE, hide_scalar_types = TRUE, val_printer = crayon::blue, class_printer = crayon::silver, show_attributes = FALSE, remove_newlines = TRUE, tree_chars = box_chars() ) } \arguments{ \item{x}{A tree like object (list, etc.)} \item{...}{Ignored (used to force use of names)} \item{index_unnamed}{Should children of containers without names have indices used as stand-in?} \item{max_depth}{How far down the tree structure should be printed. E.g. \code{1} means only direct children of the root element will be shown. Useful for very deep lists.} \item{max_length}{How many elements should be printed? This is useful in case you try and print an object with 100,000 items in it.} \item{max_vec_len}{How many elements should be printed for vectors?} \item{show_environments}{Should environments be treated like normal lists and recursed into?} \item{hide_scalar_types}{Should atomic scalars be printed with type and length like vectors? E.g. \code{x <- "a"} would be shown as \verb{x: "a"} instead of \code{x: "a"}.} \item{val_printer}{Function that values get passed to before being drawn to screen. Can be used to color or generally style output.} \item{class_printer}{Same as \code{val_printer} but for the the class types of non-atomic tree elements.} \item{show_attributes}{Should attributes be printed as a child of the list or avoided?} \item{remove_newlines}{Should character strings with newlines in them have the newlines removed? Not doing so will mess up the vertical flow of the tree but may be desired for some use-cases if newline structure is important to understanding object state.} \item{tree_chars}{List of box characters used to construct tree. Needs elements \verb{$h} for horizontal bar, \verb{$hd} for dotted horizontal bar, \verb{$v} for vertical bar, \verb{$vd} for dotted vertical bar, \verb{$l} for l-bend, and \verb{$j} for junction (or middle child).} } \value{ console output of structure } \description{ A cleaner and easier to read replacement for \code{str} for nested list-like objects } \examples{ x <- list( list(id = "a", val = 2), list( id = "b", val = 1, children = list( list(id = "b1", val = 2.5), list( id = "b2", val = 8, children = list( list(id = "b21", val = 4) ) ) ) ), list( id = "c", val = 8, children = list( list(id = "c1"), list(id = "c2", val = 1) ) ) ) # Basic usage tree(x) # Even cleaner output can be achieved by not printing indices tree(x, index_unnamed = FALSE) # Limit depth if object is potentially very large tree(x, max_depth = 2) # You can customize how the values and classes are printed if desired tree(x, val_printer = function(x) { paste0("_", x, "_") }) } lobstr/man/ast.Rd0000644000176200001440000000163215143624757013430 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/ast.R \name{ast} \alias{ast} \title{Display the abstract syntax tree} \usage{ ast(x) } \arguments{ \item{x}{An expression to display. Input is automatically quoted, use \verb{!!} to unquote if you have already captured an expression object.} } \description{ This is a useful alternative to \code{str()} for expression objects. } \examples{ # Leaves ast(1) ast(x) # Simple calls ast(f()) ast(f(x, 1, g(), h(i()))) ast(f()()) ast(f(x)(y)) ast((x + 1)) # Displaying expression already stored in object x <- quote(a + b + c) ast(x) ast(!!x) # All operations have this same structure ast(if (TRUE) 3 else 4) ast(y <- x * 10) ast(function(x = 1, y = 2) { x + y } ) # Operator precedence ast(1 * 2 + 3) ast(!1 + !1) } \seealso{ Other object inspectors: \code{\link{ref}()}, \code{\link{src}()}, \code{\link{sxp}()} } \concept{object inspectors} lobstr/man/mem_used.Rd0000644000176200001440000000123713256202040014414 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/mem.R \name{mem_used} \alias{mem_used} \title{How much memory is currently used by R?} \usage{ mem_used() } \description{ \code{mem_used()} wraps around \code{gc()} and returns the exact number of bytes currently used by R. Note that changes will not match up exactly to \code{\link[=obj_size]{obj_size()}} as session specific state (e.g. \link{.Last.value}) adds minor variations. } \examples{ prev_m <- 0; m <- mem_used(); m - prev_m x <- 1:1e6 prev_m <- m; m <- mem_used(); m - prev_m obj_size(x) rm(x) prev_m <- m; m <- mem_used(); m - prev_m prev_m <- m; m <- mem_used(); m - prev_m } lobstr/man/obj_size.Rd0000644000176200001440000000513313500655217014433 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/size.R \name{obj_size} \alias{obj_size} \alias{obj_sizes} \title{Calculate the size of an object.} \usage{ obj_size(..., env = parent.frame()) obj_sizes(..., env = parent.frame()) } \arguments{ \item{...}{Set of objects to compute size.} \item{env}{Environment in which to terminate search. This defaults to the current environment so that you don't include the size of objects that are already stored elsewhere. Regardless of the value here, \code{obj_size()} never looks past the global or base environments.} } \value{ An estimate of the size of the object, in bytes. } \description{ \code{obj_size()} computes the size of an object or set of objects; \code{obj_sizes()} breaks down the individual contribution of multiple objects to the total size. } \section{Compared to \code{object.size()}}{ Compared to \code{\link[=object.size]{object.size()}}, \code{obj_size()}: \itemize{ \item Accounts for all types of shared values, not just strings in the global string pool. \item Includes the size of environments (up to \code{env}) \item Accurately measures the size of ALTREP objects. } } \section{Environments}{ \code{obj_size()} attempts to take into account the size of the environments associated with an object. This is particularly important for closures and formulas, since otherwise you may not realise that you've accidentally captured a large object. However, it's easy to over count: you don't want to include the size of every object in every environment leading back to the \code{\link[=emptyenv]{emptyenv()}}. \code{obj_size()} takes a heuristic approach: it never counts the size of the global environment, the base environment, the empty environment, or any namespace. Additionally, the \code{env} argument allows you to specify another environment at which to stop. This defaults to the environment from which \code{obj_size()} is called to prevent double-counting of objects created elsewhere. } \examples{ # obj_size correctly accounts for shared references x <- runif(1e4) obj_size(x) z <- list(a = x, b = x, c = x) obj_size(z) # this means that object size is not transitive obj_size(x) obj_size(z) obj_size(x, z) # use obj_size() to see the unique contribution of each component obj_sizes(x, z) obj_sizes(z, x) obj_sizes(!!!z) # obj_size() also includes the size of environments f <- function() { x <- 1:1e4 a ~ b } obj_size(f()) #' # In R 3.5 and greater, `:` creates a special "ALTREP" object that only # stores the first and last elements. This will make some vectors much # smaller than you'd otherwise expect obj_size(1:1e6) } lobstr/man/obj_addr.Rd0000644000176200001440000000162113500655217014371 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/address.R \name{obj_addr} \alias{obj_addr} \alias{obj_addrs} \title{Find memory location of objects and their children.} \usage{ obj_addr(x) obj_addrs(x) } \arguments{ \item{x}{An object} } \description{ \code{obj_addr()} gives the address of the value that \code{x} points to; \code{obj_addrs()} gives the address of the components the list, environment, and character vector \code{x} point to. } \details{ \code{obj_addr()} has been written in such away that it avoids taking references to an object. } \examples{ # R creates copies lazily x <- 1:10 y <- x obj_addr(x) == obj_addr(y) y[1] <- 2L obj_addr(x) == obj_addr(y) y <- runif(10) obj_addr(y) z <- list(y, y) obj_addrs(z) y[2] <- 1.0 obj_addrs(z) obj_addr(y) # The address of an object is different every time you create it: obj_addr(1:10) obj_addr(1:10) obj_addr(1:10) } lobstr/man/figures/0000755000176200001440000000000015104641646014005 5ustar liggesuserslobstr/man/figures/logo.png0000644000176200001440000006540315104641646015463 0ustar liggesusersPNG  IHDRޫh cHRMz&u0`:pQ<bKGDtIME -ejTIDATxw|$u`r̐Ü)Jle+~}a>}om9ʖ [dI( %1pHN Uu:4r>UWs2 8avI?):fjkeO#_>ԥeL䭏20[|%`oy`M^6LN:F7I&R%r.2~c~LMF#=:y6^,]_̵Dh " d+4+|^ݱcw$X巎5(035ǥnpRHlf^AQ(x#Q& O rVd|w0 p:8ɻP\*BE`d`g{kTJ[-c7D~0L@d~jV2UU]mvp筺a5L} g2:40jM1(7 e >$ HU5uMBD\o0;=aH'I`k2YoG $౽?}ʚVDBcLMpu:tWKdxiVlq]P&!OwR ˗vp4֣ bțYK F9 hڪa2(ey22'PTÉ{q`7Ncr>$k"^.zis{̓e"ed~?Y&A~yw]w:ȡwrMB_D$LZe"ey27W2IP#?}*oEBe~^Fj"#[|lq(xȓ"#d<6fN{Fl6ۆIV] jh" )Mm{%UU oJr2uQΟ@0d!m;dǟW:I^ R@UU9SSY7-mo/[W2>*U>$>,l_"oYG*dƯGW:I\A c?#UU9Avצ^rda7 ͭlypy[큳DZѪeV](H^ {bw-& `n:j܈ #Wcc폷ŬʓD ރ ,\Ce#'EaAmcw=z}[='9iN\ao]7V9{>X4]H^L.saW 9lQP5&fU{O 2ġQ{dOjյTVdVݴ#Vͦ.U.#fa-vfVvEfuuɭlVo9!CC+Zu յ*$(%u*>VFF}ry\v4rFӵmrFbx;pr%訽ClE"o筺GKXusjj Tf˫aNq{]^E)xB ^d u}5D#ed쨽D'pq;g%cf?Vr9L *+;l9\dw DHDRTx+줴an"3ނ$u*D.iރLi@**+L1;%WcO?,;l LreJ5E`J%9d~#e~`2?Eq97Dfv >LcL&8Kg#֖RIhqGJud}lfM^Xh?!GIFHx<T%ZE dY~/e&;qykh'[t_)pVɵ~E>6Kb2JǴ>ڳlĦt(k|Lck *O רmbV*kQUUezb*=ChN&"@-n8ni>YkTդ/p9U$5I0>4,.zߛ堲OǑ]T<(Y,. %ܠ@J[U 2{R(MGS\wڳ,Z{y=o@';8p}am325( Ģ o9DϲUfS]uw51|^6h$#O2> p&,zTV`ٶ݊Q5X}pyLpN>|Aoy^05: SMii"dYT37!M+~TnӅb-!s"WR֧(eKhJ#š#c>an^I& &ֽPd"H߸E+xiFGl6lMEUܐRi2;%CP$%aqyVgpǁg+m`f9f"5ȲA*}6^JwqEQ st]'Iz ʫ"+ H15:p8L%ΑEC}*NۍUe ߄,pC '{;ԯ s?z}T-A1]#dJnr֞'i `$p"/6YZ&QMvptn*s]w.D^ˉai4ArH˶(\<]HO"F~k/s@9xO ! 1;&-6B]#;{ެEpWV09:fe.T78]R47cry%[6. Dx6峷px^Bd|2Djn8ႲEy6d"Kn,*Y, gm'EslZ{ƈFCa{}ڲCE!mUUUzi]K:>V5PҿHQ:[c٬=GwSf sSa.7Nh,\8V]2'3yjٞGJ}BWzCjp㲻p]y!o!)Fz^ڦJix4Qgsc++py++h@î<nGhM1!C=c %4_k;wӲS&C8ihav2 H]OHhw!kϗYʉ,ߑuW$Ϙ *. ˇBQT n;;He9 ]u-A$]^`wکmbϑVj+@*19:í}\6C=c$bRؿ)h:N@#7̿\y+96n͑s$.cGeV--5WWD)11<"E8I<qu?r%xz͛R-rxpڝ9r6 @K8[_Z=kE>ȪlcLϥ'#}Oвak煯!̹t"3sL0=1G4CKy_c' őh(EjRqa>݅ JO mﴳa!ݍƦ̗5PUu&&sD U8B u/TP,2ys(0?ŗ:Iē9uK4T=A[kcMj*ך,2HIMˬ[vIiwvrWIdRRQUeC}G y7Ӱ&64M39:6 ݷihȌZҀn#H{~r'b2&/<|0./++=$㩂T6'l Ӌ$Ғ+6&p>W'͹'4-gJ)ŽNa@U}}w=-9$cz|nVh0=.sQkG߷"/xBO+2QKBHpvxsWRƼH-*R]mi=GZ-zC)TE  N=|*P+goP]~WZ0JjL}mIRɔU?k=N޽-9cY !à yӷƏaGKiEs;cV'S ù(awuV$WGe9ҝBZa[{5鬪 3!'̵ V8aj+4u156pR/uN97 C[ndbx냌 NLCHyͺ*ݹǒWgϙefxaH%|gQ*[5.:a) bqBU}"W黕.t$ݣj)'#6Jck MULwsqѤUG"=2Ql\D4T.n:jiQwC7H%5?/pϑt!!2;.YY1Tѣ9Eq:/k^"NFUaSp v{S]{5ots|7|2Vzkh]'N͘B@u}@#_b#CmS%:LڗItLWVVϮ=VVv bsaZj,o?`5il%hxU!Mp\7҅9. iq̓OdaQ)tޅ`G!ZNH,lI ݗ Æ.h)9w^=7̸"08RuksV_wAf&d%UQw|7ڛk7M;L}mn)S2cK6WLɡjSq{3roE=4=;oy١ '._Frfk7 Bw~ot) 9r%6fucB*k>Sx.S*}V^% &LxGWKɌ)GTU8<^*Te4+qģ |A/31,HDQMڏ6 U` $sM89| w D!a' PU_S%j7s_`o7F4e6:RYm+xq(6Clyf{KG= (BDXrD5e|hY"6v ]LhMǵo#tJ6VRYsge凎!!=PT˝g#VEzo"[!mF&ywaw6%n.0 TM l"5´Kl!@3(.2;f6[ Vp9U0WkA*"4ertɑjek^df23!n^5yM)sEU}٩Ъ+c PT"zM9~(37fמFD,oC7H&RDB1f'CL2=!{j)ûs5G.g^bg̺>HS[=5:CKQ<> jPUus %5Azo l":Eb骺Oa0k--HE˞@uF"" DMGEEhLiզ6- gOܺP]:OrTCKAmcezU5t}M߶bj,j%MV ^r9 kn%5XD,A, ?x -r9Fu`8tC`KP_H$DK4RȮ zwD!E ^^&r 31H_CȽ09ϔS{n+Tt/^'NdoThޣo P,t2ICf` ߼^G)⧈ Xp u =)m0z TсtXӭ ݣ[^7 ՏFZ VSX}#P) M 4-w4 Aӏqwm&U:ĢԴLщɩϵcA< x2yOrj.j*eyv)I90fݫ/fz%^̛"96U>؜Ӏ+47ퟤ>HmSMx*\V/3祈GNabd٩0H].[M01<ͭK}w"o4J?79]ܼKKG}N@tk-)x#7UZH' ,]T9t8\y.|)b8ZJOP w 7/Ҹm6]"\fLI5 L5Zn5[K`o”Uhn:Nw}6VHLꐧ\>+l#~若aS4ʫH&E!zd\=SSA.XrU'ń.x`@3ۊ9;YbHF4_@j?WXY }m g5 Xn"F*5NQ`zlUąY!YBo+J20 Ks+$Mĉl*w>zWŬ|8:07u}M7nӰ``R(b_ PЂ&j h(x`:z˪m&`nǨa׈kV,q.y +c2z4/R\lIVQ>%!s3uQ67]&.ȘhJ&pLnvEUbe҂;9i>kĬ9_0I9><]"E ŘtXtMgn*727Gk9]RUh(Ϋ] uE( zJ.BQ+ ŘAז&f A8689/Ӯ$)Y{j \BR8IQUiޞ QϫPool9⑥ C ze-Ț2Q&pBAK{=,?dڐ u,{Jzf#D#qfqNmEKQ 2#MD6MϑJ}% \B8p#Q^7ZE!и-XI8HIf0>4y:ݎa2" SXQirtfR.AkUZJy{ f%l&FqdstX((0>8Mj [.n9Qn=P&pAdVtɹ0g^N"\K!SP[(L"S!f z煐]E5XsѢ<\tz \b먪 :g{}p%~%|&H|Y$y"o![ȴ%O&R L-:EWy"u2Q&p A;(4)`bdt[R0[X)cLcE1_%}/ݠbX')&Ggj+9;l5W0JSEčAG&g+gb!,uG $6Dyw-j DmF&H&R8]8tj"=Ea?PϘy q((LX&(LcUuE MUv%=aT`n*uP^K 䨏^w>|ڦQ)B<Il{ =@,Ih:ݼ DBgЇ_7/1p{$'qrxnk2mo@U~`.Xz"^? \bPUwک( +RbEIBB*)!zUIOrR5ɽli)IkLDLvx-fGyg齿ZО.UU=ThWQFgegl*U`}UͤLN233%&wg3owhfj|.X镾t`=tMOuH4 b8Ñܺ܋0j?I4i `-M068EemCگ+M]<jS ۣ$5W壼l6U&dS%#<|4^*rVBnFg%KrR7/pN.Ih&ޣqV߽G[w+go131Wp5eýтcݶ$)#stWR&1^cA2*UXAו~jh?Ԝpq8kbbd~:jDEЃaGtC=RM6G&91Mx6"P]\es!<!XBƃ]'XrѤ ^؜Ϻq³ Ġ h~n~XKj\:sC mP?7*ҵ `{]Hfp *^Eb8 zN,#q-X4AQ$C* N2Wwq讽(ji4*T/^'MZ%rpѣ1vi}Mzlv`eYM`?ކ(*+hj`g{N31T&n6 Ok260o}/[ A u29:[zƸuNPdž,FLsc+BF;28C2tS\Eu}_e.C:>q@ NîfB+NFA& "˶8Ph+qv}syT\uCBG(`ő.} Yf]d*(4SV4ˎ) զX箥d8OQ]Gv9(Xtelen,42 .;60pƄQ&p LȏExk1 {_#*imdMQ%[v#lf8%)YSJ;L;E2aW;7tAJ(* sL )+ukV=J}KU|[RY3ԸygW_(Tgoq8]vN AîZZ:p{]vuHi(}u196FdJMSx+T蛳VD{sm2{Mɞ#<g?.dN& NֈmEaj|dwt-5cv0TU-t`:M0E㵤@:dYbaAy{ ialƙFKb(DPL_ EZXYQl秒tM,Ask\'U4cjl"V! V T2KF ,5Ɩ:l.Rڊ1.TT>WI 뉴~M a6 ύnd6B3f&CC&P6VÎ!pvFg#H\) z \ٟk~NcE_}buRHo3Вct:hh!vŶ/jgz|>*-Ql0?~C']gмMtbUG!US,Bv8)7+i+|^uEchIͺƖ:.%E^-=M:Gvzڷ{^~]ӽ:]ӉaG;bpkocQ} ێ6:3Mk: xn!'SZQf&Cf")JNͶ}1 =cv麱aKzv*ff>HύAt]_Ae%KfEQp7vl^C27t9eGmUrv`Һvچm޾(f"Ģ 8 "Eh!_p854쪡6-],f(ѽ~}4$i}D^MQfc6T#T$ z)tԍ MY^-3p{ /]ϞJ2&Zl< t $HTR-q6bXժ<ʪmz;LO O:K23q$I.tɂ] AUU60d(I܏j. !^77޾2K `|h- ( ňcM׻ʆ/Y`E> :Qde9]A_el d8dDh6Jj(L2>4]wZbuLHte2=1(l**入2c tЍ5mC"@7 ٟg.whSx3`hQ{aÐFf8b νTJg7( JQB/IRIʇÎҘ37eOuEbo`*Vq$I8ZJ[qi(ҞXq^l|"Gv,J\)RI ہ/CQs?΃"V9Qz(4 xlNh6B߭a2=ŪPddOvOsͣuMgv:ĵ]GZDli9@x.Fx6\ ͮw9L,,)DQ٩saꚪVxPi 2`w?vwS=Z̍?XAz~/tW.Y\XF>|`BQa9nFh:B]S5-m$DH@UTk7c"NR&0CS5U8q8q5jXR؆2o}C07O rC6w7~<ԝ8 *'/5kUYX^$V 0 _|=q@f蚬M YYZJtt9m,>ֻ>m/|u%+8vz?.j* 3O27 *~.;s3.rcT9vz?GGG]c } 2rX8d^{*pޛCd}*-E>[Q\8]"+(P&0roV!Cg47 x3]c^n6~mu 3;Yziw܃r'9<#E-qKzoy04ajl2ˣw_|/O|3]!F󱧨o|Kv23?Ȓ"4T6PDfDUm0poH\)(B*u/gPpusc8\K]CU=*+p( .vw4$F&N?rl[]3p8֭jh^`\QG2? ~*}a|/rǗGMU6L3C++'_Ya DI'9UVo]-mRPaF&m;;)žTL!R/\Hu_x+m-b CXOYU]|)|AoC-Mp|<kG:w/-$ejQXY$<ŦnOcsGure&8xx"^ZV)ǕtHf]S ͭE²)WQepDZ?ˢAz>Ko(!w`tVvu4fDdȆnp+uMUKL/~_E,XjYdL%5"8lPh ,1ECs&^1EaYqEPHͦn*FHb 4!4xGy@3`^:S8q!h h[2!d}E~<َd"Ui)8L*? UEN;U>C'ѿhQ=~Na{=brIj??o2CboyCO<>~ӅM->D)R ENĒP)^>+9͹ Wh'Bu]:EQblxE( uMUܼh|™‡Qiۼ)||PS||qn/}sko,tc;gPT{;νH&Rєh^ VPŘ 8R ԰ޱ%!dBB۾ ȦӶk/\R3Nx{o Yf1!c2]ӹ-t=s#Ǩ\dGG۾&$7L?U%BֱF&X0+V#n:k<ԝhvc|?uU2407FEq}L4J!.~-oY8ub"gۀ"nN{}Gwc5dx+•siw޻h"ak4rN|to;`g-5<އX0~|H8*ģI.|\yZj+o,*VN0Th{gN-=NO~Hk&~?}OOT" 7ZhզOXanx‘S{Ɔg\]ƻ~I}씘|Tt*k|מ`fs01<7-aI{hfSsV|#NQ".tJ-^GXpGv3o\<'_kk}GSK:ރxǞbfl6]״Vԋ6N7Z+ȉvr?iCc g6k`9GOpc8?\8s=0dEMcU8\n P+b7Bex.J"qWi]br|"aU>>eϡE!??@L9Ĺ_4}kFU"(X2I=n,]{G;LG_Cqj|^zn ĩdߑTgX5M[<3dWEQrR*F5>;#XV| M4U>[jr C7HgQ^ٍٛ++hn󀪺M8EH+13ԷV[+S >N)xv[ +@)<ǬxbyJ.+nCKiܾ6]uA}?櫀|l(bS&W8p-TPU\1n^kD<`9]3|G [b|.{sYrj|[W{~ty qc8]tI!vocw/?fvu4Q7cl`p8(JxE ]M_L.'[h?t]_~1=STI}VZ`]dwd25okYIqayT,ypd;'8n+;OϵAP@ O1}vz E\}kx#M9x4YO[2@( ]ËV&ɾ.Ƈ~icK/pks=qNzg#\z&_,.!'$R b:Y8zY* NgRsDN?F$cjt]zݳ;;W?}~s.+n5\c8/w_/Ǟ.P.X~~w_9yO ?!2#HEvf=L4'GgTj+&&392jSeI^*~|#kx}<7^x4,.񽯼[\<ۙyLJX C/>Ϸc\VjaoXcrl alv^ -5 ZY`n:̕sB)FP]ӹ|&rdl_8p8`)`(=D1v.k GDBQeڛ cmKNtM/ݸ@VD0x暢d"Yc3KV@>j%CLm EZK!8x**) P^+d: `l`PfXq7/l%,UartLOx X~=NN[8r羢9M7> q ,0ҵJ/c=`z/s]`!s *L2=0MEUUțLq{TRn\264)t[]#?+ܼ;}rGӂƖx4ELJ1tڦ*Tݮ⯬`od̗>a{O<~tYDk( s3a.E4GU"v?{VKŁ%O{`1 5]d6KޮPǽm'8뤺>ȱ{sW,*Mo ǭ A:~]<=x*|?KW$ hh#̂jS|֢^mUU  hD6R/fsJ7)FRj഻4q[6r#++5/^{apOs[=|qy*^c]ӹuijׄ/१soshI px%%K8է ]gCt?wsr"hzX* BQ UQq]m[0{CMa<  h'X_h1?[~K^RXţ (=Y#SUuG*ߒ?"HbV MHb$Aq9Y x*FJOrqݙd`΃|JAk?f/Ÿ+CRfC՛ȜCC7hi#̒q"ؿlnABH =,v` X:;< VnKFIjعM톥 Sd]ѣ+D/p7A!d;A M?cCSEIK JPRKOt->-*4i`v'"HeelK,\4ѥ ]$OH8?t^.ZX*BS!"j; !;kȕx7PtJJvJn褴$6Ն2(Dq^*o|Y>7ʊVt_)^4 X*F,E32]5h Q{zva9#gY5RzL2l23]% *n_RK'7l&2s\|ED[sKHfġg yg"? sYnpjకe, 3eN}M:3]d|xjK8$Uo{0w_\G@,"+]~X 8N Í}y,c*F;ِHx*FRK.+[k25YDvo~xe쏳/ d:p[fuKTJ?&RqZܪ/sցO0&< ]pvW:d(c 2A2  > #0a\@qK_|eƏ!oNt2b `,7̓IJ>-*p?Ҭ~Y8 ;2Jns%nˤ=Ċ>5^d"od<T[:-U-Q2(M`"iEstX-&V̎<w/{W2^,[, ARKUc7gJ <"F:>T/wlR&,;N_ b\)qM3lG~ x p-w٢CƏ˲26/%+$nrc '5_ڲ2!d٘?.X{/7? qM 瀏#˄Hl,[,c]ɰH_ =yal"'_;V؉D.cUB,P}n2R)tt YDvO OcYr-e<7X>W~~]WٞEJW2Vflptʲ2D>W$R #\)OHO31 &03;VYXr2Sm6mO-V,wlŰ2(߫, (lR'[|+2-!ʲ2Vuby5Q3:Ϭ> pp%]v'JY'ēk"$#7n6yDl";VlSN0?W&s$ YD-U]v'lqbe~F/F$ l"ddi :tP}U6 %?kF2=+/?vqYe222a`)M2 䧀UNXc 2 O'-7cd"꧐iŌGҁIjNL"?L\SFaKм8@FxJƛ?vi%uGyaDw-.w,PN,-HU)7nE3'{XlѬi+7 r} mլ̓->->jd A~~~H m7 V*2c+o1bѵzd5]%#2n'6}yD~d,yY(wX_b"c 6n730)[ DXN\ A |Mm=Mdك- BflewEbe~/!-JDQQ3lH⁕7DYX& ol"_>$P&QX7IFw6-OGvClCFLl_Ez٢S6S2kg6 eyDރ-4@2122.`Ck<ȴw厵ٲE@5k {x"( ȓ- ?~5-nu>[H"(xgV!Nlضlllє%RHEF7f,wQ&:"$0%$[\22qeod"ocղEY d/X]X(|i.Y&L D}ddwuAFU2 G< Y)g0ʲXYk(EoP&&!+;R5_B. ȓ->FFXXd R22$(DE ɕ?""re_ILBǑ/[L@vE__yLA%<)lݬ@BAz2F%-oLZAYQ&Z0 =eߖD[ dfn~DYeQ&EoR\Ex&;vC[dF*x $Y2m2 t[%$Ƒ2Oûm7 '[|OH2m$;ZvTtEXtSoftwareAdobe ImageReadyqe<IENDB`lobstr/man/src.Rd0000644000176200001440000002621515145635461013430 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/src.R \name{src} \alias{src} \title{Display tree of source references} \usage{ src(x, max_depth = 5L, max_length = 100L, ...) } \arguments{ \item{x}{An R object with source references. Can be: \itemize{ \item A \code{srcref} object \item A list of \code{srcref} objects \item A expression vector with attached source references \item An evaluated closure with attached source references \item A quoted call with attached source references }} \item{max_depth}{Maximum depth to traverse nested structures (default 5)} \item{max_length}{Maximum number of srcref nodes to display (default 100)} \item{...}{Additional arguments passed to \code{\link[=tree]{tree()}}} } \value{ Returns a structured list containing the source reference information. Print it to view the formatted tree. } \description{ View source reference metadata attached to R objects in a tree structure. Shows source file information, line/column locations, and lines of source code. } \section{Overview}{ Source references are made of two kinds of objects: \itemize{ \item \code{srcref} objects, which contain information about a specific location within the source file, such as the line and column numbers. \item \code{srcfile} objects, which contain metadata about the source file such as its name, path, and encoding. } \subsection{Where and when are source references created?}{ Ultimately the R parser creates source references. The main two entry points to the parser are: \itemize{ \item The R function \code{parse()}. \item The frontend hook \code{ReadConsole}, which powers the console input parser in the R CLI and in IDEs. This C-level parser can also be accessed from C code via \code{R_ParseVector()}. } In principle, anything that calls \code{parse()} may create source references, but here are the important direct and indirect callers: \itemize{ \item \code{source()} and \code{sys.source()} which parse and evaluate code. \item \code{loadNamespace()} calls \code{sys.source()} when loading a \emph{source} package: \url{https://github.com/r-devel/r-svn/blob/acd196be/src/library/base/R/namespace.R#L573}. \item \verb{R CMD install} creates a lazy-load database from a source package. The first step is to call \code{loadNamespace()}: \url{https://github.com/r-devel/r-svn/blob/acd196be/src/library/tools/R/makeLazyLoad.R#L32} } By default source references are not created but can be enabled by: \itemize{ \item Passing \code{keep.source = TRUE} explicitly to \code{parse()}, \code{source()}, \code{sys.source()}, or \code{loadNamespace()}. \item Setting \code{options(keep.source = TRUE)}. This affects the default arguments of the aforementioned functions, as well as the console input parser. In interactive sessions, \code{keep.source} is set to \code{TRUE} by default: \url{https://github.com/r-devel/r-svn/blob/3a4745af/src/library/profile/Common.R#L26}. \item Setting \code{options(keep.source.pkgs = TRUE)}. This affects loading a package from source, and installing a package from source. } } \subsection{\code{srcref} objects}{ \code{srcref} objects are compact integer vectors describing a character range in a source. It records start/end lines and byte/column positions and, optionally, the parsed-line numbers if \verb{#line} directives were used. Lengths of 4, 6, or 8 are allowed: \itemize{ \item 4: basic (first_line, first_byte, last_line, last_byte). Byte positions are within the line. \item 6: adds columns in Unicode codepoints (first_col, last_col) \item 8: adds parsed-line numbers (first_parsed, last_parsed) } The "column" information does not represent grapheme clusters, but Unicode codepoints. The column cursor is incremented at every UTF-8 lead byte and there is no support for encodings other than UTF-8. The srcref columns are right-boundary positions, meaning that for an expression starting at the start of a line, the column will be 1. \code{wholeSrcref} (see below) on the other hand starts at 0, before the first character. It might also end 1 character after the last srcref column. They are attached as attributes (e.g. \code{attr(x, "srcref")} or \code{attr(x, "wholeSrcref")}), possibly wrapped in a list, to the following objects: \itemize{ \item Expression vectors returned by \code{parse()} (wrapped in a list) \item Quoted function calls (unwrapped) \item Quoted \verb{\{} calls (wrapped in a list). This is crucial for debugging: when R steps through brace lists, the srcref for the current expression is saved to a global variable (\code{R_Srcref}) so the IDE knows exactly where execution is paused. See: \url{https://github.com/r-devel/r-svn/blob/fa0b47c5/src/main/eval.c#L2986}. \item Evaluated closures (unwrapped) } They have a \code{srcfile} attribute that points to the source file. Methods: \itemize{ \item \code{as.character()}: Retrieves relevant source lines from the \code{srcfile} reference. } \subsection{\code{wholeSrcref} attributes}{ These are \code{srcref} objects stored in the \code{wholeSrcref} attributes of: \itemize{ \item Expression vectors returned by \code{parse()}, which seems to be the intended usage. \item \verb{\{} calls, which seems unintended. } For expression vectors, the \code{wholeSrcref} spans from the first position to the last position and represents the entire document. For braces, they span from the first position to the location of the closing brace. There is no way to know the location of the opening brace without reparsing, which seems odd. It's probably an overlook from \code{xxexprlist()} calling \code{attachSrcrefs()} in \url{https://github.com/r-devel/r-svn/blob/52affc16/src/main/gram.y#L1380}. That function is also called at the end of parsing, where it's intended for the \code{wholeSrcref} attribute to be attached. For evaluated closures, the \code{wholeSrcref} attribute on the body has the same unreliable start positions as \verb{\{} nodes. } } \subsection{\code{srcfile} objects}{ \code{srcfile} objects are environments representing information about a source file that a source reference points to. They typically refer to a file on disk and store the filename, working directory, a timestamp, and encoding information. While it is possible to create bare \code{srcfile} objects, specialized subclasses are much more common. \subsection{\code{srcfile}}{ A bare \code{srcfile} object does not contain any data apart from the file path. It lazily loads lines from the file on disk, without any caching. Fields common to all \code{srcfile} objects: \itemize{ \item \code{filename}: The filename of the source file. If relative, the path is resolved against \code{wd}. \item \code{wd}: The working directory (\code{getwd()}) at the time the srcfile was created, generally at the time of parsing). \item \code{timestamp}: The timestamp of the source file. Retrieved from \code{filename} with \code{file.mtime()}. \item \code{encoding}: The encoding of the source file. \item \code{Enc}: The encoding of output lines. Used by \code{getSrcLines()}, which calls \code{iconv()} when \code{Enc} does not match \code{encoding}. \item \code{parseData} (optional): Parser information saved when \code{keep.source.data} is set to \code{TRUE}. } Implementations: \itemize{ \item \code{print()} and \code{summary()} to print information about the source file. \item \code{open()} and \code{close()} to access the underlying file as a connection. } Helpers: \itemize{ \item \code{getSrcLines()}: Retrieves source lines from a \code{srcfile}. } } \subsection{\code{srcfilecopy}}{ A \code{srcfilecopy} stores the actual source lines in memory in \verb{$lines}. \code{srcfilecopy} is useful when the original file may change or does not exist, because it preserves the exact text used by the parser. This type of srcfile is the most common. It's created by: \itemize{ \item The R-level \code{parse()} function when \code{text} is supplied: \if{html}{\out{
}}\preformatted{# Creates a `""` non-file `srcfilecopy` parse(text = "...", keep.source = TRUE) }\if{html}{\out{
}} \item The console's input parser when \code{getOption("keep.source")} is \code{TRUE}. \item \code{sys.source()} when \code{keep.source = TRUE}: \if{html}{\out{
}}\preformatted{sys.source(file, keep.source = TRUE) }\if{html}{\out{
}} The \code{srcfilecopy} object is timestamped with the file's last modification time. \url{https://github.com/r-devel/r-svn/blob/52affc16/src/library/base/R/source.R#L273-L276} } Fields: \itemize{ \item \code{filename}: The filename of the source file. If \code{isFile} is \code{FALSE}, the field is non meaningful. For instance \code{parse(text = )} sets it to \code{""}, and the console input parser sets it to \code{""}. \item \code{isFile}: A logical indicating whether the source file exists. \item \code{fixedNewlines}: If \code{TRUE}, \code{lines} is a character vector of lines with no embedded \verb{\\n} characters. The \code{getSrcLines()} helper regularises \code{lines} in this way and sets \code{fixedNewlines} to \code{TRUE}. } Note that the C-level parser (used directly mainly when parsing console input) does not call the R-level constructor and only instantiates the \code{filename} (set to \code{""}) and \code{lines} fields. } \subsection{\code{srcfilealias}}{ This object wraps an existing \code{srcfile} object (stored in \code{original}). It allows exposing a different \code{filename} while delegating the open/close/get lines operations to the \code{srcfile} stored in \code{original}. The typical way aliases are created is via \verb{#line *line* *filename*} directives where the optional \verb{*filename*} argument is supplied. These directives remap the srcref and srcfile of parsed code to a different location, for example from a temporary file or generated file to the original location on disk. Created by \code{install.packages()} when installing a \emph{source} package with \code{keep.source.pkgs} set to \code{TRUE} (see \url{https://github.com/r-devel/r-svn/blob/52affc16/src/library/tools/R/install.R#L545}), but \href{https://github.com/r-devel/r-svn/blob/52affc16/src/library/tools/R/admin.R#L308}{only when}: \itemize{ \item \code{Encoding} was supplied in \code{DESCRIPTION} \item The system locale is not "C" or "POSIX". } The source files are converted to the encoding of the system locale, then collated in a single source file with \verb{#line} directives mapping them to their original file names (with full paths): \url{https://github.com/r-devel/r-svn/blob/52affc16/src/library/tools/R/admin.R#L342}. Note that the \code{filename} of the \code{original} srcfile incorrectly points to the package path in the install destination. Fields: \itemize{ \item \code{filename}: The virtual file name (or full path) of the parsed code. \item \code{original}: The actual \code{srcfile} the code was parsed from. } } } } \seealso{ \itemize{ \item \code{\link[=srcfile]{srcfile()}}: Base documentation for \code{srcref} and \code{srcfile} objects. \item \code{\link[=getParseData]{getParseData()}}: Parse information stored when \code{keep.source.data} is \code{TRUE}. \item Source References (R Journal): \url{https://journal.r-project.org/articles/RJ-2010-010/} } Other object inspectors: \code{\link{ast}()}, \code{\link{ref}()}, \code{\link{sxp}()} } \concept{object inspectors} lobstr/man/tree_label.Rd0000644000176200001440000000112015104641646014720 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/tree.R \name{tree_label} \alias{tree_label} \title{Build element or node label in tree} \usage{ tree_label(x, opts) } \arguments{ \item{x}{A tree like object (list, etc.)} \item{opts}{A list of options that directly mirrors the named arguments of \link{tree}. E.g. \code{list(val_printer = crayon::red)} is equivalent to \code{tree(..., val_printer = crayon::red)}.} } \description{ These methods control how the value of a given node is printed. New methods can be added if support is needed for a novel class } lobstr/man/ref.Rd0000644000176200001440000000176015143624757013417 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/ref.R \name{ref} \alias{ref} \title{Display tree of references} \usage{ ref(..., character = FALSE) } \arguments{ \item{...}{One or more objects} \item{character}{If \code{TRUE}, show references from character vector in to global string pool} } \description{ This tree display focusses on the distinction between names and values. For each reference-type object (lists, environments, and optional character vectors), it displays the location of each component. The display shows the connection between shared references using a locally unique id. } \examples{ x <- 1:100 ref(x) y <- list(x, x, x) ref(y) ref(x, y) e <- new.env() e$e <- e e$x <- x e$y <- list(x, e) ref(e) # Can also show references to global string pool if requested ref(c("x", "x", "y")) ref(c("x", "x", "y"), character = TRUE) } \seealso{ Other object inspectors: \code{\link{ast}()}, \code{\link{src}()}, \code{\link{sxp}()} } \concept{object inspectors} lobstr/man/cst.Rd0000644000176200001440000000212713256202040013406 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/cst.R \name{cst} \alias{cst} \title{Call stack tree} \usage{ cst() } \description{ Shows the relationship between calls on the stack. This function combines the results of \code{\link[=sys.calls]{sys.calls()}} and \code{\link[=sys.parents]{sys.parents()}} yielding a display that shows how frames on the call stack are related. } \examples{ # If all evaluation is eager, you get a single tree f <- function() g() g <- function() h() h <- function() cst() f() # You get multiple trees with delayed evaluation try(f()) # Pay attention to the first element of each subtree: each # evaluates the outermost call f <- function(x) g(x) g <- function(x) h(x) h <- function(x) x try(f(cst())) # With a little ingenuity you can use it to see how NSE # functions work in base R with(mtcars, {cst(); invisible()}) invisible(subset(mtcars, {cst(); cyl == 0})) # You can also get unusual trees by evaluating in frames # higher up the call stack f <- function() g() g <- function() h() h <- function() eval(quote(cst()), parent.frame(2)) f() } lobstr/man/sxp.Rd0000644000176200001440000000372515143626242013447 0ustar liggesusers% Generated by roxygen2: do not edit by hand % Please edit documentation in R/sxp.R \name{sxp} \alias{sxp} \title{Inspect an object} \usage{ sxp(x, expand = character(), max_depth = 5L) } \arguments{ \item{x}{Object to inspect} \item{expand}{Optionally, expand components of the true that are usually suppressed. Use: \itemize{ \item "character" to show underlying entries in the global string pool. \item "environment" to show binding components without any side effects (e.g. promises or active bindings). \item "altrep" to show the underlying data. \item "call" to show the full AST (but \code{\link[=ast]{ast()}} is usually superior) \item "bytecode" to show generated bytecode. }} \item{max_depth}{Maximum depth to recurse. Use \code{max_depth = Inf} (with care!) to recurse as deeply as possible. Skipped elements will be shown as \code{...}.`} } \description{ \code{sxp(x)} is similar to \code{.Internal(inspect(x))}, recursing into the C data structures underlying any R object. The main difference is the output is a little more compact, it recurses fully, and avoids getting stuck in infinite loops by using a depth-first search. It also returns a list that you can compute with, and carefully uses colour to highlight the most important details. } \details{ The name \code{sxp} comes from \code{SEXP}, the name of the C data structure that underlies all R objects. } \examples{ x <- list( TRUE, 1L, runif(100), "3" ) sxp(x) # Expand "character" to see underlying CHARSXP entries in the global # string pool x <- c("banana", "banana", "apple", "banana") sxp(x) sxp(x, expand = "character") # Expand altrep to see underlying data x <- 1:10 sxp(x) sxp(x, expand = "altrep") # Expand environments to see promise expressions without forcing e <- new.env(parent = emptyenv()) delayedAssign("x", 1 + 1, assign.env = e) sxp(e) sxp(e, expand = "environment") } \seealso{ Other object inspectors: \code{\link{ast}()}, \code{\link{ref}()}, \code{\link{src}()} } \concept{object inspectors} lobstr/DESCRIPTION0000644000176200001440000000225415164116517013277 0ustar liggesusersPackage: lobstr Title: Visualize R Data Structures with Trees Version: 1.2.1 Authors@R: c( person("Hadley", "Wickham", , "hadley@posit.co", role = c("aut", "cre")), person("Posit Software, PBC", role = c("cph", "fnd")) ) Description: A set of tools for inspecting and understanding R data structures inspired by str(). Includes ast() for visualizing abstract syntax trees, ref() for showing shared references, cst() for showing call stack trees, and obj_size() for computing object sizes. License: MIT + file LICENSE URL: https://lobstr.r-lib.org/, https://github.com/r-lib/lobstr BugReports: https://github.com/r-lib/lobstr/issues Depends: R (>= 3.6.0) Imports: crayon, methods, prettyunits, rlang (>= 1.0.0) Suggests: covr, pillar, pkgdown, testthat (>= 3.0.0) LinkingTo: cpp11 (>= 0.4.2) Config/Needs/website: tidyverse/tidytemplate Config/testthat/edition: 3 Encoding: UTF-8 RoxygenNote: 7.3.3 Config/build/compilation-database: true NeedsCompilation: yes Packaged: 2026-04-03 09:34:59 UTC; lionel Author: Hadley Wickham [aut, cre], Posit Software, PBC [cph, fnd] Maintainer: Hadley Wickham Repository: CRAN Date/Publication: 2026-04-04 05:10:39 UTC