Enforce the ifelse() branch-shape contract

ifelse() promoted branch modes and rejected scalar-test/array-branch
calls, but never validated branch shapes against `test`. Fortran's
merge() requires conformable arguments, so a runtime length mismatch
read past the shorter branch and returned garbage where R recycles.

A non-scalar branch must now match the shape of `test`: statically
unequal dims (including rank mismatches) are a compile error, and
symbolic dims emit a statement-level runtime size guard, matching the
elementwise-operator policy. NA dims always count as unknown -- two
unknown lengths are not the same quantity.

Author: mns-nordicals

R/r2f-conditionals.R

@@ -1,16 +1,86 @@
 # r2f-conditionals.R
 # Handlers for vectorized conditionals: ifelse
 
-# --- Handlers ---
+# --- Local Helpers ---
 
-r2f_handlers[["ifelse"]] <- function(args, scope, ...) {
-  .[mask, tsource, fsource] <- lapply(args, r2f, scope, ...)
-  mask <- booleanize_logical_as_int(mask)
+ifelse_branch_shape_msg <- paste0(
+  "ifelse() `yes` and `no` must be scalars or match the shape of `test`; ",
+  "R-style recycling is not supported"
+)
 
-  # merge() requires same-typed branches; promote both to their common mode.
-  promoted <- promote_operands(list(tsource, fsource), context = "ifelse()")
-  .[tsource, fsource] <- promoted$args
-  mode <- promoted$mode
+# Three-valued conformability verdict for one axis of an ifelse() branch
+# against `test`: ok+known (no guard), not-ok+known (compile error), or
+# unknown (runtime guard). NA dims are always unknown: two unknown lengths
+# are not the same quantity.
+ifelse_axis_verdict <- function(test_dim, branch_dim) {
+  if (is_wholenumber(test_dim) && is_wholenumber(branch_dim)) {
+    return(list(
+      ok = identical(as.integer(test_dim), as.integer(branch_dim)),
+      unknown = FALSE
+    ))
+  }
+  if (!is_scalar_na(test_dim) && !is_scalar_na(branch_dim)) {
+    test_norm <- fortranize_expr_symbols(test_dim)
+    branch_norm <- fortranize_expr_symbols(branch_dim)
+    if (identical(test_norm, branch_norm)) {
+      return(list(ok = TRUE, unknown = FALSE))
+    }
+  }
+  list(ok = TRUE, unknown = TRUE)
+}
+
+# Enforce the shape contract for one ifelse() branch: scalars broadcast
+# natively; a non-scalar branch must match `test`'s shape, because
+# merge() requires conformable arguments and a runtime mismatch would
+# read past the shorter branch. Statically unequal dims are a compile
+# error; symbolic dims get a statement-level runtime size guard.
+check_ifelse_branch_shape <- function(branch, mask, hoist, scope) {
+  if (passes_as_scalar(branch@value)) {
+    return(invisible())
+  }
+  if (branch@value@rank != mask@value@rank) {
+    stop(ifelse_branch_shape_msg, call. = FALSE)
+  }
+  unknown_axes <- integer()
+  for (axis in seq_len(mask@value@rank)) {
+    verdict <- ifelse_axis_verdict(
+      dim_or_one(mask, axis),
+      dim_or_one(branch, axis)
+    )
+    if (!verdict$ok) {
+      stop(ifelse_branch_shape_msg, call. = FALSE)
+    }
+    if (verdict$unknown) {
+      unknown_axes <- c(unknown_axes, axis)
+    }
+  }
+  if (!length(unknown_axes)) {
+    return(invisible())
+  }
+  if (is.null(hoist)) {
+    stop(
+      "cannot emit a runtime length guard here; ",
+      "ifelse() branch lengths must match `test` statically",
+      call. = FALSE
+    )
+  }
+  # size() is an inquiry, so applying it to operand expression text does
+  # not evaluate the operands.
+  condition <- str_flatten(
+    map_chr(
+      unknown_axes,
+      function(axis) glue("size({branch}, {axis}) /= size({mask}, {axis})")
+    ),
+    " .or. "
+  )
+  emit_quickr_error_if(condition, ifelse_branch_shape_msg, hoist, scope)
+  invisible()
+}
+
+# --- Handlers ---
+
+r2f_handlers[["ifelse"]] <- function(args, scope, ..., hoist = NULL) {
+  .[mask, tsource, fsource] <- lapply(args, r2f, scope, ..., hoist = hoist)
 
   # R: the result is shaped like `test` (branches only contribute values).
   # A scalar test with array branches is not representable with merge().
@@ -25,6 +95,17 @@ r2f_handlers[["ifelse"]] <- function(args, scope, ...) {
     )
   }
 
+  # Checked before casts so guards splice the bare operand text.
+  check_ifelse_branch_shape(tsource, mask, hoist, scope)
+  check_ifelse_branch_shape(fsource, mask, hoist, scope)
+
+  mask <- booleanize_logical_as_int(mask)
+
+  # merge() requires same-typed branches; promote both to their common mode.
+  promoted <- promote_operands(list(tsource, fsource), context = "ifelse()")
+  .[tsource, fsource] <- promoted$args
+  mode <- promoted$mode
+
   Fortran(
     glue("merge({tsource}, {fsource}, {mask})"),
     Variable(mode, mask@value@dims)

tests/testthat/_snaps/ifelse.md

@@ -79,3 +79,132 @@
         return out_;
       }
 
+# ifelse guards unknown branch lengths at runtime
+
+    Code
+      fn
+    Output
+      function(c, a, b) {
+          declare(type(c = logical(NA)), type(a = double(NA)), type(b = double(NA)))
+          ifelse(c, a, b)
+        }
+      <environment: 0x0>
+    Code
+      cat(fsub)
+    Output
+      subroutine fn(c, a, b, out_, a__len_, b__len_, c__len_, quickr_err_msg) bind(c)
+        use iso_c_binding, only: c_char, c_double, c_int, c_null_char, c_ptrdiff_t
+        implicit none
+      
+        ! manifest start
+        ! sizes
+        integer(c_ptrdiff_t), intent(in), value :: c__len_
+        integer(c_ptrdiff_t), intent(in), value :: a__len_
+        integer(c_ptrdiff_t), intent(in), value :: b__len_
+      
+        ! error
+        character(kind=c_char), intent(inout) :: quickr_err_msg(256)
+      
+        ! args
+        integer(c_int), intent(in) :: c(c__len_) ! logical
+        real(c_double), intent(in) :: a(a__len_)
+        real(c_double), intent(in) :: b(b__len_)
+        real(c_double), intent(out) :: out_(c__len_)
+        ! manifest end
+      
+      
+        if (size(a, 1) /= size((c/=0), 1)) then
+      call quickr_set_error_msg("ifelse() `yes` and `no` must be scalars or match the shape of `test`; R-style recycling is not&
+      & supported")
+          return
+        end if
+        if (size(b, 1) /= size((c/=0), 1)) then
+      call quickr_set_error_msg("ifelse() `yes` and `no` must be scalars or match the shape of `test`; R-style recycling is not&
+      & supported")
+          return
+        end if
+        out_ = merge(a, b, (c/=0))
+      
+        contains
+          subroutine quickr_set_error_msg(msg)
+            character(len=*), intent(in) :: msg
+            integer :: i
+            integer :: n
+            if (quickr_err_msg(1) == c_null_char) then
+              n = min(len(msg), 256 - 1)
+              quickr_err_msg(1:n) = [(msg(i:i), i = 1, n)]
+              quickr_err_msg(n + 1) = c_null_char
+            end if
+          end subroutine quickr_set_error_msg
+      end subroutine
+    Code
+      cat(cwrapper)
+    Output
+      #define R_NO_REMAP
+      #include <R.h>
+      #include <Rinternals.h>
+      
+      
+      extern void fn(
+        const int* const c__, 
+        const double* const a__, 
+        const double* const b__, 
+        double* const out___, 
+        const R_xlen_t a__len_, 
+        const R_xlen_t b__len_, 
+        const R_xlen_t c__len_, 
+        char* quickr_err_msg);
+      
+      SEXP fn_(SEXP _args) {
+        // c
+        _args = CDR(_args);
+        SEXP c = CAR(_args);
+        if (TYPEOF(c) != LGLSXP) {
+          Rf_error("typeof(c) must be 'logical', not '%s'", Rf_type2char(TYPEOF(c)));
+        }
+        const int* const c__ = LOGICAL(c);
+        const R_xlen_t c__len_ = Rf_xlength(c);
+        
+        // a
+        _args = CDR(_args);
+        SEXP a = CAR(_args);
+        if (TYPEOF(a) != REALSXP) {
+          Rf_error("typeof(a) must be 'double', not '%s'", Rf_type2char(TYPEOF(a)));
+        }
+        const double* const a__ = REAL(a);
+        const R_xlen_t a__len_ = Rf_xlength(a);
+        
+        // b
+        _args = CDR(_args);
+        SEXP b = CAR(_args);
+        if (TYPEOF(b) != REALSXP) {
+          Rf_error("typeof(b) must be 'double', not '%s'", Rf_type2char(TYPEOF(b)));
+        }
+        const double* const b__ = REAL(b);
+        const R_xlen_t b__len_ = Rf_xlength(b);
+        
+        const R_xlen_t out___len_ = c__len_;
+        SEXP out_ = PROTECT(Rf_allocVector(REALSXP, out___len_));
+        double* out___ = REAL(out_);
+        
+        char quickr_err_msg[256];
+        quickr_err_msg[0] = '\0';
+        
+        
+        fn(
+          c__,
+          a__,
+          b__,
+          out___,
+          a__len_,
+          b__len_,
+          c__len_,
+          quickr_err_msg);
+        if (quickr_err_msg[0] != '\0') {
+          Rf_error("%s", quickr_err_msg);
+        }
+        
+        UNPROTECT(1);
+        return out_;
+      }
+

tests/testthat/test-ifelse.R

@@ -50,3 +50,31 @@ test_that("ifelse with scalar test and array branch errors cleanly", {
   }
   expect_error(quick(fn), "shape of `test`")
 })
+
+test_that("ifelse with statically mismatched branch lengths is a compile error", {
+  fn <- function(c, a) {
+    declare(type(c = logical(3)), type(a = double(2)))
+    ifelse(c, a, 0)
+  }
+  expect_error(quick(fn), "R-style recycling is not supported")
+})
+
+test_that("ifelse guards unknown branch lengths at runtime", {
+  fn <- function(c, a, b) {
+    declare(type(c = logical(NA)), type(a = double(NA)), type(b = double(NA)))
+    ifelse(c, a, b)
+  }
+  # locks the size guards: a bare merge() with runtime-mismatched
+  # assumed-shape vectors read past the shorter branch (returned garbage
+  # like 4.65e-310 where R recycles)
+  expect_translation_snapshots(fn)
+  qfn <- quick(fn)
+
+  cc <- c(TRUE, FALSE, TRUE)
+  a <- c(10, 20, 30)
+  b <- c(1, 2, 3)
+  expect_identical(qfn(cc, a, b), ifelse(cc, a, b))
+
+  expect_error(qfn(cc, c(10, 20), b), "match the shape of `test`")
+  expect_error(qfn(cc, a, c(1, 2, 3, 4)), "match the shape of `test`")
+})