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.

Author: mns-nordicals

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})))")
   }
 

tests/testthat/_snaps/runif.md

@@ -566,3 +566,67 @@
         return out_;
       }
 
+# impure runif() bounds are evaluated exactly once
+
+    Code
+      fn
+    Output
+      function() {
+          out <- runif(2L, runif(1L), 10)
+          out
+        }
+      <environment: 0x0>
+    Code
+      cat(fsub)
+    Output
+      subroutine fn(out) bind(c)
+        use iso_c_binding, only: c_double, c_int
+        implicit none
+      
+        ! manifest start
+        ! args
+        real(c_double), intent(out) :: out(2)
+      
+        ! locals
+        integer(c_int) :: tmp1_
+        ! 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()
+          out = [((btmp1_ + (unif_rand() * (10.0_c_double - btmp1_))), tmp1_=1, 2)]
+        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_ = 2;
+        SEXP out = PROTECT(Rf_allocVector(REALSXP, out__len_));
+        double* out__ = REAL(out);
+        
+        GetRNGstate();
+        fn(out__);
+        PutRNGstate();
+        
+        UNPROTECT(1);
+        return out;
+      }
+

tests/testthat/test-runif.R

@@ -117,3 +117,28 @@ test_that("runif with min/max", {
     set_seed_and_call(qfn, 20)
   )
 })
+
+test_that("impure runif() bounds are evaluated exactly once", {
+  # `min` is spliced twice into the emitted expression, and the implied-do
+  # for array results would re-evaluate spliced bounds per element; R
+  # evaluates bounds once per call.
+  fn <- function() {
+    out <- runif(2L, runif(1L), 10)
+    out
+  }
+  expect_translation_snapshots(fn)
+  qfn <- quick(fn)
+
+  expect_identical(
+    set_seed_and_call(fn),
+    set_seed_and_call(qfn)
+  )
+
+  set.seed(1)
+  qfn()
+  q_next <- runif(1L)
+  set.seed(1)
+  fn()
+  r_next <- runif(1L)
+  expect_identical(q_next, r_next)
+})