[1/15] Fix repeated side effects in floor/ceiling and runif bounds, reject na.rm= in reductions, and three small crash/diagnostic fixes (#137)

* Evaluate floor()/ceiling() arguments exactly once

floor() and ceiling() splice their argument into the emitted Fortran
expression three times (once for aint(), twice for the sign adjustment),
so an impure argument such as runif(1) was evaluated three times: the
result mixed different random draws and the RNG state diverged from R.

Extract the hoist-to-temporary pattern already used by matrix() into a
shared helper, hoist_unless_name(), and use it in floor()/ceiling() to
evaluate non-trivial arguments once. Bare variable names are passed
through unchanged, so existing translations without side effects are
unaffected. matrix() now uses the shared helper.

* Reject named arguments in max/min/sum/prod

The reductions handler never inspected argument names, so
`sum(x, na.rm = TRUE)` translated `na.rm = TRUE` as an extra data
argument, emitting `(sum(x) + .true.)`. Reject named arguments with a
clear compile-time error, matching the existing any()/all() guard.

* Error cleanly when assigning a value-less expression

Binding a new variable to an expression that produces no value (e.g.
`y <- if (x) 1 else 2`, where `if` lowers to a statement) crashed with
"no applicable method for `@` applied to an object of class NULL".
Diagnose it at the assignment site instead, naming the offending
expression.

* Fix r2size() crash on deferred-mode variables

`var@mode != "integer"` fails with "argument is of length zero" when
@mode is NULL (a binding whose mode is still being inferred, as in the
deferred-mode path in r2f-assign.R). Use !identical() so the intended
"size is not an integer" warning path is reached instead.

* Make Variable@dims <- NULL reset to scalar

The dims setter early-returned on empty input, so resetting a variable
to scalar (NULL dims, per the class's own convention) silently kept the
stale dims. r2f-assign.R's deferred-mode path assigns
`var@dims <- value@value@dims` with a legitimately-NULL RHS and relied
on this working. Assign the attribute directly (the same S7 workaround
already used by the `r` property) to avoid recursing through the setter.

* Evaluate runif() bounds exactly once

Same defect class as the floor()/ceiling() fix: `min` is spliced twice
into the emitted expression, and for array results the implied-do
re-evaluates spliced bounds once per element, so an impure bound such
as `runif(2L, runif(1L), 10)` drew a fresh `min` value repeatedly where
R evaluates it once. Hoist non-trivial bounds via hoist_unless_name();
bare names and literal bounds are unaffected.

* Format with air

Author: mns-nordicals

R/classes.R

@@ -240,6 +240,9 @@ Variable := new_class(
       NULL | class_list,
       setter = function(self, value) {
         if (!length(value)) {
+          # reset to scalar (NULL means scalar); assign the attribute
+          # directly to avoid recursing through this setter
+          attr(self, "dims") <- NULL
           return(self)
         }
 

R/r2f-aab-core.R

@@ -71,6 +71,26 @@ new_hoist <- function(scope) {
   )
 }
 
+# Hoist `x` into a temporary variable unless it already renders as a bare
+# variable name. Use this whenever the same operand is spliced into generated
+# code more than once: Fortran evaluates intrinsic actual arguments before the
+# call, so repeating an expression duplicates its side effects (e.g. RNG
+# state via runif()).
+hoist_unless_name <- function(x, hoist) {
+  stopifnot(inherits(x, Fortran), inherits(x@value, Variable))
+  code <- trimws(as.character(x))
+  if (!is.null(x@value@name) && identical(code, x@value@name)) {
+    return(x)
+  }
+  tmp <- hoist$declare_tmp(
+    mode = x@value@mode,
+    dims = x@value@dims,
+    logical_as_int = logical_as_int(x@value)
+  )
+  hoist$emit(glue("{tmp@name} = {x}"))
+  Fortran(tmp@name, tmp)
+}
+
 
 # --- Scope Helpers ---
 

R/r2f-assign.R

@@ -175,6 +175,14 @@ register_r2f_handler(
     if (!existing_binding) {
       # The var does not exist -> this is a binding to a new symbol
       # Create a fresh Variable carrying only mode/dims and a new name.
+      if (inherits(value, Fortran) && is.null(value@value)) {
+        stop(
+          "cannot assign `",
+          deparse1(rhs),
+          "`: expression does not produce a value",
+          call. = FALSE
+        )
+      }
       if (!inherits(var, Variable)) {
         src <- value@value
         var <- Variable(mode = src@mode, dims = src@dims)

R/r2f-constructors.R

@@ -157,24 +157,10 @@ r2f_handlers[["matrix"]] <- function(args, scope = NULL, ..., hoist = NULL) {
 
   rows <- dims[[1L]]
   cols <- dims[[2L]]
-  source <- glue("{src}")
 
   # Avoid double-evaluating non-trivial expressions when used in both the
-  # `source` and `pad` args. In Fortran, intrinsic actual args are evaluated
-  # before the call, so repeating the expression can duplicate side effects
-  # (e.g. RNG state via runif()).
-  if (
-    is.null(src@value@name) ||
-      !identical(trimws(source), src@value@name)
-  ) {
-    tmp <- hoist$declare_tmp(
-      mode = src@value@mode,
-      dims = src@value@dims,
-      logical_as_int = logical_as_int(src@value)
-    )
-    hoist$emit(glue("{tmp@name} = {src}"))
-    source <- tmp@name
-  }
+  # `source` and `pad` args.
+  source <- glue("{hoist_unless_name(src, hoist)}")
   Fortran(
     glue(
       "reshape({source}, [{bind_dim_int(rows)}, {bind_dim_int(cols)}], pad = {source})"

R/r2f-math.R

@@ -42,10 +42,13 @@ register_unary_intrinsic(
   expr_fun = function(arg, intrinsic) glue("{intrinsic}({arg})")
 )
 
-r2f_handlers[["floor"]] <- function(args, scope, ...) {
+r2f_handlers[["floor"]] <- function(args, scope, ..., hoist = NULL) {
   stopifnot(length(args) == 1L)
-  arg <- r2f(args[[1L]], scope, ...)
+  arg <- r2f(args[[1L]], scope, ..., hoist = hoist)
 
+  # `arg` is spliced into the emitted expression three times below; hoist
+  # non-trivial expressions so side effects (e.g. RNG state) happen once.
+  arg <- hoist_unless_name(arg, hoist)
   arg <- maybe_cast_double(arg)
   if (!identical(arg@value@mode, "double")) {
     stop("floor() only implemented for logical, integer, and double")
@@ -63,10 +66,13 @@ r2f_handlers[["floor"]] <- function(args, scope, ...) {
   )
 }
 
-r2f_handlers[["ceiling"]] <- function(args, scope, ...) {
+r2f_handlers[["ceiling"]] <- function(args, scope, ..., hoist = NULL) {
   stopifnot(length(args) == 1L)
-  arg <- r2f(args[[1L]], scope, ...)
+  arg <- r2f(args[[1L]], scope, ..., hoist = hoist)
 
+  # `arg` is spliced into the emitted expression three times below; hoist
+  # non-trivial expressions so side effects (e.g. RNG state) happen once.
+  arg <- hoist_unless_name(arg, hoist)
   arg <- maybe_cast_double(arg)
   if (!identical(arg@value@mode, "double")) {
     stop("ceiling() only implemented for logical, integer, and double")

R/r2f-random.R

@@ -14,14 +14,22 @@ r2f_handlers[["runif"]] <- function(args, scope, ..., hoist = NULL) {
   default_min <- identical(min, 0) || identical(min, 0L)
   default_max <- identical(max, 1) || identical(max, 1L)
 
+  # R evaluates runif() bounds exactly once, but `min` is spliced twice below
+  # and the implied-do re-evaluates the whole expression per element; hoist
+  # non-trivial bounds (e.g. an impure runif(1)) so they are evaluated once.
+  bound <- function(r_arg) {
+    b <- r2f(r_arg, scope, ..., hoist = hoist)
+    if (is.atomic(r_arg)) b else hoist_unless_name(b, hoist)
+  }
+
   if (default_min && default_max) {
     get1rand <- "unif_rand()"
   } else if (default_min) {
-    max <- r2f(max, scope, ..., hoist = hoist)
+    max <- bound(max)
     get1rand <- glue("unif_rand() * {max}")
   } else {
-    max <- r2f(max, scope, ..., hoist = hoist)
-    min <- r2f(min, scope, ..., hoist = hoist)
+    min <- bound(min)
+    max <- bound(max)
     get1rand <- glue("({min} + (unif_rand() * ({max} - {min})))")
   }
 

R/r2f-reductions.R

@@ -13,6 +13,16 @@ register_r2f_handler(
     scope,
     ...
   ) {
+    # Named arguments like `na.rm` would otherwise be treated as data
+    # arguments (e.g. `sum(x, na.rm = TRUE)` -> `(sum(x) + .true.)`).
+    arg_names <- names(args) %||% character()
+    if (length(arg_names) && any(nzchar(arg_names))) {
+      stop(
+        "max()/min()/sum()/prod() do not support named arguments (e.g. `na.rm`)",
+        call. = FALSE
+      )
+    }
+
     intrinsic <- switch(
       last(list(...)$calls),
       max = "maxval",

R/sizes.R

@@ -168,7 +168,8 @@ r2size <- function(r, scope) {
         if (!inherits(var, Variable)) {
           stop("could not resolve size: ", as.character(r))
         }
-        if (var@mode != "integer" || !passes_as_scalar(var)) {
+        # !identical(): @mode can be NULL (deferred-mode binding)
+        if (!identical(var@mode, "integer") || !passes_as_scalar(var)) {
           warning("size is not an integer:", as.character(r))
         }
         if (var@is_arg && !var@modified) {

tests/testthat/_snaps/example-convolve.md

@@ -10,7 +10,7 @@
           ab <- double(length(a) + length(b) - 1)
           for (i in seq_along(a)) {
             for (j in seq_along(b)) {
-              ab[i + j - 1] = ab[i + j - 1] + a[i] * b[j]
+              ab[i + j - 1] <- ab[i + j - 1] + a[i] * b[j]
             }
           }
           ab

tests/testthat/_snaps/hoist-unless-name.md

@@ -0,0 +1,61 @@
+# floor() hoists non-name arguments to a temporary
+
+    Code
+      fn
+    Output
+      function() {
+          out <- floor(runif(1L) * 10)
+          out
+        }
+      <environment: 0x0>
+    Code
+      cat(fsub)
+    Output
+      subroutine fn(out) bind(c)
+        use iso_c_binding, only: c_double
+        implicit none
+      
+        ! manifest start
+        ! args
+        real(c_double), intent(out) :: out
+        ! manifest end
+      
+        interface
+          function unif_rand() bind(c, name = "unif_rand") result(u)
+            use iso_c_binding, only: c_double
+            real(c_double) :: u
+          end function unif_rand
+        end interface
+      
+        block
+          real(c_double) :: btmp1_
+      
+          btmp1_ = (unif_rand() * 10.0_c_double)
+          out = (aint(btmp1_) - merge(1.0_c_double, 0.0_c_double, (btmp1_ < aint(btmp1_))))
+        end block
+      end subroutine
+    Code
+      cat(cwrapper)
+    Output
+      #define R_NO_REMAP
+      #include <R.h>
+      #include <Rinternals.h>
+      #include <R_ext/Random.h>
+      
+      
+      extern void fn(double* const out__);
+      
+      SEXP fn_(SEXP _args) {
+        
+        const R_xlen_t out__len_ = (1);
+        SEXP out = PROTECT(Rf_allocVector(REALSXP, out__len_));
+        double* out__ = REAL(out);
+        
+        GetRNGstate();
+        fn(out__);
+        PutRNGstate();
+        
+        UNPROTECT(1);
+        return out;
+      }
+