Add support for runif()

NEWS.md

@@ -1,10 +1,12 @@
 # quickr (development version)
 
-- Internal utility `r2f()` print method now shows the generated `c_bridge` 
+- Internal utility `r2f()` print method now shows the generated `c_bridge`
   for translated subroutines.
-  
+
 - Added support for `nrow()`, `ncol()` and `dim()` (#21, @mikmart).
 
+- Added support for `runif()` with integration to R's RNG (#22, #45).
+
 - Added support for `while`, `repeat`, `break`, `next`.
 
 - Added support for `%%` and `%/%`.
@@ -22,6 +24,8 @@
 
 - Fixed segfault encountered on Windows with variable sized arrays.
 
+- Added workaround for cases where the compiler error message might not
+  display correctly in RStudio.
 
 # quickr 0.1.0
 

R/c-wrapper.R

@@ -3,6 +3,7 @@ make_c_bridge <- function(fsub, strict = TRUE, headers = TRUE) {
 
   closure <- fsub@closure
   scope <- fsub@scope
+  uses_rng <- isTRUE(attr(scope, "uses_rng", TRUE))
 
   fsub_arg_names <- fsub@signature # arg names
   closure_arg_names <- names(formals(closure))
@@ -58,7 +59,9 @@ make_c_bridge <- function(fsub, strict = TRUE, headers = TRUE) {
 
   append(c_body) <- c(
     "",
+    if (uses_rng) "GetRNGstate();",
     glue("{fsub@name}({str_flatten_commas(fsub_call_args)});"),
+    if (uses_rng) "PutRNGstate();",
     ""
   )
   if (n_protected > 0) {
@@ -73,14 +76,13 @@ make_c_bridge <- function(fsub, strict = TRUE, headers = TRUE) {
 
   fsub_extern_decl <- fsub_extern_decl(fsub)
 
-  c_headers <- glue::trim(
-    r"--(
-     #define R_NO_REMAP
-     #include <R.h>
-     #include <Rinternals.h>
-
-
-     )--"
+  c_headers <- str_flatten_lines(
+    "#define R_NO_REMAP",
+    "#include <R.h>",
+    "#include <Rinternals.h>",
+    if (uses_rng) "#include <R_ext/Random.h>",
+    "",
+    ""
   )
 
   as_glue(str_flatten_lines(c(

R/quick.R

@@ -184,10 +184,13 @@ compile <- function(fsub, build_dir = tempfile(paste0(fsub@name, "-build-"))) {
       stderr = TRUE
     )
   })
-  if (!is.null(attr(result, "status"))) {
+  if (!is.null(status <- attr(result, "status"))) {
+    # Adjust the compiler error so RStudio console formatter doesn't mangle
+    # the actual error message https://github.com/rstudio/rstudio/issues/16365
+    result <- gsub("Error: ", "Compiler Error: ", result, fixed = TRUE)
     writeLines(result, stderr())
-    str(attributes(result))
-    stop("Compilation Error")
+    cat("---\nCompiler exit status:", status, "\n", file = stderr())
+    stop("Compilation Error", call. = FALSE)
   }
 
   # tryCatch(dyn.unload(dll_path), error = identity)

R/r2f.R

@@ -944,6 +944,39 @@ r2f_handlers[["double"]] <- function(args, scope, ...) {
 
 r2f_handlers[["numeric"]] <- r2f_handlers[["double"]]
 
+r2f_handlers[["runif"]] <- function(args, scope, ..., hoist = NULL) {
+  attr(scope, "uses_rng") <- TRUE
+
+  dims <- r2dims(args$n, scope)
+  var <- Variable("double", dims)
+
+  min <- args$min %||% 0
+  max <- args$max %||% 1
+  default_min <- identical(min, 0) || identical(min, 0L)
+  default_max <- identical(max, 1) || identical(max, 1L)
+
+  if (default_min && default_max) {
+    get1rand <- "unif_rand()"
+  } else if (default_min) {
+    max <- r2f(max, scope, ..., hoist = hoist)
+    get1rand <- glue("unif_rand() * {max}")
+  } else {
+    max <- r2f(max, scope, ..., hoist = hoist)
+    min <- r2f(min, scope, ..., hoist = hoist)
+    get1rand <- glue("({min} + (unif_rand() * ({max} - {min})))")
+  }
+
+  if (passes_as_scalar(var)) {
+    fortran <- get1rand
+  } else {
+    tmp_i <- scope@get_unique_var("integer") ## would be better as uint64...
+    fortran <- glue("[({get1rand}, {tmp_i}=1, {dims[[1L]]})]")
+  }
+
+  Fortran(fortran, var)
+}
+
+
 r2f_handlers[["character"]] <- r2f_handlers[["raw"]] <-
   .r2f_handler_not_implemented_yet
 

R/subroutine.R

@@ -91,8 +91,26 @@ new_fortran_subroutine <- function(name, closure, parent = emptyenv()) {
       append(used_iso_bindings) <- "c_ptrdiff_t"
     }
   }
+  if (isTRUE(attr(scope@closure, "uses_rng", TRUE))) {
+    used_iso_bindings <- union(used_iso_bindings, "c_double")
+  }
   used_iso_bindings <- sort(used_iso_bindings, method = "radix")
 
+  uses_rng <- isTRUE(attr(scope, 'uses_rng', TRUE))
+  if (uses_rng) {
+    rng_interface <- glue::trim(
+      '
+      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
+      '
+    )
+
+    manifest <- str_flatten_lines(manifest, "", rng_interface)
+  }
   subroutine <- glue(
     "
     subroutine {name}({str_flatten_commas(fsub_arg_names)}) bind(c)