Merge pull request t-kalinowski#85 from mns-nordicals/split-r2f.R

Split r2f.R into domain-specific handler and helper files

Author: t-kalinowski

R/r2f-aab-core.R

@@ -0,0 +1,92 @@
+# r2f-arithmetic.R
+# Handlers for arithmetic operators: +, -, *, /, ^, %%, %/%
+
+# --- Handlers ---
+
+r2f_handlers[["+"]] <- function(args, scope, ...) {
+  # Support both binary and unary plus
+  if (length(args) == 1L) {
+    x <- r2f(args[[1L]], scope, ...)
+    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
+    Fortran(glue("({left} + {right})"), conform(left@value, right@value))
+  }
+}
+
+r2f_handlers[["-"]] <- function(args, scope, ...) {
+  # Support both binary and unary minus
+  if (length(args) == 1L) {
+    x <- r2f(args[[1L]], scope, ...)
+    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
+    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
+  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
+  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))
+}
+
+
+# ---- remainder (%%) and integer division (%/%) ----
+#
+# R semantics:
+#   x %%  y  ==  r   where  r has the sign of y  (divisor)
+#   x %/% y  ==  q   where  q = floor(x / y)
+# and  x == r + y * q  (within rounding error)
+#
+# Fortran intrinsics:
+#   - MODULO(a,p)   : remainder with sign(p)
+#   - FLOOR(x)      : greatest integer <= x      (real)
+#   - AINT(x)       : truncation toward 0       (real)
+
+r2f_handlers[["%%"]] <- function(args, scope, ...) {
+  .[left, right] <- lapply(args, r2f, scope, ...)
+  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, ...)
+  out_val <- conform(left@value, right@value)
+
+  expr <- switch(
+    out_val@mode,
+    integer = glue("int(floor(real({left}) / real({right})))"),
+    double = glue("floor({left} / {right})"),
+    stop("%/% only implemented for numeric types")
+  )
+
+  Fortran(expr, out_val)
+}

R/r2f-arithmetic.R

@@ -0,0 +1,9 @@
+# r2f-coercions.R
+# Handlers for type coercions: as.double
+
+# --- Handlers ---
+
+r2f_handlers[["as.double"]] <- function(args, scope = NULL, ...) {
+  stopifnot(length(args) == 1L)
+  maybe_cast_double(r2f(args[[1]], scope, ...))
+}

R/r2f-coercions.R

@@ -0,0 +1,12 @@
+# r2f-conditionals.R
+# Handlers for vectorized conditionals: ifelse
+
+# --- Handlers ---
+
+r2f_handlers[["ifelse"]] <- function(args, scope, ...) {
+  .[mask, tsource, fsource] <- lapply(args, r2f, scope, ...)
+  # (tsource, fsource, mask)
+  mode <- tsource@value@mode
+  dims <- conform(mask@value, tsource@value, fsource@value)@dims
+  Fortran(glue("merge({tsource}, {fsource}, {mask})"), Variable(mode, dims))
+}

R/r2f-conditionals.R

@@ -0,0 +1,97 @@
+# r2f-constructors.R
+# Handlers for value constructors: c, logical, integer, double, numeric,
+# character, raw, matrix, array
+
+# --- Handlers ---
+
+r2f_handlers[["c"]] <- function(args, scope = NULL, ...) {
+  ff <- lapply(args, r2f, scope, ...)
+  s <- glue("[ {str_flatten_commas(ff)} ]")
+  lens <- lapply(ff[order(map_int(ff, \(f) f@value@rank))], function(e) {
+    rank <- e@value@rank
+    if (rank == 0) {
+      1L
+    } else if (rank == 1) {
+      e@value@dims[[1]]
+    } else {
+      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)) {
+        NA
+      } else if (is_wholenumber(l1) && is_wholenumber(l2)) {
+        l1 + l2
+      } else {
+        call("+", l1, l2)
+      }
+    },
+    lens
+  )
+  Fortran(s, Variable(mode, list(len)))
+}
+
+
+register_r2f_handler(
+  "logical",
+  function(args, scope, ...) {
+    Fortran(".false.", Variable(mode = "logical", dims = r2dims(args, scope)))
+  },
+  match_fun = FALSE
+)
+
+register_r2f_handler(
+  "integer",
+  function(args, scope, ...) {
+    Fortran("0", Variable(mode = "integer", dims = r2dims(args, scope)))
+  },
+  match_fun = FALSE
+)
+
+register_r2f_handler(
+  c("double", "numeric"),
+  function(args, scope, ...) {
+    Fortran("0", Variable(mode = "double", dims = r2dims(args, scope)))
+  },
+  match_fun = FALSE
+)
+
+
+r2f_handlers[["character"]] <- r2f_handlers[["raw"]] <-
+  .r2f_handler_not_implemented_yet
+
+
+r2f_handlers[["matrix"]] <- function(args, scope = NULL, ...) {
+  args$data %||% stop("matrix(data=) must be provided, cannot be NA")
+  out <- r2f(args$data, scope, ...)
+  out@value <- Variable(
+    mode = out@value@mode,
+    dims = r2dims(list(args$nrow, args$ncol), scope)
+  )
+  out
+
+  # TODO: reshape() if !passes_as_scalar(out)
+}
+
+r2f_handlers[["array"]] <- function(args, scope = NULL, ...) {
+  args$data %||% stop("array(data=) must be provided, cannot be NA")
+  if (is.null(args$dim)) {
+    stop("array(dim=) must be provided, cannot be NA")
+  }
+  if (!is.null(args$dimnames)) {
+    stop("array(dimnames=) not supported")
+  }
+
+  out <- r2f(args$data, scope, ...)
+  if (!passes_as_scalar(out@value)) {
+    stop("array(data=) must be a scalar for now")
+  }
+
+  out@value <- Variable(
+    mode = out@value@mode,
+    dims = r2dims(args$dim, scope)
+  )
+  out
+}