Merge pull request #73 from t-kalinowski/fix/nonfinal-statements-60

Reject bare non-final expressions

Author: t-kalinowski

R/aaa-utils.R

@@ -116,6 +116,26 @@ drop_nulls <- function(x, i) {
 
 last <- function(x) x[[length(x)]]
 drop_last <- function(x) x[-length(x)]
+
+compile_nonreturn_statements <- function(stmts, scope) {
+  if (!length(stmts)) {
+    return("")
+  }
+
+  compiled <- lapply(stmts, function(stmt) {
+    stmt_f <- r2f(stmt, scope)
+    if (!is.null(stmt_f@value)) {
+      stop(
+        "all expressions except the final return must compile to a statement (no value); found: ",
+        deparse1(stmt),
+        call. = FALSE
+      )
+    }
+    stmt_f
+  })
+
+  str_flatten_lines(compiled)
+}
 # fmt: skip
 {
 is_scalar_na      <- function(x) is.atomic(x)    && !is.object(x) && length(x) == 1L && is.na(x)

R/r2f-closures.R

@@ -168,16 +168,12 @@ compile_internal_subroutine <- function(
     if (is.null(last(stmts))) {
       stmts <- drop_last(stmts)
     }
-    if (length(stmts)) {
-      body_prefix <- lapply(stmts, function(stmt) r2f(stmt, proc_scope))
-      body_prefix <- str_flatten_lines(body_prefix)
-    }
+    body_prefix <- compile_nonreturn_statements(stmts, proc_scope)
   } else {
     last_expr <- last(stmts)
     prefix <- drop_last(stmts)
 
-    body_prefix <- lapply(prefix, function(stmt) r2f(stmt, proc_scope))
-    body_prefix <- str_flatten_lines(body_prefix)
+    body_prefix <- compile_nonreturn_statements(prefix, proc_scope)
 
     h <- new_hoist(proc_scope)
     expr_error <- NULL

R/subroutine.R

@@ -30,7 +30,8 @@ new_fortran_subroutine <- function(
   #   declare(type(foo = integer(foo_dim_1_, foo_dim_2_)),
   #           type(bar = integer(foo_dim_1_, 3L)))
   body <- substitute_declared_sizes(body)
-  body <- r2f(drop_last(body), scope)
+  stmts <- as.list(body)[-1L]
+  body <- compile_nonreturn_statements(drop_last(stmts), scope)
 
   # check all input vars were declared
   # TODO: this check might be too late, because r2f() might throw cryptic errors

tests/testthat/test-errors.R

@@ -7,3 +7,63 @@ test_that("case-sensitive variable name clashes", {
     })
   })
 })
+
+test_that("non-final expressions must be assigned", {
+  expect_error(regexp = "all expressions except the final return", {
+    quick(function(x) {
+      declare(type(x = double(1)))
+      x + 1
+      x
+    })
+  })
+
+  expect_error(regexp = "all expressions except the final return", {
+    quick(function(x) {
+      declare(type(x = double(1)))
+      x
+      x
+    })
+  })
+
+  expect_error(regexp = "all expressions except the final return", {
+    quick(function(x) {
+      declare(type(x = double(1)))
+      x <- x + 1
+      x + 1
+      x
+    })
+  })
+})
+
+test_that("value-returning local closures can be called as statements", {
+  fn <- function(x) {
+    declare(type(x = double(1)))
+
+    apply_boundary_conditions <- function() {
+      x <<- x + 1
+    }
+
+    apply_boundary_conditions()
+    x
+  }
+
+  # r2f(fn)
+
+  expect_quick_identical(fn, list(1))
+
+  fn <- function(x) {
+    declare(type(x = double(1)))
+
+    apply_boundary_conditions <- function() {
+      x <<- x + 1
+      x
+    }
+
+    apply_boundary_conditions()
+    x
+  }
+
+  # r2f(fn)
+
+  expect_quick_identical(fn, list(1))
+})