lhs may now assign anything, re #32

R/operator.R

@@ -195,6 +195,9 @@
     },
     invalid_rhs = function(e) {
       stop("invalid `%<-%` right-hand side, ", e$message, call. = FALSE)
+    },
+    error = function(e) {
+      stop("problem in `%<-%`, ", e$message, call. = FALSE)
     }
   )
 }
@@ -209,6 +212,9 @@
     },
     invalid_rhs = function(e) {
       stop("invalid `%->%` left-hand side, ", e$message, call. = FALSE)
+    },
+    error = function(e) {
+      stop("problem in `%->%`, ", e$message, call. = FALSE)
     }
   )
 }
@@ -235,7 +241,10 @@ multi_assign <- function(x, value, env) {
   # standard assignment, no calls (i.e. `c`) found
   #
   if (is.null(internals)) {
-    assign(as.character(ast), value, envir = env)
+    assign(lhs, value, envir = env)
+    return(invisible(value))
+  } else if (length(internals) == 1 && internals %in% c("[[", "[", "$")) {
+    replace_assign(lhs, value, envir = env)
     return(invisible(value))
   }
 
@@ -266,6 +275,11 @@ multi_assign <- function(x, value, env) {
     name <- t[["name"]]
     val <- t[["value"]]
 
+    if (is.language(name)) {
+      replace_assign(name, val, envir = env)
+      next
+    }
+
     #
     # collector variable names retain the leading "..." in order to revert
     # list values back to vectors if necessary

R/pair-off.R

@@ -1,5 +1,5 @@
 pair_off <- function(names, values, env) {
-  if (is.character(names)) {
+  if (is.character(names) || is.language(names)) {
     if (names == ".") {
       return()
     }

R/utils.R

@@ -16,6 +16,10 @@ cdr <- function(cons) {
   cons[-1]
 }
 
+names2 <- function(x) {
+  if (is.null(names(x))) rep.int("", length(x)) else names(x)
+}
+
 default <- function(x) {
   attr(x, "default", exact = TRUE)
 }
@@ -32,8 +36,10 @@ add_defaults <- function(names, values, env) {
   append(values, evaled)
 }
 
-names2 <- function(x) {
-  if (is.null(names(x))) rep.int("", length(x)) else names(x)
+replace_assign <- function(call, value, envir = parent.frame()) {
+  replacee <- call("<-", call, value)
+  eval(replacee, envir = envir)
+  invisible(value)
 }
 
 tree <- function(x) {
@@ -64,7 +70,7 @@ calls <- function(x) {
 
   this <- car(x)
 
-  if (this != "c" && this != "=") {
+  if (!(as.character(this) %in% c("c", "=", "$", "[", "[["))) {
     stop_invalid_lhs(unexpected_call(this))
   }
 
@@ -95,6 +101,10 @@ variables <- function(x) {
     attr(var, "default") <- default
 
     return(var)
+  } else if (car(x) == "$" || car(x) == "[[" || car(x) == "[") {
+    parts <- as.call(x)
+
+    return(parts)
   }
 
   lapply(cdr(x), variables)