Add error handling plumbing

NEWS.md

@@ -17,6 +17,8 @@
 - Added OpenMP parallelization via `declare(parallel())`/`declare(omp())` for
   `for` loops and `sapply()` calls.
 
+- Added support for throwing errors with `stop()`. (#86)
+
 - Added support for `abs()` in size expressions used by `declare(type(...))`
   (e.g. `declare(type(x = integer(abs(end - start) + 1L)))`).
 

R/c-wrapper.R

@@ -4,6 +4,7 @@ make_c_bridge <- function(fsub, strict = TRUE, headers = TRUE) {
   closure <- fsub@closure
   scope <- fsub@scope
   uses_rng <- isTRUE(attr(scope, "uses_rng", TRUE))
+  uses_errors <- isTRUE(attr(scope, "uses_errors", TRUE))
 
   fsub_arg_names <- fsub@signature # arg names
   closure_arg_names <- names(formals(closure)) %||% character()
@@ -52,8 +53,22 @@ make_c_bridge <- function(fsub, strict = TRUE, headers = TRUE) {
     }
   }
 
+  if (uses_errors) {
+    append(c_body) <- c(
+      "",
+      glue("char {quickr_error_msg_name()}[{quickr_error_msg_len()}];"),
+      glue("{quickr_error_msg_name()}[0] = '\\0';"),
+      ""
+    )
+  }
+
   fsub_call_args <- fsub_arg_names |>
-    lapply(\(nm) paste0(nm, if (!is_size_name(nm)) "__")) |>
+    lapply(\(nm) {
+      if (is_quickr_error_msg(nm)) {
+        return(nm)
+      }
+      paste0(nm, if (!is_size_name(nm)) "__")
+    }) |>
     unlist()
 
   if (length(fsub_call_args) > 3) {
@@ -65,6 +80,13 @@ make_c_bridge <- function(fsub, strict = TRUE, headers = TRUE) {
     if (uses_rng) "GetRNGstate();",
     glue("{fsub@name}({str_flatten_commas(fsub_call_args)});"),
     if (uses_rng) "PutRNGstate();",
+    if (uses_errors) glue("if ({quickr_error_msg_name()}[0] != '\\0') {{"),
+    if (uses_errors) {
+      indent(glue(
+        "Rf_error(\"%s\", {quickr_error_msg_name()});"
+      ))
+    },
+    if (uses_errors) "}",
     ""
   )
   # Determine if the closure returns a list call or a single symbol
@@ -552,6 +574,9 @@ fsub_extern_decl <- function(fsub) {
   scope <- fsub@scope
 
   fsub_c_sig <- map_chr(fsub_arg_names, function(name) {
+    if (is_quickr_error_msg(name)) {
+      return(glue("char* {name}"))
+    }
     if (is_size_name(name)) {
       type <- if (name |> endsWith("__len_")) {
         "R_xlen_t"

R/error-handling.R

@@ -0,0 +1,131 @@
+quickr_error_msg_name <- function() "quickr_err_msg"
+
+quickr_error_msg_len <- function() 256L
+
+quickr_error_setter_name <- function() "quickr_set_error_msg"
+
+quickr_error_arg_names <- function() {
+  c(quickr_error_msg_name())
+}
+
+is_quickr_error_msg <- function(name) {
+  identical(name, quickr_error_msg_name())
+}
+
+scope_root_for_errors <- function(scope) {
+  if (!inherits(scope, "quickr_scope")) {
+    return(scope)
+  }
+  while (
+    !identical(attr(scope, "kind", exact = TRUE), "subroutine") &&
+      inherits(parent.env(scope), "quickr_scope")
+  ) {
+    scope <- parent.env(scope)
+  }
+  scope
+}
+
+mark_scope_uses_errors <- function(scope) {
+  root <- scope_root_for_errors(scope)
+  if (inherits(root, "quickr_scope")) {
+    attr(root, "uses_errors") <- TRUE
+  }
+  invisible(TRUE)
+}
+
+scope_uses_errors <- function(scope) {
+  root <- scope_root_for_errors(scope)
+  isTRUE(attr(root, "uses_errors", TRUE))
+}
+
+fortran_string_literal <- function(x) {
+  stopifnot(is_string(x))
+  escaped <- gsub("\r\n|\r|\n", "\\\\n", x)
+  escaped <- gsub("\"", "\"\"", escaped, fixed = TRUE)
+  paste0("\"", escaped, "\"")
+}
+
+check_quickr_error_message_continuable <- function(msg) {
+  stopifnot(is_string(msg))
+  if (grepl("[ \t]", msg)) {
+    return(invisible(TRUE))
+  }
+  msg_literal <- fortran_string_literal(msg)
+  line_len <- nchar(glue(
+    "&{quickr_error_setter_name()}( {msg_literal} )"
+  ))
+  if (line_len > 132L) {
+    stop(
+      "Error message is too long to fit in a single Fortran line without spaces.",
+      " Add spaces to allow line continuations.",
+      call. = FALSE
+    )
+  }
+  invisible(TRUE)
+}
+
+quickr_error_manifest_lines <- function() {
+  msg_name <- quickr_error_msg_name()
+  len_val <- quickr_error_msg_len()
+
+  glue("character(kind=c_char), intent(inout) :: {msg_name}({len_val})")
+}
+
+quickr_error_helper_fortran <- function(openmp = FALSE) {
+  msg_name <- quickr_error_msg_name()
+  setter <- quickr_error_setter_name()
+  len_val <- quickr_error_msg_len()
+
+  glue::trim(str_flatten_lines(
+    glue("subroutine {setter}(msg)"),
+    "  character(len=*), intent(in) :: msg",
+    "  integer :: i",
+    "  integer :: n",
+    if (isTRUE(openmp)) "  !$omp critical (quickr_error)",
+    glue("  if ({msg_name}(1) == c_null_char) then"),
+    glue("    n = min(len(msg), {len_val} - 1)"),
+    glue("    {msg_name}(1:n) = [(msg(i:i), i = 1, n)]"),
+    glue("    {msg_name}(n + 1) = c_null_char"),
+    "  end if",
+    if (isTRUE(openmp)) "  !$omp end critical (quickr_error)",
+    glue("end subroutine {setter}")
+  ))
+}
+
+quickr_error_fortran_lines <- function(message = NULL, scope = NULL) {
+  msg <- message %||% "quickr error"
+  stopifnot(is_string(msg))
+  if (!nzchar(msg)) {
+    msg <- "quickr error"
+  }
+  check_quickr_error_message_continuable(msg)
+  msg_literal <- fortran_string_literal(msg)
+  lines <- glue("call {quickr_error_setter_name()}({msg_literal})")
+  if (isTRUE(scope_in_openmp(scope))) {
+    lines <- c(lines, "!$omp cancel do")
+  } else {
+    lines <- c(lines, "return")
+  }
+  lines
+}
+
+quickr_error_return_if_set <- function(
+  scope,
+  openmp_depth = scope_openmp_depth(scope)
+) {
+  if (!isTRUE(scope_uses_errors(scope))) {
+    return("")
+  }
+  if (is.null(openmp_depth)) {
+    openmp_depth <- 0L
+  }
+  openmp_depth <- max(as.integer(openmp_depth), 0L)
+  if (openmp_depth > 0L) {
+    return(str_flatten_lines(
+      glue("if ({quickr_error_msg_name()}(1) /= c_null_char) then"),
+      "  !$omp cancel do",
+      "end if"
+    ))
+  }
+  glue("if ({quickr_error_msg_name()}(1) /= c_null_char) return")
+}

R/manifest.R

@@ -105,7 +105,8 @@ iso_c_binding_symbols <- function(
   vars,
   body_code = "",
   logical_is_c_int = logical_as_int,
-  uses_rng = FALSE
+  uses_rng = FALSE,
+  include_errors = FALSE
 ) {
   stopifnot(is.list(vars), is_string(body_code), is.function(logical_is_c_int))
 
@@ -152,6 +153,13 @@ iso_c_binding_symbols <- function(
     used_iso_bindings <- union(used_iso_bindings, "c_double")
   }
 
+  if (isTRUE(include_errors)) {
+    used_iso_bindings <- union(
+      used_iso_bindings,
+      c("c_char", "c_null_char")
+    )
+  }
+
   used_iso_bindings |>
     compact() |>
     unique() |>
@@ -256,7 +264,7 @@ emit_block <- function(decls, stmts) {
   ))
 }
 
-r2f.scope <- function(scope) {
+r2f.scope <- function(scope, include_errors = FALSE) {
   vars <- scope_vars(scope)
   vars <- lapply(vars, function(var) {
     intent_in <- var@name %in% names(formals(scope@closure))
@@ -331,6 +339,7 @@ r2f.scope <- function(scope) {
 
   manifest <- compact(list(
     sizes = sizes,
+    error = if (isTRUE(include_errors)) quickr_error_manifest_lines(),
     args = vars[non_local_var_names],
     locals = vars[setdiff(names(vars), non_local_var_names)]
   ))
@@ -346,7 +355,8 @@ r2f.scope <- function(scope) {
   # # method="radix" for locale-independent stable order.
   signature <- unique(c(
     non_local_var_names,
-    sort(size_names, method = "radix")
+    sort(size_names, method = "radix"),
+    if (isTRUE(include_errors)) quickr_error_arg_names()
   ))
   attr(manifest, "signature") <- signature
 

R/parallel.R

@@ -31,6 +31,44 @@ mark_openmp_used <- function(scope) {
   invisible(root)
 }
 
+scope_openmp_depth <- function(scope) {
+  if (!inherits(scope, "quickr_scope")) {
+    return(0L)
+  }
+  depth <- attr(scope, "openmp_depth", exact = TRUE)
+  if (is.null(depth)) {
+    0L
+  } else {
+    as.integer(depth)
+  }
+}
+
+scope_in_openmp <- function(scope) {
+  scope_openmp_depth(scope) > 0L
+}
+
+enter_openmp_scope <- function(scope) {
+  if (!inherits(scope, "quickr_scope")) {
+    return(NULL)
+  }
+  previous_depth <- attr(scope, "openmp_depth", exact = TRUE)
+  depth <- scope_openmp_depth(scope)
+  attr(scope, "openmp_depth") <- depth + 1L
+  previous_depth
+}
+
+exit_openmp_scope <- function(scope, previous_depth) {
+  if (!inherits(scope, "quickr_scope")) {
+    return(invisible(NULL))
+  }
+  if (is.null(previous_depth)) {
+    attr(scope, "openmp_depth") <- NULL
+  } else {
+    attr(scope, "openmp_depth") <- as.integer(previous_depth)
+  }
+  invisible(TRUE)
+}
+
 openmp_abort <- function(message, class = "quickr_openmp_error") {
   stop(
     structure(

R/quick.R

@@ -447,7 +447,9 @@ check_all_var_names_valid <- function(fun) {
         "c_ptrdiff_t",
 
         # clashes with C bridge symbols
-        "int" #, "double",
+        "int", #, "double",
+        quickr_error_msg_name(),
+        quickr_error_setter_name()
 
         # ??? (clashes with R symbols?)
         # "double", "integer"

R/r2f-closures.R

@@ -467,9 +467,16 @@ compile_closure_call <- function(
 
     call_args <- unname(args_f)
     if (length(call_args)) {
-      return(Fortran(glue("call {proc$name}({str_flatten_commas(call_args)})")))
+      call_stmt <- glue("call {proc$name}({str_flatten_commas(call_args)})")
+      return(Fortran(str_flatten_lines(
+        call_stmt,
+        quickr_error_return_if_set(scope)
+      )))
     }
-    return(Fortran(glue("call {proc$name}()")))
+    return(Fortran(str_flatten_lines(
+      glue("call {proc$name}()"),
+      quickr_error_return_if_set(scope)
+    )))
   }
 
   proc <- compile_local_closure_proc(
@@ -484,9 +491,16 @@ compile_closure_call <- function(
   if (!needs_value && is.null(proc$res)) {
     call_args <- unname(args_f)
     if (length(call_args)) {
-      return(Fortran(glue("call {proc$name}({str_flatten_commas(call_args)})")))
+      call_stmt <- glue("call {proc$name}({str_flatten_commas(call_args)})")
+      return(Fortran(str_flatten_lines(
+        call_stmt,
+        quickr_error_return_if_set(scope)
+      )))
     }
-    return(Fortran(glue("call {proc$name}()")))
+    return(Fortran(str_flatten_lines(
+      glue("call {proc$name}()"),
+      quickr_error_return_if_set(scope)
+    )))
   }
 
   res_var <- proc$res_var
@@ -497,6 +511,7 @@ compile_closure_call <- function(
   tmp <- hoist$declare_tmp(mode = res_var@mode, dims = res_var@dims)
   call_args <- c(unname(args_f), tmp@name)
   call_stmt <- glue("call {proc$name}({str_flatten_commas(call_args)})")
+  call_stmt <- str_flatten_lines(call_stmt, quickr_error_return_if_set(scope))
 
   if (needs_value) {
     hoist$emit(call_stmt)
@@ -621,6 +636,7 @@ compile_closure_call_assignment <- function(
   Fortran(glue(
     "
     call {proc$name}({str_flatten_commas(call_args)})
+    {quickr_error_return_if_set(scope)}
     {str_flatten_lines(post)}
     "
   ))
@@ -863,6 +879,22 @@ compile_sapply_assignment <- function(
   if (!is.null(parallel)) {
     mark_openmp_used(scope)
   }
+  error_check_inner <- if (is.null(parallel)) {
+    quickr_error_return_if_set(scope)
+  } else {
+    quickr_error_return_if_set(
+      scope,
+      openmp_depth = scope_openmp_depth(scope) + 1L
+    )
+  }
+  error_check_after <- if (!is.null(parallel)) {
+    quickr_error_return_if_set(
+      scope,
+      openmp_depth = scope_openmp_depth(scope)
+    )
+  } else {
+    ""
+  }
   loop_header <- glue("do {idx@name} = 1_c_int, {last_i}")
   prefix <- str_flatten_lines(
     if (!index_iterable) iterable_tmp_assign else NULL,
@@ -872,8 +904,10 @@ compile_sapply_assignment <- function(
     "
     {prefix}
       call {proc_name}({call_args})
+      {error_check_inner}
     end do
     {str_flatten_lines(directives$suffix)}
+    {error_check_after}
     {str_flatten_lines(post_stmts)}
     "
   ))