Promote ifelse() branches and shape the result like test

Fortran's merge() requires same-typed branches, but the ifelse()
handler took its result mode from `yes` alone and never cast `no`:
mixed-mode branches emitted an invalid mixed-type merge()
(ifelse(c, 1L, a) with double `a` failed at the gfortran stage). The
result shape also came from the first non-scalar of (test, yes, no),
where R documents ifelse() as returning a result shaped like `test`.

Promote both branches to their common lattice mode with
promote_operands(), and take the result's mode and shape from the
promoted branches and the (booleanized) test respectively. A scalar
test with array-valued branches is now a compile-time error --
merge() cannot represent R's length-1 result -- instead of silently
emitting branch-shaped code.

Author: mns-nordicals

R/r2f-conditionals.R

@@ -6,8 +6,27 @@
 r2f_handlers[["ifelse"]] <- function(args, scope, ...) {
   .[mask, tsource, fsource] <- lapply(args, r2f, scope, ...)
   mask <- booleanize_logical_as_int(mask)
-  # (tsource, fsource, mask)
-  mode <- tsource@value@mode
-  dims <- conform(mask@value, tsource@value, fsource@value)@dims
-  Fortran(glue("merge({tsource}, {fsource}, {mask})"), Variable(mode, dims))
+
+  # 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
+
+  # R: the result is shaped like `test` (branches only contribute values).
+  # A scalar test with array branches is not representable with merge().
+  if (
+    passes_as_scalar(mask@value) &&
+      !(passes_as_scalar(tsource@value) && passes_as_scalar(fsource@value))
+  ) {
+    stop(
+      "ifelse() result takes the shape of `test`; ",
+      "array-valued yes/no with scalar test is not supported",
+      call. = FALSE
+    )
+  }
+
+  Fortran(
+    glue("merge({tsource}, {fsource}, {mask})"),
+    Variable(mode, mask@value@dims)
+  )
 }

tests/testthat/_snaps/ifelse.md

@@ -0,0 +1,81 @@
+# ifelse promotes branches and shapes like test
+
+    Code
+      fn
+    Output
+      function(c, a) {
+          declare(type(c = logical(n)), type(a = double(n)))
+          ifelse(c, 1L, a)
+        }
+      <environment: 0x0>
+    Code
+      cat(fsub)
+    Output
+      subroutine fn(c, a, out_, c__len_) bind(c)
+        use iso_c_binding, only: c_double, c_int, c_ptrdiff_t
+        implicit none
+      
+        ! manifest start
+        ! sizes
+        integer(c_ptrdiff_t), intent(in), value :: c__len_
+      
+        ! args
+        integer(c_int), intent(in) :: c(c__len_) ! logical
+        real(c_double), intent(in) :: a(c__len_)
+        real(c_double), intent(out) :: out_(c__len_)
+        ! manifest end
+      
+      
+        out_ = merge(real(1_c_int, kind=c_double), a, (c/=0))
+      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__, 
+        double* const out___, 
+        const R_xlen_t c__len_);
+      
+      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);
+        
+        if (c__len_ != a__len_)
+          Rf_error("length(a) must equal length(c),"
+                   " but are %0.f and %0.f",
+                    (double)a__len_, (double)c__len_);
+        const R_xlen_t out___len_ = c__len_;
+        SEXP out_ = PROTECT(Rf_allocVector(REALSXP, out___len_));
+        double* out___ = REAL(out_);
+        
+        fn(
+          c__,
+          a__,
+          out___,
+          c__len_);
+        
+        UNPROTECT(1);
+        return out_;
+      }
+

tests/testthat/test-ifelse.R

@@ -26,3 +26,27 @@ test_that("ifelse", {
   }
   expect_quick_equal(fn, list(seq(-5, 5, length.out = 20), double(20)))
 })
+
+test_that("ifelse promotes branches and shapes like test", {
+  fn <- function(c, a) {
+    declare(type(c = logical(n)), type(a = double(n)))
+    ifelse(c, 1L, a)
+  }
+  expect_translation_snapshots(fn)
+  expect_quick_equal(fn, list(c(TRUE, FALSE, TRUE), c(2, 4, 6)))
+
+  # logical branches join as logical
+  fn2 <- function(c, a) {
+    declare(type(c = logical(n)), type(a = logical(n)))
+    ifelse(c, FALSE, a)
+  }
+  expect_quick_equal(fn2, list(c(TRUE, FALSE, TRUE), c(TRUE, TRUE, FALSE)))
+})
+
+test_that("ifelse with scalar test and array branch errors cleanly", {
+  fn <- function(c, a) {
+    declare(type(c = logical(1)), type(a = double(n)))
+    ifelse(c, a, 0)
+  }
+  expect_error(quick(fn), "shape of `test`")
+})