Merge pull request #49 from mns-nordicals/list_return_1

Add ability to return multiple values

Author: t-kalinowski

NEWS.md

@@ -1,5 +1,8 @@
 # quickr (development version)
 
+- Functions can now return multiple arrays in a `list()`, optionally
+  named (#49, @mns-nordicals).
+
 # quickr 0.2.0
 
 - Internal utility `r2f()` print method now shows the generated `c_bridge`
@@ -28,12 +31,12 @@
 
 - Added workaround for cases where the compiler error message might not
   display correctly in RStudio.
-  
+
 - Improved error message when using case-sensitive variable names (#18, #36, #39)
 
-- Added `AGENTS.md` and `scripts/setup_codex.sh` to enable the ChatGPT/Codex agent 
+- Added `AGENTS.md` and `scripts/setup_codex.sh` to enable the ChatGPT/Codex agent
   to run tests in a docker container configured without internet access.
-  
+
 
 # quickr 0.1.0
 

R/c-wrapper.R

@@ -36,16 +36,19 @@ make_c_bridge <- function(fsub, strict = TRUE, headers = TRUE) {
     scope = scope
   )
 
-  # maybe define and allocate the output var
+  # maybe define and allocate the output var(s)
   n_protected <- 0L
-  return_var <- get(closure_return_var_name(closure), scope)
-  if (!return_var@name %in% closure_arg_names) {
-    return_var@modified <- TRUE
-    assign(return_var@name, return_var, scope)
-    append(c_body) <- return_var_c_defs(return_var, fsub@scope)
-    add(n_protected) <- 1L # allocated return var
-    if (return_var@rank > 1) {
-      add(n_protected) <- 1L # allocated _dim_sexp
+  return_var_names <- closure_return_var_names(closure)
+  # Deduplicate by the underlying variable name to avoid duplicate C defs
+  for (return_var in mget(unique(unname(return_var_names)), scope)) {
+    if (!return_var@name %in% closure_arg_names) {
+      return_var@modified <- TRUE
+      assign(return_var@name, return_var, scope)
+      append(c_body) <- return_var_c_defs(return_var, fsub@scope)
+      add(n_protected) <- 1L # allocated return var
+      if (return_var@rank > 1) {
+        add(n_protected) <- 1L # allocated _dim_sexp
+      }
     }
   }
 
@@ -64,10 +67,49 @@ make_c_bridge <- function(fsub, strict = TRUE, headers = TRUE) {
     if (uses_rng) "PutRNGstate();",
     ""
   )
-  if (n_protected > 0) {
-    append(c_body) <- glue("UNPROTECT({n_protected});")
+  # Determine if the closure returns a list call or a single symbol
+  is_list_return <- is_call(last(body(closure)), quote(list))
+
+  if (length(return_var_names) == 1L && !is_list_return) {
+    if (n_protected > 0) {
+      append(c_body) <- glue("UNPROTECT({n_protected});")
+    }
+    append(c_body) <- glue("return {return_var_names};")
+  } else {
+    return_var_values <- unname(return_var_names)
+    provided_names <- names(return_var_names)
+    if (is.null(provided_names)) {
+      provided_names <- rep("", length(return_var_values))
+    }
+    has_any_names <- any(nzchar(provided_names))
+
+    append(c_body) <- c(
+      glue(
+        "SEXP _ans = PROTECT(Rf_allocVector(VECSXP, {length(return_var_values)}));"
+      ),
+      imap(return_var_values, function(nm, i) {
+        glue("SET_VECTOR_ELT(_ans, {i-1}, {nm});")
+      })
+    )
+
+    if (has_any_names) {
+      names_to_use <- provided_names
+      append(c_body) <- c(
+        glue(
+          "SEXP _names = PROTECT(Rf_allocVector(STRSXP, {length(return_var_values)}));"
+        ),
+        imap(names_to_use, function(nm, i) {
+          glue('SET_STRING_ELT(_names, {i-1}, Rf_mkChar("{nm}"));')
+        }),
+        "Rf_setAttrib(_ans, R_NamesSymbol, _names);"
+      )
+      append(c_body) <- glue("UNPROTECT({n_protected + 2});")
+    } else {
+      append(c_body) <- glue("UNPROTECT({n_protected + 1});")
+    }
+
+    append(c_body) <- "return _ans;"
   }
-  append(c_body) <- glue("return {return_var@name};")
 
   c_args <- paste("SEXP", names(formals(closure)), collapse = ", ")
   c_body <- as_glue(str_flatten_lines(c_body))
@@ -416,12 +458,39 @@ as_friendly_size_expression <- function(d) {
   deparse1(d)
 }
 
-closure_return_var_name <- function(closure) {
-  return_var_name <- last(body(closure))
-  if (!is.symbol(return_var_name)) {
-    stop("return value must be a symbol")
+closure_return_var_names <- function(closure) {
+  return_var_expr <- last(body(closure))
+  if (is.symbol(return_var_expr)) {
+    val <- as.character(return_var_expr)
+    # Return named to keep interface consistent
+    return(setNames(val, val))
+  }
+  if (is_call(return_var_expr, quote(list))) {
+    args <- as.list(return_var_expr)[-1L]
+    if (length(args) == 0L) {
+      stop("return list must contain at least one element")
+    }
+    vals <- map_chr(args, as.character)
+    nms <- names(args)
+    if (is.null(nms)) {
+      nms <- rep("", length(vals))
+    }
+    # validate names are syntactic when provided
+    if (any(nzchar(nms))) {
+      bad <- nzchar(nms) & make.names(nms) != nms
+      if (any(bad)) {
+        stop(
+          "only syntactic names are valid, encountered: ",
+          paste0(nms[bad], sep = ", ")
+        )
+      }
+    }
+    # Use provided names when present; fallback to symbol names
+    # nms <- ifelse(nzchar(nms), nms, vals)
+    return(setNames(vals, nms))
   }
-  as.character(return_var_name)
+  ## is it redundent ? new_fortran_subroutine also errors ?
+  stop("return value must be a symbol or list of symbols")
 }
 
 

R/manifest.R

@@ -38,8 +38,9 @@ r2f.scope <- function(scope) {
   vars <- as.list.environment(scope, all.names = TRUE)
   vars <- lapply(vars, function(var) {
     intent_in <- var@name %in% names(formals(scope@closure))
-    intent_out <- var@name == closure_return_var_name(scope@closure) ||
-      intent_in && var@modified
+    intent_out <-
+      (var@name %in% closure_return_var_names(scope@closure)) ||
+      (intent_in && var@modified)
 
     intent <-
       if (intent_in && intent_out) {
@@ -88,7 +89,7 @@ r2f.scope <- function(scope) {
   # vars that will be visible in the C bridge, either as an input or output
   non_local_var_names <- unique(c(
     names(formals(scope@closure)),
-    closure_return_var_name(scope@closure)
+    closure_return_var_names(scope@closure)
   ))
 
   # collect all size_names; sort so non-locals are declared first.

R/preprocess-lang.R

@@ -12,19 +12,57 @@ defuse_numeric_literals <- function(e) {
   e
 }
 
+# Helper function to validate that all list elements are symbols
+validate_list_symbols <- function(list_call) {
+  args <- as.list(list_call)[-1L]
+  if (!all(map_lgl(args, is.symbol))) {
+    stop("all elements of the list must be symbols")
+  }
+  invisible(TRUE)
+}
+
 
 ensure_last_expr_sym <- function(bdy) {
   if (!is_call(bdy, quote(`{`))) {
     stop("bad body, needs {")
   }
-  if (!is.symbol(last_expr <- last(bdy))) {
-    bdy[[length(bdy)]] <- call("<-", quote(out_), last_expr)
-    bdy[[length(bdy) + 1L]] <- quote(out_)
+
+  last_expr <- last(bdy)
+
+  # Case 1: Last expression is a symbol
+  if (is.symbol(last_expr)) {
+    # Check for pattern: out <- list(...); out
+    n <- length(bdy)
+    second_last_expr <- bdy[[n - 1L]]
+
+    list_pattern <-
+      is_call(second_last_expr, quote(`<-`)) &&
+      identical(second_last_expr[[2L]], last_expr) &&
+      is_call(second_last_expr[[3L]], quote(list))
+
+    if (list_pattern) {
+      # Modify body such that last espression is list(...)
+      list_call <- second_last_expr[[3L]]
+      validate_list_symbols(list_call)
+      bdy[[n - 1]] <- NULL # delete list assignment
+      bdy[[n - 1]] <- list_call # replace last line with list(...)
+    }
+
+    return(bdy)
+  }
+
+  # Case 2: Last expression is a direct list call
+  if (is_call(last_expr, quote(list))) {
+    validate_list_symbols(last_expr)
+    return(bdy)
   }
+
+  # Case 3: Other expressions - create assignment to out_
+  bdy[[length(bdy)]] <- call("<-", quote(out_), last_expr)
+  bdy[[length(bdy) + 1L]] <- quote(out_)
   bdy
 }
 
-
 whole_doubles_to_ints <- function(x) {
   walker <- function(x) {
     switch(
@@ -38,7 +76,6 @@ whole_doubles_to_ints <- function(x) {
   walker(x)
 }
 
-
 substitute_unique_case_insensitive_symbols <- function(x) {
   # TODO: would be nice to fix case-insenstive name clashes
   # with automatic substitutions. Would be a little involved since

R/subroutine.R

@@ -35,14 +35,24 @@ new_fortran_subroutine <- function(name, closure, parent = emptyenv()) {
     }
   }
 
-  # figure out the return variable.
-  if (is.symbol(last_expr <- last(body(closure)))) {
+  # figure out the return variable(s).
+  last_expr <- last(body(closure))
+  if (is.symbol(last_expr)) {
     return_var <- get(last_expr, scope)
     return_var@is_return <- TRUE
     scope[[as.character(last_expr)]] <- return_var
+  } else if (is_call(last_expr, quote(list))) {
+    args <- as.list(last_expr)[-1L]
+    for (arg in args) {
+      var <- get(arg, scope)
+      var@is_return <- TRUE
+      scope[[as.character(arg)]] <- var
+    }
   } else {
     # lots we can still do here, just not implemented yet.
-    stop("last expression in the function must be a bare symbol")
+    stop(
+      "last expression in the function must be a bare symbol or list of symbols"
+    )
   }
 
   manifest <- r2f.scope(scope)

tests/testthat/test-as-double.R

@@ -24,4 +24,4 @@ test_that("/ performs real division for integer and logical inputs", {
     a / b
   }
   expect_quick_equal(div_lgl, list(c(TRUE, FALSE, TRUE), c(TRUE, TRUE, TRUE)))
-})
+})

tests/testthat/test-loops.R

@@ -101,4 +101,3 @@ test_that("expr return value", {
   expect_translation_snapshots(fn)
   expect_quick_identical(fn, 1:10)
 })
-