Refuse reassignment between scalar and array shapes

check_assignment_compatible() exempted any assignment where either side
was length 1, so the two shape changes R handles by rebinding the symbol
went undiagnosed in both directions:

  x <- numeric(n); x <- 0   broadcast 0 across every element (R: length 1)
  x <- 1; x <- numeric(3)   kept only the first element (R: length 3)

Only the both-sides-length-1 case is genuinely compatible (a declared
double(1) is rank 1, a literal is rank 0), so exempt that and let
everything else reach the shape checks. Deferred-shape locals still
reallocate for an array value, as before.

Three declare()-size-expression tests assigned a scalar into an array
target as a way of reaching the size validator; they now use the same
size expression on both sides, which reaches the intended error without
depending on the exemption.

Author: mns-nordicals

NEWS.md

@@ -19,9 +19,12 @@
   `x <- numeric(2); x <- numeric(3)`) is a compile-time error;
   dimensions that cannot be compared at compile time are checked at run
   time. Previously such reassignments silently kept the old shape or
-  produced invalid Fortran. Assigning a scalar into an array variable
-  (native Fortran broadcast) is unchanged, as are locals declared with
-  unknown (`NA`) dims, which reallocate on assignment like R.
+  produced invalid Fortran. This also covers reassignment between a scalar
+  and an array in either direction: `x <- numeric(n); x <- 0` used to
+  broadcast the scalar across every element, and assigning an array to a
+  scalar variable used to keep only its first element, where R rebinds the
+  symbol in both cases. Locals declared with unknown (`NA`) dims still
+  reallocate on assignment, like R.
 
 - Elementwise operations (arithmetic, comparisons, `&`, `|`) now require
   operand lengths to match, unless one operand is a scalar or a vector is

R/r2f-operators-helpers.R

@@ -626,9 +626,38 @@ check_assignment_compatible <- function(
   ) {
     return(invisible())
   }
-  if (passes_as_scalar(target) || passes_as_scalar(value)) {
+  target_scalar <- passes_as_scalar(target)
+  value_scalar <- passes_as_scalar(value)
+  # Two length-1 values conform whatever their ranks (a declared `double(1)`
+  # is rank 1; a literal is rank 0).
+  if (target_scalar && value_scalar) {
     return(invisible())
   }
+  deferred_local <- !target@is_external && has_self_size_dims(target)
+  if (target_scalar || value_scalar) {
+    # A deferred-shape local can genuinely take a new array shape.
+    if (deferred_local && !value_scalar) {
+      return(invisible())
+    }
+    # Otherwise one side is length 1 and the other is a real array. R
+    # rebinds the symbol to the new shape; Fortran cannot, and would
+    # silently broadcast a scalar across the array (or drop all but the
+    # first element of an array into a scalar).
+    stop(
+      "cannot reassign `",
+      name,
+      "`: replacement is ",
+      if (value_scalar) "a scalar" else "an array",
+      " but `",
+      name,
+      "` is ",
+      if (target_scalar) "a scalar" else "an array",
+      "; R would rebind `",
+      name,
+      "` to the new shape",
+      call. = FALSE
+    )
+  }
   if (target@rank != value@rank) {
     stop(
       "cannot reassign `",
@@ -643,7 +672,7 @@ check_assignment_compatible <- function(
       call. = FALSE
     )
   }
-  if (!target@is_external && has_self_size_dims(target)) {
+  if (deferred_local) {
     # deferred-shape local: implicit (re)allocation matches R's rebind
     return(invisible())
   }

tests/testthat/_snaps/size-constraint.md

@@ -5,7 +5,7 @@
     Output
       function(a, b) {
           declare(type(a = double(n)), type(b = double(n + 1)))
-          a <- sum(b)
+          a <- a + sum(b)
           a
         }
       <environment: 0x0>
@@ -26,7 +26,7 @@
         ! manifest end
       
       
-        a = sum(b)
+        a = (a + sum(b))
       end subroutine
     Code
       cat(cwrapper)

tests/testthat/test-assignment-shape.R

@@ -87,12 +87,55 @@ test_that("shape-preserving reassignments still compile", {
   }
   expect_quick_identical(fn_same, c(1, 2, 3))
 
-  # scalar broadcast into an array target keeps working
-  fn_scalar <- function(a) {
+  # two length-1 values conform whatever their ranks: a declared double(1)
+  # is rank 1, a literal is rank 0
+  fn_len1 <- function(a) {
+    declare(type(a = double(1)))
+    a <- 2
+    a
+  }
+  expect_quick_identical(fn_len1, 1)
+})
+
+test_that("reassignment between scalar and array shapes is refused", {
+  # R rebinds `x` to the scalar; Fortran would broadcast it across the
+  # array, so every element would change instead of the shape
+  fn_scalar_into_array <- function(a) {
     declare(type(a = double(n)))
     x <- a
     x <- 0
     sum(x)
   }
-  expect_no_error(r2f(fn_scalar))
+  expect_error(
+    r2f(fn_scalar_into_array),
+    "replacement is a scalar but `x` is an array",
+    fixed = TRUE
+  )
+
+  # the reduction form of the same mistake
+  fn_reduce_into_array <- function(a) {
+    declare(type(a = double(n)))
+    x <- a
+    x <- sum(x)
+    x
+  }
+  expect_error(
+    r2f(fn_reduce_into_array),
+    "replacement is a scalar but `x` is an array",
+    fixed = TRUE
+  )
+
+  # the other direction: R rebinds to the array, Fortran would keep only
+  # the first element
+  fn_array_into_scalar <- function(a) {
+    declare(type(a = double(3)))
+    x <- 1
+    x <- a
+    x
+  }
+  expect_error(
+    r2f(fn_array_into_scalar),
+    "replacement is an array but `x` is a scalar",
+    fixed = TRUE
+  )
 })

tests/testthat/test-size-constraint.R

@@ -5,7 +5,7 @@ skip_on_cran()
 test_that("size constraint", {
   fn <- function(a, b) {
     declare(type(a = double(n)), type(b = double(n + 1)))
-    a <- sum(b)
+    a <- a + sum(b)
     a
   }
 
@@ -20,7 +20,9 @@ test_that("size constraint", {
     fixed = TRUE
   )
   expect_translation_snapshots(fn, "call_size_constraint")
-  expect_equal(qfn(1, c(2, 3)), 5)
+  # `a` stays an array: reassigning a scalar into it would be a shape
+  # change, which R does by rebinding and Fortran cannot do at all
+  expect_equal(qfn(1, c(2, 3)), 6)
 })
 
 test_that("size constraint", {

tests/testthat/test-size-expr-abs.R

@@ -29,7 +29,7 @@ test_that("declare() size expressions validate abs() arity", {
       type(m = integer(1)),
       type(out = double(abs(n, m)))
     )
-    out <- double(1L)
+    out <- double(abs(n, m))
     out
   }
 

tests/testthat/test-size-expr-dim-nrow-ncol.R

@@ -42,12 +42,12 @@ test_that("declare() size expressions support dim(x)[axis] indices", {
 test_that("declare() size expressions validate nrow()/ncol() arity", {
   bad_nrow <- function(x) {
     declare(type(x = double(NA, NA)), type(out = double(nrow(x, 1L))))
-    out <- double(1L)
+    out <- double(nrow(x, 1L))
     out
   }
   bad_ncol <- function(x) {
     declare(type(x = double(NA, NA)), type(out = double(ncol(x, 1L))))
-    out <- double(1L)
+    out <- double(ncol(x, 1L))
     out
   }
 
@@ -68,7 +68,7 @@ test_that("declare() size expressions reject ncol() beyond variable rank", {
 test_that("declare() size expressions reject unsupported calls", {
   bad <- function(n) {
     declare(type(n = integer(1)), type(out = double(sum(n))))
-    out <- double(1L)
+    out <- double(sum(n))
     out
   }