[3/15] Apply R's type-promotion lattice: promoted result modes, operand casts, and a narrowing-reassignment error (t-kalinowski#139)

* Report and apply promoted result modes in operators and constructors

reduce_promoted_mode() implemented R's mode lattice correctly but was
only used for c()/reduction output declarations; conform() reported the
first non-scalar operand's mode, and no operand was ever cast. Since
`<-` copies the reported mode verbatim into the target's declaration,
mixed integer/double arithmetic silently truncated (x + 0.5 on integer
x returned integers), and every context where Fortran requires uniform
argument types -- array constructors, min/max, modulo -- failed at the
gfortran stage for mixed modes. Logical operands could not participate
in arithmetic or comparisons at all.

Centralize the mechanism in two helpers and wire it through:

- cast_to_mode(x, mode, context): the one place cast spellings live.
  Handles integer->double, logical->integer/double (booleanizing or
  relabeling bind(c) integer-backed logicals as needed), and errors
  cleanly on casts it cannot spell. bind_cast_value() folds into it.
- promote_operands(args, context): join + cast for uniform-type
  contexts (c(), multi-arg min/max/sum/prod, modulo).
- conform() now reports the lattice join; the lattice gains complex as
  its top so complex results no longer depend on operand order.
- ^ always returns double like R, casting the base but keeping integer
  exponents integer (real ** int is exact and defined for negative
  bases, matching R_pow); the parenthesized exponent fixes the
  non-standard `x ** -1_c_int` spelling.
- Arithmetic and comparisons cast logical operands to integer
  (R: TRUE + TRUE is 2L), including unary +/-.

Snapshot churn: heat-diffusion's dx^2/dy^2 gain the base cast and
exponent parens; all runtime results are unchanged there.

* Error when reassignment would narrow a variable's mode

R re-types a binding on assignment (x <- x + 0.5 promotes an integer x
to double); Fortran cannot re-type a variable, so quickr kept the
declared mode and the assignment silently truncated the value back into
it -- quick() returned 2 where R returns 2.5, with no diagnostic.
check_assignment_compatible() only checked rank, not mode.

Add check_reassignment_narrowing(): reassigning a value whose mode sits
above the target's on the lattice (logical < integer < double <
complex) is now a compile-time error naming the variable and both
modes. Same-mode reassignment and assigning a lower-mode value into a
wider variable (x_dbl <- x_dbl + 1L) are unaffected.

* Compute double %/% in the real domain

Fortran FLOOR() returns a default-kind integer, so the double branch of
%/% silently overflowed large quotients: 1e20 %/% 3 came back as
-2147483648 instead of ~3.33e19. The sibling floor() handler already
avoids this with aint() plus a merge() adjustment in real arithmetic;
use the same expression here, hoisting the quotient so it is evaluated
once instead of three times.

* Extend the narrowing check to subassignment and superassignment

check_reassignment_narrowing() only guarded whole-variable `<-`, so
`x[1L] <- 2.5` on a declared-integer x silently truncated to 2L where R
promotes the whole vector to double -- the same contract hole the
reassignment check was added to close. `x <<- val` and `x[i] <<- val`
inside local closures had the identical gap.

Run the same check against the base variable in the `[<-`, `<<-`, and
`[<<-` handlers.

* Treat logicals as integers in abs() and single-arg reductions

The logical-as-integer arithmetic rule was spelled inline at each call
site, and two sites missed it: abs() passed logical expressions straight
to Fortran's abs(), and the single-argument reduction path emitted
sum((x /= 0)) / minval((x /= 0)) / etc. -- all gfortran type errors,
where R returns integer results (abs(TRUE) is 1L, sum(TRUE) is 1L).

Name the rule once as arith_join_mode() and use it in abs(), reduce_arg,
and the existing inline spellings (unary +/-, %%, multi-arg reductions,
promote_arith_pair), so the next consumer cannot miss it.

* Spell the mode lattice once: shared mode_lattice + mode_rank()

The narrowing check hand-spelled the promotion order that
reduce_promoted_mode() encoded as an if-chain, so the two rules this
branch ties together -- what a join promotes to, and what a
reassignment may not narrow from -- could drift apart. One lattice
constant and a mode_rank() helper now back both: the join takes the
highest rank present (modes outside the lattice are ignored, as the
old chain did), the narrowing check compares ranks. No behavior
change.

* Format with air

* Use result unpacking for more compact and readable code.

* Create snapshots of assignmetn narrowing errors

Author: mns-nordicals

R/r2f-arithmetic.R

@@ -7,12 +7,13 @@ r2f_handlers[["+"]] <- function(args, scope, ...) {
   # Support both binary and unary plus
   if (length(args) == 1L) {
     x <- r2f(args[[1L]], scope, ...)
+    # R: +TRUE is 1L
+    x <- cast_to_mode(x, arith_join_mode(x), "unary +")
     Fortran(glue("(+{x})"), Variable(x@value@mode, x@value@dims))
   } else {
     .[left, right] <- lapply(args, r2f, scope, ...)
-    reshaped <- maybe_reshape_vector_matrix(left, right)
-    left <- reshaped$left
-    right <- reshaped$right
+    .[left, right] <- promote_arith_pair(left, right, "+")
+    .[left, right] <- maybe_reshape_vector_matrix(left, right)
     Fortran(glue("({left} + {right})"), conform(left@value, right@value))
   }
 }
@@ -21,40 +22,52 @@ r2f_handlers[["-"]] <- function(args, scope, ...) {
   # Support both binary and unary minus
   if (length(args) == 1L) {
     x <- r2f(args[[1L]], scope, ...)
+    # R: -TRUE is -1L
+    x <- cast_to_mode(x, arith_join_mode(x), "unary -")
     Fortran(glue("(-{x})"), Variable(x@value@mode, x@value@dims))
   } else {
     .[left, right] <- lapply(args, r2f, scope, ...)
-    reshaped <- maybe_reshape_vector_matrix(left, right)
-    left <- reshaped$left
-    right <- reshaped$right
+    .[left, right] <- promote_arith_pair(left, right, "-")
+    .[left, right] <- maybe_reshape_vector_matrix(left, right)
     Fortran(glue("({left} - {right})"), conform(left@value, right@value))
   }
 }
 
 r2f_handlers[["*"]] <- function(args, scope = NULL, ...) {
   .[left, right] <- lapply(args, r2f, scope, ...)
-  reshaped <- maybe_reshape_vector_matrix(left, right)
-  left <- reshaped$left
-  right <- reshaped$right
+  .[left, right] <- promote_arith_pair(left, right, "*")
+  .[left, right] <- maybe_reshape_vector_matrix(left, right)
   Fortran(glue("({left} * {right})"), conform(left@value, right@value))
 }
 
 r2f_handlers[["/"]] <- function(args, scope = NULL, ...) {
   .[left, right] <- lapply(args, r2f, scope, ...)
   left <- maybe_cast_double(left)
   right <- maybe_cast_double(right)
-  reshaped <- maybe_reshape_vector_matrix(left, right)
-  left <- reshaped$left
-  right <- reshaped$right
+  .[left, right] <- maybe_reshape_vector_matrix(left, right)
   Fortran(glue("({left} / {right})"), conform(left@value, right@value))
 }
 
 r2f_handlers[["^"]] <- function(args, scope, ...) {
   .[left, right] <- lapply(args, r2f, scope, ...)
-  reshaped <- maybe_reshape_vector_matrix(left, right)
-  left <- reshaped$left
-  right <- reshaped$right
-  Fortran(glue("({left} ** {right})"), conform(left@value, right@value))
+  # R's ^ always returns double (R_pow), so cast the base. Keep an integer
+  # exponent as integer: Fortran `real ** int` is exact and, unlike
+  # `real ** real`, defined for negative bases -- matching R, which
+  # special-cases whole-number exponents.
+  left <- maybe_cast_double(left)
+  if (identical(right@value@mode, "logical")) {
+    right <- cast_to_mode(right, "integer", "^")
+  }
+  .[left, right] <- maybe_reshape_vector_matrix(left, right)
+  mode <- reduce_promoted_mode(left, right)
+  if (!identical(mode, "complex")) {
+    mode <- "double"
+  }
+  # Parenthesizing the exponent avoids non-standard `** -1_c_int`.
+  Fortran(
+    glue("({left} ** ({right}))"),
+    conform(left@value, right@value, mode = mode)
+  )
 }
 
 
@@ -72,21 +85,38 @@ r2f_handlers[["^"]] <- function(args, scope, ...) {
 
 r2f_handlers[["%%"]] <- function(args, scope, ...) {
   .[left, right] <- lapply(args, r2f, scope, ...)
+  # `modulo` requires same-typed arguments, so cast both operands to the
+  # join (logical joins as integer: R's TRUE %% TRUE is 0L).
+  mode <- arith_join_mode(left, right)
+  left <- cast_to_mode(left, mode, "%%")
+  right <- cast_to_mode(right, mode, "%%")
   out_val <- conform(left@value, right@value)
   # MODULO gives result with sign(right) - matches R %% behaviour
   Fortran(glue("modulo({left}, {right})"), out_val)
 }
 
-r2f_handlers[["%/%"]] <- function(args, scope, ...) {
-  .[left, right] <- lapply(args, r2f, scope, ...)
+r2f_handlers[["%/%"]] <- function(args, scope, ..., hoist = NULL) {
+  .[left, right] <- lapply(args, r2f, scope, ..., hoist = hoist)
+  .[left, right] <- promote_arith_pair(left, right, "%/%")
   out_val <- conform(left@value, right@value)
 
   expr <- switch(
     out_val@mode,
     integer = glue(
       "int(floor(real({left}, kind=c_double) / real({right}, kind=c_double)), kind=c_int)"
     ),
-    double = glue("floor({left} / {right})"),
+    double = {
+      # Fortran FLOOR() returns an integer, so a large double quotient
+      # (e.g. 1e20 %/% 3) would silently overflow. Stay in the real domain
+      # as the floor() handler does; the quotient is spliced three times,
+      # so hoist it to evaluate once.
+      q <- hoist_unless_name(
+        Fortran(glue("({left} / {right})"), out_val),
+        hoist
+      )
+      aint <- glue("aint({q})")
+      glue("({aint} - merge(1.0_c_double, 0.0_c_double, ({q} < {aint})))")
+    },
     stop("%/% only implemented for numeric types")
   )
 

R/r2f-assign.R

@@ -222,6 +222,7 @@ register_r2f_handler(
         var@mode <- value@value@mode
         var@dims <- value@value@dims
       }
+      check_reassignment_narrowing(name, var, value@value)
       check_assignment_compatible(var, value@value)
       var@modified <- TRUE
       # could probably drop this @modified property, and instead track
@@ -259,6 +260,12 @@ register_r2f_handler(
     lhs <- compile_subscript_lhs(target_call, scope, ..., target = "local")
     value <- r2f(args[[2L]], scope, ...)
 
+    # Subassignment cannot re-type the base variable any more than
+    # whole-variable reassignment can: `x[1L] <- 2.5` on an integer `x`
+    # would silently truncate where R promotes `x` to double.
+    base_name <- as.character(target_call[[2L]])
+    check_reassignment_narrowing(base_name, get0(base_name, scope), value@value)
+
     Fortran(str_flatten_lines(lhs$pre, glue("{lhs$lhs} = {value}")))
   }
 )
@@ -313,6 +320,7 @@ register_r2f_handler(
     host_scope[[name]] <- host_var
 
     value <- r2f(args[[2L]], scope, ..., hoist = hoist)
+    check_reassignment_narrowing(name, host_var, value@value)
     check_assignment_compatible(host_var, value@value)
 
     Fortran(glue("{host_var@name} = {value}"))
@@ -366,6 +374,7 @@ register_r2f_handler(
       target = "host"
     )
     value <- r2f(args[[2L]], scope, ..., hoist = hoist)
+    check_reassignment_narrowing(name, host_var, value@value)
     Fortran(glue("{lhs$lhs} = {value}"))
   }
 )

R/r2f-constructors.R

@@ -6,6 +6,12 @@
 
 r2f_handlers[["c"]] <- function(args, scope = NULL, ...) {
   ff <- lapply(args, r2f, scope, ...)
+  # Fortran array constructors require uniform element types; cast every
+  # element whose mode differs from the promoted mode (R: c(1L, 2.5) is
+  # double, c(TRUE, 2L) is integer).
+  promoted <- promote_operands(ff, context = "c()")
+  ff <- promoted$args
+  mode <- promoted$mode
   s <- glue("[ {str_flatten_commas(ff)} ]")
   lens <- lapply(ff[order(map_int(ff, \(f) f@value@rank))], function(e) {
     rank <- e@value@rank
@@ -17,7 +23,6 @@ r2f_handlers[["c"]] <- function(args, scope = NULL, ...) {
       stop("all args passed to c() must be scalars or 1-d arrays")
     }
   })
-  mode <- reduce_promoted_mode(ff)
   len <- Reduce(
     \(l1, l2) {
       if (is_scalar_na(l1) || is_scalar_na(l2)) {

R/r2f-logical.R

@@ -7,41 +7,53 @@
 
 r2f_handlers[[">="]] <- function(args, scope, ...) {
   .[left, right] <- lapply(args, r2f, scope, ...)
+  # R compares logicals as integers; Fortran has no logical comparison.
+  .[left, right] <- promote_arith_pair(left, right, "comparison")
   var <- conform(left@value, right@value)
   var@mode <- "logical"
   Fortran(glue("({left} >= {right})"), var)
 }
 
 r2f_handlers[[">"]] <- function(args, scope, ...) {
   .[left, right] <- lapply(args, r2f, scope, ...)
+  # R compares logicals as integers; Fortran has no logical comparison.
+  .[left, right] <- promote_arith_pair(left, right, "comparison")
   var <- conform(left@value, right@value)
   var@mode <- "logical"
   Fortran(glue("({left} > {right})"), var)
 }
 
 r2f_handlers[["<"]] <- function(args, scope, ...) {
   .[left, right] <- lapply(args, r2f, scope, ...)
+  # R compares logicals as integers; Fortran has no logical comparison.
+  .[left, right] <- promote_arith_pair(left, right, "comparison")
   var <- conform(left@value, right@value)
   var@mode <- "logical"
   Fortran(glue("({left} < {right})"), var)
 }
 
 r2f_handlers[["<="]] <- function(args, scope, ...) {
   .[left, right] <- lapply(args, r2f, scope, ...)
+  # R compares logicals as integers; Fortran has no logical comparison.
+  .[left, right] <- promote_arith_pair(left, right, "comparison")
   var <- conform(left@value, right@value)
   var@mode <- "logical"
   Fortran(glue("({left} <= {right})"), var)
 }
 
 r2f_handlers[["=="]] <- function(args, scope, ...) {
   .[left, right] <- lapply(args, r2f, scope, ...)
+  # R compares logicals as integers; Fortran has no logical comparison.
+  .[left, right] <- promote_arith_pair(left, right, "comparison")
   var <- conform(left@value, right@value)
   var@mode <- "logical"
   Fortran(glue("({left} == {right})"), var)
 }
 
 r2f_handlers[["!="]] <- function(args, scope, ...) {
   .[left, right] <- lapply(args, r2f, scope, ...)
+  # R compares logicals as integers; Fortran has no logical comparison.
+  .[left, right] <- promote_arith_pair(left, right, "comparison")
   var <- conform(left@value, right@value)
   var@mode <- "logical"
   Fortran(glue("({left} /= {right})"), var)

R/r2f-math.R

@@ -121,6 +121,9 @@ r2f_handlers[["log10"]] <- function(args, scope, ...) {
 r2f_handlers[["abs"]] <- function(args, scope, ...) {
   stopifnot(length(args) == 1L)
   arg <- r2f(args[[1]], scope, ...)
+  # R: abs(logical) is integer (abs(TRUE) is 1L); Fortran's abs() requires
+  # a numeric argument, so a logical operand participates as integer.
+  arg <- cast_to_mode(arg, arith_join_mode(arg), "abs()")
   out_mode <- if (arg@value@mode == "complex") "double" else arg@value@mode
   Fortran(glue("abs({arg})"), Variable(mode = out_mode, dims = arg@value@dims))
 }

R/r2f-matrix.R

@@ -224,29 +224,6 @@ bind_output_mode <- function(values, context) {
   stop(context, " does not support input mode(s): ", str_flatten_commas(modes))
 }
 
-bind_cast_value <- function(value, mode, context) {
-  if (identical(value@value@mode, mode)) {
-    return(value)
-  }
-  if (identical(mode, "double")) {
-    return(maybe_cast_double(value))
-  }
-  if (identical(mode, "integer") && identical(value@value@mode, "logical")) {
-    return(Fortran(
-      glue("merge(1_c_int, 0_c_int, {value})"),
-      Variable("integer", value@value@dims)
-    ))
-  }
-  stop(
-    context,
-    " does not support coercion from ",
-    value@value@mode,
-    " to ",
-    mode,
-    call. = FALSE
-  )
-}
-
 bind_dim_sum <- function(values, context, label) {
   if (!length(values)) {
     return(0L)
@@ -381,7 +358,7 @@ register_r2f_handler(
     }
 
     mode <- bind_output_mode(values, context)
-    values <- lapply(values, bind_cast_value, mode = mode, context = context)
+    values <- lapply(values, cast_to_mode, mode = mode, context = context)
 
     dims <- lapply(values, matrix_dims, orientation = "colvec")
     scalar_flags <- map_lgl(values, \(val) passes_as_scalar(val@value))
@@ -437,7 +414,7 @@ register_r2f_handler(
     }
 
     mode <- bind_output_mode(values, context)
-    values <- lapply(values, bind_cast_value, mode = mode, context = context)
+    values <- lapply(values, cast_to_mode, mode = mode, context = context)
 
     dims <- lapply(values, matrix_dims, orientation = "rowvec")
     scalar_flags <- map_lgl(values, \(val) passes_as_scalar(val@value))