[5/15] Validate subscripts and make in-loop errors cancel OpenMP loops (#141)

* Move emit_quickr_error_if() to error-handling.R

The statement-level runtime-guard emitter is generic error machinery,
but it lived in the BLAS translation file, forcing any other handler
that wants a guard into an odd dependency. Move it next to the rest of
the quickr error plumbing, unchanged.

* Validate subscripts: reject exclusion, guard index ranges

R's negative subscript means exclusion and its zero subscript is
dropped -- both produce value-dependent result shapes that quickr's
static-shape model cannot represent -- but the `[` handler forwarded
them verbatim into Fortran, where x(-1) and x(0) are silent
out-of-bounds reads. Similarly, x[a:b] lowers to the section
a:b:sign(1, b-a) with claimed length abs(b-a)+1, which is only correct
when both bounds are >= 1: x[1:n] with n = 0 read x(0) and returned 2
values where R returns 1.

Compile errors where the problem is visible statically:
- any negative or zero subscript value, and the syntactic form x[-i]
  (unary minus is unambiguously exclusion in R)
- literal range bounds < 1
- seq() in subscript position with a non-literal `by`: the result
  length divides by the step and is evaluated in the generated C bridge
  before any Fortran guard could run, so a zero step would be an
  unguardable division-by-zero crash there

Runtime guards (one scalar check per statement, via
emit_quickr_error_if) where the values are only known at run time:
- x[a:b] bounds not provably >= 1, raising "index ranges in x[a:b]
  must have bounds >= 1"; literal-bound halves of the check are
  constant-folded away, and descending ranges x[n:1] still work
- x[seq(a, b, by)] with literal step but symbolic bounds, raising
  "wrong sign in 'by' argument" as R does

Also fixes seq_like_length_expr() silently dropping a non-literal `by`
when from/to are literal: seq(1L, 9L, by = k) claimed length 9
regardless of k, mis-sizing constructor results (now sized by the
step) and subscript sections (now rejected, above).

x[seq_len(n)] / x[seq_along(y)] need no guard: their worst case is a
legal zero-length section, matching R's x[integer(0)]. For-loop ranges
are untouched (do i = 1, 0 already runs zero times).

Behavior change to note: R's x[1:0] returns x[1] (the 0 is dropped);
quickr now errors at runtime instead of reading out of bounds.

* Enable OpenMP cancellation so in-loop errors exit early

Error paths inside parallel loops emit `!$omp cancel do`, but per the
OpenMP spec cancel constructs are no-ops unless the cancel-var ICV is
true, which requires OMP_CANCELLATION=true in the environment when the
OpenMP runtime first initializes. Nothing set it, so an error raised
inside a parallel loop recorded its message correctly (first-wins
critical section) but every remaining iteration still ran -- wasted
work, and statements after a failed in-loop check kept executing in
that iteration's thread.

Set OMP_CANCELLATION=true in .onLoad when unset (a pre-set value is
respected). Caveats documented in ?declare: no effect if another
package already initialized the OpenMP runtime, so early exit is
best-effort -- error messages are always correct either way.

* Validate assignment subscripts and literal bounds against known extents

Two gaps in subscript validation (both compile-and-return-garbage, found
in external review):

- The write side never validated at all: x[-1L] <- 9 and x[0L] <- 1
  compiled into silent out-of-bounds Fortran writes, bypassing the
  exclusion/zero rejection the read-side `[` handler already had.
  compile_subset_designator() now runs the same checks, covering [<-,
  [<<-, and closure host writes.

- Literal subscripts were never checked against a statically-known
  extent: x[4L] and x[2:4] on a declared double(3) compiled and read
  garbage, where R pads with NA (and grows the vector on writes) --
  neither representable in quickr's static-shape model. When the base's
  extent along an axis is a literal, out-of-range literal values, `:`
  endpoints, and c() elements are now compile errors. A single subscript
  on a rank>1 base (R's linear indexing) checks against the product of
  the dims. Symbolic subscripts and symbolic extents are untouched, per
  the documented bounds contract.

Range lower-bound validation (>= 1, including the runtime guard for
symbolic endpoints) stays in check_subscript_range_bounds(); the new
extent check only adds the upper side for literals.

* Extract check_subscript_exprs() shared by read and write subscripts

The read-side `[` handler and the write-side compile_subset_designator()
carried the same six-line validation loop; the invariant that both sides
validate identically is now pinned by a single helper instead of a
comment asking to keep two copies in sync.

Review finding (fable-final-review.md #3); no behavior change.

* Validate coerced subscripts and symbolic seq steps

* Accept signed literal seq steps

* Accept valid singleton and double-negated subscripts

* Fix hoisting in unbraced for-loop bodies

Braced loop bodies give each statement its own hoist target, but a single-expression for-loop body inherited the target of the enclosing statement. Body-local setup could therefore be emitted before the loop, where it executed only once and could reference an uninitialized loop variable.

Give both index- and value-iteration bodies a fresh hoist target. Iterable setup remains outside the loop, while guards and temporaries required by the body are emitted inside it.

* Drop runtime guards for dynamic subscript bounds

Dynamic range guards added work to hot loops while checking only lower bounds. Upper bounds and symbolic scalar and vector subscripts remained unchecked, so the partial guard did not provide a coherent safety contract.

Keep zero-cost compile-time validation for unsupported or statically invalid subscripts, and keep runtime validation required for seq() step semantics. Dynamically computed array bounds remain the caller's responsibility.

---------

Co-authored-by: Tomasz Kalinowski <kalinowskit@gmail.com>

Author: mns-nordicals

R/c-wrapper.R

@@ -459,6 +459,26 @@ c_bridge_hoist_take_pending <- function(hoist) {
   pending
 }
 
+c_bridge_hoist_seq_checks <- function(hoist, from, to, by) {
+  stopifnot(
+    is.environment(hoist),
+    is_string(from),
+    is_string(to),
+    is_string(by)
+  )
+  hoist$pending <- c(
+    hoist$pending,
+    glue(
+      '
+      if (({from} != {to}) && ({by} == 0))
+        Rf_error("invalid \'(to - from)/by\'");
+      if ((({from} < {to}) && ({by} < 0)) ||
+          (({from} > {to}) && ({by} > 0)))
+        Rf_error("wrong sign in \'by\' argument");'
+    )
+  )
+}
+
 
 as_c_name <- function(var, c_hoist = NULL) {
   stopifnot(inherits(var, Variable))
@@ -582,6 +602,23 @@ dims2c_expr <- function(e, scope, c_hoist = NULL) {
     return(dims2c_dim_index_expr(call("[", call("dim", args[[1L]]), 2L), scope))
   }
 
+  if (identical(op, "quickr_seq_length")) {
+    if (length(args) != 3L || is.null(c_hoist)) {
+      stop("quickr_seq_length() requires three arguments and a C bridge hoist")
+    }
+    from <- dims2c_expr(args[[1L]], scope, c_hoist = c_hoist)
+    to <- dims2c_expr(args[[2L]], scope, c_hoist = c_hoist)
+    by <- dims2c_expr(args[[3L]], scope, c_hoist = c_hoist)
+    c_bridge_hoist_seq_checks(c_hoist, from, to, by)
+
+    safe_by <- glue("(({by}) == 0 ? 1 : ({by}))")
+    delta <- glue("((R_xlen_t)({to}) - (R_xlen_t)({from}))")
+    quotient <- glue("({delta} / (R_xlen_t)({safe_by}))")
+    return(glue(
+      "((({quotient}) < 0 ? -({quotient}) : ({quotient})) + 1)"
+    ))
+  }
+
   if (identical(op, "abs")) {
     if (length(args) != 1L) {
       stop("abs() expects one argument")

R/declare.R

@@ -18,6 +18,15 @@
 #' and `OMP_DYNAMIC` (disable/enable runtime adjustment). Set them before
 #' calling a compiled function, e.g. `Sys.setenv(OMP_NUM_THREADS = "4")`.
 #'
+#' When an error is raised inside a parallel loop, quickr cancels the
+#' remaining iterations via OpenMP cancellation, which the OpenMP runtime
+#' only honors when `OMP_CANCELLATION=true` is set before the runtime first
+#' initializes in the process. quickr sets it when the package loads (unless
+#' already set), but this has no effect if another package initialized the
+#' OpenMP runtime first. Early exit is best-effort either way: the error
+#' message is always recorded correctly; without cancellation the remaining
+#' iterations simply run to completion before the error is raised.
+#'
 #' @param ... Declarations, typically calls like `type(x = double(n))`.
 #' @returns `NULL`, invisibly.
 #' @rawNamespace if (getRversion() < "4.4.0") export(declare)

R/error-handling.R

@@ -112,6 +112,32 @@ quickr_error_fortran_lines <- function(message = NULL, scope = NULL) {
   lines
 }
 
+# Emit a runtime guard: if `condition` holds, record a quickr error and
+# bail out of the subroutine (or cancel the OpenMP loop). Statement-level
+# machinery shared by any handler that needs a runtime check.
+emit_quickr_error_if <- function(
+  condition,
+  message,
+  hoist,
+  scope
+) {
+  stopifnot(
+    is_string(condition),
+    is_string(message),
+    inherits(hoist, "environment"),
+    inherits(scope, "quickr_scope")
+  )
+  mark_scope_uses_errors(scope)
+  err_lines <- quickr_error_fortran_lines(message, scope = scope)
+  hoist$emit(glue(
+    "
+    if ({condition}) then
+    {indent(str_flatten_lines(err_lines))}
+    end if
+    "
+  ))
+}
+
 quickr_error_return_if_set <- function(
   scope,
   openmp_depth = scope_openmp_depth(scope)

R/manifest.R

@@ -522,6 +522,10 @@ dims2f_eval_base_env[["%%"]] <- function(e1, e2) {
 }
 dims2f_eval_base_env[["^"]] <- function(e1, e2) glue("({e1})**({e2})")
 dims2f_eval_base_env[["abs"]] <- function(x) glue("abs({x})")
+dims2f_eval_base_env[["quickr_seq_length"]] <- function(from, to, by) {
+  safe_by <- glue("merge(int({by}), 1, int({by}) /= 0)")
+  glue("(abs((int({to}) - int({from})) / {safe_by}) + 1)")
+}
 dims2f_eval_base_env[["length"]] <- function(x) {
   if (is.symbol(x)) {
     glue("size({as.character(x)})")

R/r2f-closures.R

@@ -1389,6 +1389,11 @@ compile_subset_designator <- function(
     is_bool(allow_logical_vector_subscripts)
   )
 
+  # Same validation as the read-side `[` handler: assignment subscripts
+  # would otherwise lower R's exclusion/zero/out-of-range subscripts into
+  # silent out-of-bounds Fortran writes.
+  check_subscript_exprs(base_var, idx_args)
+
   idxs <- whole_doubles_to_ints(idx_args)
   idxs <- imap(idxs, function(idx, i) {
     if (is_missing(idx)) {

R/r2f-control-flow.R

@@ -77,7 +77,7 @@ r2f_handlers[["while"]] <- function(args, scope, ...) {
 }
 
 # ---- for ----
-r2f_handlers[["for"]] <- function(args, scope, ...) {
+r2f_handlers[["for"]] <- function(args, scope, ..., hoist = NULL) {
   .[var, iterable, body] <- args
   stopifnot(is.symbol(var))
   var <- as.character(var)
@@ -174,7 +174,10 @@ r2f_handlers[["for"]] <- function(args, scope, ...) {
       previous_openmp <- enter_openmp_scope(scope)
       on.exit(exit_openmp_scope(scope, previous_openmp), add = TRUE)
     }
-    body <- r2f(body, scope, ...)
+    # The body is a distinct execution region and needs its own hoist target.
+    # Otherwise a single-expression body reuses the enclosing statement's
+    # target and emits loop-dependent setup before the loop.
+    body <- r2f(body, scope, ..., hoist = NULL)
     check_pending_parallel_consumed(scope)
     loop_stmts <- str_flatten_lines(glue("{var_name} = {element_expr}"), body)
 
@@ -214,12 +217,14 @@ r2f_handlers[["for"]] <- function(args, scope, ...) {
   }
   scope[[var]] <- loop_var
 
-  iterable <- r2f_for_iterable(iterable, scope, ...)
+  iterable <- r2f_for_iterable(iterable, scope, ..., hoist = hoist)
   if (!is.null(parallel)) {
     previous_openmp <- enter_openmp_scope(scope)
     on.exit(exit_openmp_scope(scope, previous_openmp), add = TRUE)
   }
-  body <- r2f(body, scope, ...)
+  # See the value-iteration path above: body-local setup must run inside the
+  # loop even when the R body is not wrapped in braces.
+  body <- r2f(body, scope, ..., hoist = NULL)
   check_pending_parallel_consumed(scope)
 
   directives <- openmp_directives(parallel)

R/r2f-iterables-helpers.R

@@ -46,7 +46,11 @@ seq_like_length_expr <- function(from, to, by = NULL) {
     return(1L)
   }
 
-  if (is_scalar_integerish(from) && is_scalar_integerish(to)) {
+  if (
+    is_scalar_integerish(from) &&
+      is_scalar_integerish(to) &&
+      (is.null(by) || is_scalar_integerish(by)) # symbolic by: length needs it
+  ) {
     from_val <- as.integer(from)
     to_val <- as.integer(to)
     delta <- to_val - from_val
@@ -72,7 +76,39 @@ seq_like_length_expr <- function(from, to, by = NULL) {
   if (is.null(by)) {
     return(call("+", call("abs", call("-", to, from)), 1L))
   }
-  call("+", call("abs", call("%/%", call("-", to, from), by)), 1L)
+  call("quickr_seq_length", from, to, by)
+}
+
+seq_like_step_needs_runtime_check <- function(info) {
+  !is.null(info$by) &&
+    !(is_scalar_integerish(info$from) &&
+      is_scalar_integerish(info$to) &&
+      is_scalar_integerish(info$by))
+}
+
+emit_seq_step_runtime_checks <- function(from, to, by, hoist, scope) {
+  stopifnot(
+    inherits(from, Fortran),
+    inherits(to, Fortran),
+    inherits(by, Fortran),
+    inherits(hoist, "environment"),
+    inherits(scope, "quickr_scope")
+  )
+  emit_quickr_error_if(
+    glue("({from} /= {to}) .and. ({by} == 0_c_int)"),
+    "invalid '(to - from)/by'",
+    hoist,
+    scope
+  )
+  emit_quickr_error_if(
+    glue(
+      "(({to} > {from}) .and. ({by} < 0_c_int)) .or. ",
+      "(({to} < {from}) .and. ({by} > 0_c_int))"
+    ),
+    "wrong sign in 'by' argument",
+    hoist,
+    scope
+  )
 }
 
 # Parse a seq-like call into its components.
@@ -249,6 +285,24 @@ seq_like_r2f <- function(
     context <- "value"
   }
 
+  check_step_at_runtime <- kind == "seq" &&
+    seq_like_step_needs_runtime_check(info)
+  if (check_step_at_runtime && context != "[") {
+    emit_seq_step_runtime_checks(
+      from,
+      to,
+      by,
+      hoist = list(...)$hoist,
+      scope = scope
+    )
+  }
+  if (check_step_at_runtime) {
+    by <- Fortran(
+      glue("merge(int({by}, kind=c_int), 1_c_int, {from} /= {to})"),
+      Variable("integer")
+    )
+  }
+
   if (is.null(len_expr) || is_scalar_na(len_expr)) {
     len_expr <- NA_integer_
   }
@@ -280,6 +334,18 @@ seq_like_r2f <- function(
       glue("{start}, {end}, {step}")
     }
   } else if (context == "[") {
+    # Validate statically-known unsupported bounds and seq() step semantics.
+    # Dynamically computed array bounds remain the caller's responsibility.
+    if (kind %in% c(":", "seq")) {
+      check_subscript_range_bounds(
+        info,
+        from,
+        to,
+        by_f = by,
+        hoist = list(...)$hoist,
+        scope = scope
+      )
+    }
     fr <- if (omit_step) {
       glue("{start}:{end}")
     } else {
@@ -297,6 +363,77 @@ seq_like_r2f <- function(
   Fortran(fr, val)
 }
 
+# Validate an x[a:b] / x[seq(a, b, by)] index range where doing so has no
+# general bounds-checking cost. Statically bad literal bounds are compile
+# errors. Dynamic bounds are trusted, consistently with symbolic scalar and
+# vector subscripts. An explicit seq() step is handled below (literal-only,
+# plus a runtime wrong-sign check required by seq() semantics).
+# Used by: seq_like_r2f() (subscript context)
+check_subscript_range_bounds <- function(info, from, to, by_f, hoist, scope) {
+  lit <- function(e) {
+    e <- unwrap_parens(e)
+    if (is_scalar_integerish(e)) as.integer(e) else NA_integer_
+  }
+  from_lit <- lit(info$from)
+  to_lit <- lit(info$to)
+  by_lit <- if (is.null(info$by)) 1L else lit(info$by)
+  same_endpoint <- identical(
+    unwrap_parens(info$from),
+    unwrap_parens(info$to)
+  )
+
+  bounds_msg <- "index ranges in x[a:b] must have bounds >= 1"
+  if (isTRUE(from_lit < 1L) || isTRUE(to_lit < 1L)) {
+    stop(
+      bounds_msg,
+      ": ",
+      deparse1(info$from),
+      ", ",
+      deparse1(info$to),
+      call. = FALSE
+    )
+  }
+
+  emit <- function(condition, message) {
+    if (is.null(hoist)) {
+      stop(
+        "cannot emit a runtime subscript-range guard here; ",
+        "use literal bounds >= 1 in x[a:b]",
+        call. = FALSE
+      )
+    }
+    emit_quickr_error_if(condition, message, hoist, scope)
+  }
+
+  # Explicit seq() step. When the endpoints differ, the result length divides
+  # by the step, and that length is evaluated in the C bridge *before* any
+  # Fortran guard can run (a zero step would be a division-by-zero crash
+  # there), so a non-literal step is a compile error, not a guard. With a
+  # literal step and symbolic bounds, R errors when the step's sign opposes
+  # the direction -- the emitted section would be zero-length while the
+  # claimed length is not; that case is checkable at runtime. All-literal
+  # ranges were already validated by seq_like_length_expr() at compile time.
+  if (!is.null(info$by) && !same_endpoint) {
+    if (is.na(by_lit)) {
+      stop(
+        "seq() in x[...] requires a literal `by` step ",
+        "(the result length depends on it): by = ",
+        deparse1(info$by),
+        call. = FALSE
+      )
+    }
+    if (is.na(from_lit) || is.na(to_lit)) {
+      emit(
+        glue(
+          "(({to} /= {from}) .and. (sign(1_c_int, {by_f}) /= sign(1_c_int, {to} - {from})))"
+        ),
+        "wrong sign in 'by' argument in x[seq(a, b, by)]"
+      )
+    }
+  }
+  invisible(NULL)
+}
+
 # Unwrap a for-loop iterable, handling rev() calls.
 # Used by: r2f-control-flow.R
 r2f_unwrap_for_iterable <- function(iterable) {

R/r2f-matrix-blas.R

@@ -74,29 +74,6 @@ assert_conformable_dims <- function(left, right, context, err_msg) {
   invisible(TRUE)
 }
 
-emit_quickr_error_if <- function(
-  condition,
-  message,
-  hoist,
-  scope
-) {
-  stopifnot(
-    is_string(condition),
-    is_string(message),
-    inherits(hoist, "environment"),
-    inherits(scope, "quickr_scope")
-  )
-  mark_scope_uses_errors(scope)
-  err_lines <- quickr_error_fortran_lines(message, scope = scope)
-  hoist$emit(glue(
-    "
-    if ({condition}) then
-    {indent(str_flatten_lines(err_lines))}
-    end if
-    "
-  ))
-}
-
 # Return the R symbol name if operand is a bare symbol; otherwise NULL.
 symbol_name_or_null <- function(x) {
   stopifnot(inherits(x, Fortran))