Merge pull request #72 from t-kalinowski/fix/fallthrough-assignment

Fix fall-through assignment (a <- b <- expr)

Author: t-kalinowski

NEWS.md

@@ -58,6 +58,9 @@
 - Fixed an issue where subsetting logical arrays could fail when compiling quick
   functions, e.g. `(x > 0)[2, 3]` (#68).
 
+- Fixed a crash when compiling chained / fall-through assignments like
+  `a <- b <- 1` (#60).
+
 # quickr 0.2.1
 
 - Added support for `!` and unary `-` and `+` (#49, @mns-nordicals)

R/r2f.R

@@ -1147,15 +1147,15 @@ r2f_handlers[["cbind"]] <- function(e, scope) {
   ncols <- eval(ncols, scope@sizes)
 }
 
-r2f_handlers[["<-"]] <- function(args, scope, ...) {
+r2f_handlers[["<-"]] <- function(args, scope, ..., hoist = NULL) {
   target <- args[[1]]
   if (is.call(target)) {
     # given a call like `foo(x) <- y`, dispatch to `foo<-`
     target_callable <- target[[1]]
     stopifnot(is.symbol(target_callable))
     name <- as.symbol(paste0(as.character(target_callable), "<-"))
     handler <- get_r2f_handler(name)
-    return(handler(args, scope, ...)) # new hoist target
+    return(handler(args, scope, ..., hoist = hoist)) # new hoist target
   }
 
   # It sure seems like it's be nice if the Fortran() constructor
@@ -1166,6 +1166,37 @@ r2f_handlers[["<-"]] <- function(args, scope, ...) {
 
   rhs <- args[[2]]
 
+  # Fall-through assignment: `a <- b <- expr` (or `a <- (b <- expr)`).
+  # R evaluates this right-to-left and returns the assigned value, i.e.
+  # `a <- (b <- expr)` is equivalent to `b <- expr; a <- b`.
+  rhs_unwrapped <- rhs
+  while (is_call(rhs_unwrapped, "(") && length(rhs_unwrapped) == 2L) {
+    rhs_unwrapped <- rhs_unwrapped[[2L]]
+  }
+  if (
+    (is_call(rhs_unwrapped, "<-") || is_call(rhs_unwrapped, "=")) &&
+      length(rhs_unwrapped) == 3L &&
+      is.symbol(rhs_unwrapped[[2L]])
+  ) {
+    inner_target <- rhs_unwrapped[[2L]]
+    inner_rhs <- rhs_unwrapped[[3L]]
+
+    inner_stmt <- r2f(
+      call("<-", inner_target, inner_rhs),
+      scope,
+      ...,
+      hoist = hoist
+    )
+    outer_stmt <- r2f(
+      call("<-", target, inner_target),
+      scope,
+      ...,
+      hoist = hoist
+    )
+
+    return(Fortran(str_flatten_lines(inner_stmt, outer_stmt)))
+  }
+
   # Local closure definition: `f <- function(i) ...`
   if (is_function_call(rhs)) {
     scope[[name]] <- as_local_closure(
@@ -1182,15 +1213,21 @@ r2f_handlers[["<-"]] <- function(args, scope, ...) {
       is.symbol(rhs[[1L]]) &&
       inherits(scope[[as.character(rhs[[1L]])]], LocalClosure)
   ) {
-    return(compile_closure_call_assignment(name, rhs, scope, ...))
+    return(compile_closure_call_assignment(
+      name,
+      rhs,
+      scope,
+      ...,
+      hoist = hoist
+    ))
   }
 
   # Targeted higher-order lowering: `out <- sapply(seq_along(x), f)`
   if (is_sapply_call(rhs)) {
-    return(compile_sapply_assignment(name, rhs, scope, ...))
+    return(compile_sapply_assignment(name, rhs, scope, ..., hoist = hoist))
   }
 
-  value <- r2f(rhs, scope, ...)
+  value <- r2f(rhs, scope, ..., hoist = hoist)
 
   # immutable / copy-on-modify usage of Variable()
   var <- get0(name, scope, inherits = FALSE)

tests/testthat/test-fallthrough-assignment.R

@@ -0,0 +1,28 @@
+test_that("fall-through assignment is supported", {
+  expect_quick_identical(
+    function(x) {
+      declare(type(x = double(1)))
+      a <- b <- 1
+      x + a + b
+    },
+    8
+  )
+
+  expect_quick_identical(
+    function(x) {
+      declare(type(x = double(1)))
+      a <- (b <- 1)
+      x + a + b
+    },
+    8
+  )
+
+  expect_quick_identical(
+    function(x) {
+      declare(type(x = double(1)))
+      a <- b <- c <- x + 1
+      a + b + c
+    },
+    8
+  )
+})