Add tanh() intrinsic and rev() handler

NEWS.md

@@ -36,6 +36,10 @@
 - Improved `for (... in <iterable>)` lowering, including value iteration
   (`for (v in x)`) and support for `rev()` wrappers on supported iterables.
 
+- Added support for `tanh()` as a unary intrinsic and `rev()` for reversing
+  rank-0/1 vectors (including bind(c) logicals, preserving `NA` storage where
+  possible).
+
 - Added nested compilation scopes with local declaration emission, enabling
   block-scoped temporaries (Fortran 2008 `block ... end block`) and local
   closures (lowered to internal procedures under `contains`), including `sapply()`

R/r2f-aab-core.R

@@ -249,8 +249,12 @@ lang2fortran <- r2f <- function(
         # logicals passed via the bind(c) interface are stored as integer(0/1)
         # and must be "booleanized" for Fortran logical operations.
         s <- paste0("(", s, "/=0)")
+        out <- Fortran(s, value = if (inherits(val, Variable)) val else NULL)
+        attr(out, "logical_booleanized") <- TRUE
+        out
+      } else {
+        Fortran(s, value = if (inherits(val, Variable)) val else NULL)
       }
-      Fortran(s, value = if (inherits(val, Variable)) val else NULL)
     },
 
     ## handling 'object' and 'closure' here are both bad ideas,

R/r2f-assign.R

@@ -179,6 +179,17 @@ register_r2f_handler(
         src <- value@value
         var <- Variable(mode = src@mode, dims = src@dims)
       }
+      if (
+        inherits(value, Fortran) &&
+          inherits(value@value, Variable) &&
+          identical(value@value@mode, "logical") &&
+          logical_as_int(value@value) &&
+          !isTRUE(attr(value, "logical_booleanized", exact = TRUE))
+      ) {
+        # Keep bind(c) logicals as integer storage when the RHS is an
+        # integer-backed expression (e.g. rev(x) for external logicals).
+        var@logical_as_int <- TRUE
+      }
       if (is.null(fortran_name)) {
         fortran_name <- assignment_fortran_name(name, scope)
       }

R/r2f-coercions.R

@@ -22,7 +22,16 @@ r2f_handlers[["as.integer"]] <- function(args, scope = NULL, ...) {
     arg@value@mode,
     integer = arg,
     double = Fortran(glue("int({arg}, kind=c_int)"), out_val),
-    logical = Fortran(glue("merge(1_c_int, 0_c_int, {arg})"), out_val),
+    logical = {
+      # External logicals are integer-backed (0/1/NA) under bind(c); if the
+      # expression preserves that storage (e.g. rev(m)), return it directly.
+      if (logical_as_int(arg@value)) {
+        src <- arg@value@name %||% as.character(arg)
+        return(Fortran(src, out_val))
+      }
+      arg <- booleanize_logical_as_int(arg)
+      Fortran(glue("merge(1_c_int, 0_c_int, {arg})"), out_val)
+    },
     stop("as.integer() only implemented for logical, integer, and double")
   )
 }

R/r2f-conditionals.R

@@ -5,6 +5,7 @@
 
 r2f_handlers[["ifelse"]] <- function(args, scope, ...) {
   .[mask, tsource, fsource] <- lapply(args, r2f, scope, ...)
+  mask <- booleanize_logical_as_int(mask)
   # (tsource, fsource, mask)
   mode <- tsource@value@mode
   dims <- conform(mask@value, tsource@value, fsource@value)@dims

R/r2f-logical.R

@@ -55,6 +55,7 @@ r2f_handlers[["!"]] <- function(args, scope, ...) {
   if (x@value@mode != "logical") {
     stop("'!' expects a logical value; numeric coercions not yet supported")
   }
+  x <- booleanize_logical_as_int(x)
   Fortran(glue("(.not. {x})"), Variable("logical", x@value@dims))
 }
 
@@ -97,6 +98,8 @@ register_r2f_handler(
       a
     })
     .[left, right] <- args
+    left <- booleanize_logical_as_int(left)
+    right <- booleanize_logical_as_int(right)
 
     operator <- switch(
       last(list(...)$calls),

R/r2f-math.R

@@ -1,6 +1,6 @@
 # r2f-math.R
 # Handlers for math intrinsics: sin, cos, tan, asin, acos, atan, sqrt, exp,
-# log, floor, ceiling, trunc, log10, abs, Re, Im, Mod, Arg, Conj
+# log, tanh, floor, ceiling, trunc, log10, abs, Re, Im, Mod, Arg, Conj
 
 # --- Local Helpers ---
 
@@ -30,6 +30,7 @@ register_unary_intrinsic(
     "sin",
     "cos",
     "tan",
+    "tanh",
     "asin",
     "acos",
     "atan",

R/r2f-operators-helpers.R

@@ -1,6 +1,30 @@
 # r2f-operators-helpers.R
 # Generic helpers for binary operators and type conformance.
 
+# Convert a logical value backed by bind(c) integer storage (0/1/NA) to a
+# Fortran LOGICAL expression. Symbols are typically booleanized during r2f()
+# (see r2f-aab-core.R), but expressions like rev(x) need handling at use sites.
+# Used by: r2f-logical.R, r2f-conditionals.R, r2f-subscript.R, r2f-reductions.R
+booleanize_logical_as_int <- function(x) {
+  stopifnot(inherits(x, Fortran))
+
+  if (
+    is.null(x@value) ||
+      !identical(x@value@mode, "logical") ||
+      !logical_as_int(x@value)
+  ) {
+    return(x)
+  }
+
+  if (isTRUE(attr(x, "logical_booleanized", exact = TRUE))) {
+    return(x)
+  }
+
+  out <- Fortran(glue("({x} /= 0)"), Variable("logical", x@value@dims))
+  attr(out, "logical_booleanized") <- TRUE
+  out
+}
+
 # Cast a value to double if it's logical or integer.
 # Used by: r2f-arithmetic.R
 maybe_cast_double <- function(x) {

R/r2f-reductions-helpers.R

@@ -9,6 +9,7 @@ create_mask_hoist <- function() {
 
   try_set <- function(mask) {
     stopifnot(inherits(mask, Fortran), mask@value@mode == "logical")
+    mask <- booleanize_logical_as_int(mask)
     # each hoist can only accept one mask.
     if (is.null(.hoisted_mask)) {
       .hoisted_mask <<- mask

R/r2f-reductions.R

@@ -91,13 +91,18 @@ r2f_handlers[["which.max"]] <- r2f_handlers[["which.min"]] <-
 
       has_var_name <- inherits(x@value, Variable) && !is.null(x@value@name)
       use_lgl_storage <- has_var_name && !logical_as_int(x@value)
+      int_backed_expr <-
+        logical_as_int(x@value) &&
+        !isTRUE(attr(x, "logical_booleanized", exact = TRUE))
 
       # Prefer searching the underlying integer storage directly when available
       # (external logical arrays are passed as integer(0/1)). If the input is an
       # actual Fortran logical array, search it directly to avoid unnecessary
       # casting.
       haystack <- if (has_var_name) {
         x@value@name
+      } else if (int_backed_expr) {
+        as.character(x)
       } else {
         glue("merge(1_c_int, 0_c_int, {x})")
       }

R/r2f-rev.R

@@ -0,0 +1,61 @@
+# r2f-rev.R
+# Handler for rev()
+
+r2f_handlers[["rev"]] <- function(args, scope, ..., hoist = NULL) {
+  stopifnot(length(args) == 1L)
+
+  x <- r2f(args[[1L]], scope, ..., hoist = hoist)
+  if (is.null(x@value)) {
+    stop("rev() expects a typed value", call. = FALSE)
+  }
+
+  # Scalars (incl. length-1 vectors that are lowered as scalars) reverse to self.
+  if (passes_as_scalar(x@value)) {
+    # For bind(c) logical scalars, the default symbol lowering booleanizes the
+    # argument as `(m/=0)`, which would both lose NA_LOGICAL and force a
+    # nonstandard logical->integer assignment into the integer-backed return.
+    # Preserve the underlying integer storage when available.
+    if (identical(x@value@mode, "logical") && logical_as_int(x@value)) {
+      base_name <- x@value@name
+      if (!is.null(base_name)) {
+        return(Fortran(base_name, x@value))
+      }
+    }
+    return(x)
+  }
+
+  if (x@value@rank != 1L) {
+    stop("rev() only supports rank 0-1 inputs", call. = FALSE)
+  }
+
+  # Fortran array sections require an array designator; hoist array expressions.
+  if (is.null(x@value@name)) {
+    tmp <- hoist$declare_tmp(
+      mode = x@value@mode,
+      dims = x@value@dims,
+      logical_as_int = logical_as_int(x@value)
+    )
+    hoist$emit(glue("{tmp@name} = {x}"))
+    x <- Fortran(tmp@name, tmp)
+  }
+
+  base_name <- x@value@name %||%
+    stop("missing array name for rev()", call. = FALSE)
+
+  # External logical args are stored as integer(0/1) and symbol-lowered as `(x/=0)`.
+  # Reverse the underlying storage (including NA_LOGICAL sentinel values).
+  #
+  # Note: this returns integer storage (0/1/NA) for bind(c) logicals, which
+  # preserves NA when the reversed value is returned back to R.
+  if (identical(x@value@mode, "logical") && logical_as_int(x@value)) {
+    out_val <- Variable("logical", x@value@dims)
+    out_val@logical_as_int <- TRUE
+    return(Fortran(
+      glue("{base_name}(size({base_name}):1:-1)"),
+      out_val
+    ))
+  }
+
+  out_val <- Variable(x@value@mode, x@value@dims)
+  Fortran(glue("{base_name}(size({base_name}):1:-1)"), out_val)
+}

R/r2f-subscript.R

@@ -47,6 +47,7 @@ r2f_handlers[["["]] <- function(
       idxs[[1]]@value@rank == var@value@rank
   ) {
     mask <- idxs[[1]]
+    mask <- booleanize_logical_as_int(mask)
     if (hoist_mask(mask)) {
       return(var)
     }

tests/testthat/_snaps/unary-intrinsics.md

@@ -165,6 +165,70 @@
       #include <Rinternals.h>
 
 
+      extern void fn(
+        const double* const x__, 
+        double* const out__, 
+        const R_xlen_t x__len_);
+
+      SEXP fn_(SEXP _args) {
+        // x
+        _args = CDR(_args);
+        SEXP x = CAR(_args);
+        if (TYPEOF(x) != REALSXP) {
+          Rf_error("typeof(x) must be 'double', not '%s'", Rf_type2char(TYPEOF(x)));
+        }
+        const double* const x__ = REAL(x);
+        const R_xlen_t x__len_ = Rf_xlength(x);
+
+        const R_xlen_t out__len_ = x__len_;
+        SEXP out = PROTECT(Rf_allocVector(REALSXP, out__len_));
+        double* out__ = REAL(out);
+
+        fn(x__, out__, x__len_);
+
+        UNPROTECT(1);
+        return out;
+      }
+
+---
+
+    Code
+      fn
+    Output
+      function (x) 
+      {
+          declare(type(x = double(NA)))
+          out <- tanh(x)
+          out
+      }
+      <environment: 0x0>
+    Code
+      cat(fsub)
+    Output
+      subroutine fn(x, out, x__len_) bind(c)
+        use iso_c_binding, only: c_double, c_ptrdiff_t
+        implicit none
+
+        ! manifest start
+        ! sizes
+        integer(c_ptrdiff_t), intent(in), value :: x__len_
+
+        ! args
+        real(c_double), intent(in) :: x(x__len_)
+        real(c_double), intent(out) :: out(x__len_)
+        ! manifest end
+
+
+        out = tanh(x)
+      end subroutine
+    Code
+      cat(cwrapper)
+    Output
+      #define R_NO_REMAP
+      #include <R.h>
+      #include <Rinternals.h>
+
+
       extern void fn(
         const double* const x__, 
         double* const out__, 
@@ -1061,6 +1125,70 @@
       #include <Rinternals.h>
 
 
+      extern void fn(
+        const Rcomplex* const z__, 
+        Rcomplex* const out__, 
+        const R_xlen_t z__len_);
+
+      SEXP fn_(SEXP _args) {
+        // z
+        _args = CDR(_args);
+        SEXP z = CAR(_args);
+        if (TYPEOF(z) != CPLXSXP) {
+          Rf_error("typeof(z) must be 'complex', not '%s'", Rf_type2char(TYPEOF(z)));
+        }
+        const Rcomplex* const z__ = COMPLEX(z);
+        const R_xlen_t z__len_ = Rf_xlength(z);
+
+        const R_xlen_t out__len_ = z__len_;
+        SEXP out = PROTECT(Rf_allocVector(CPLXSXP, out__len_));
+        Rcomplex* out__ = COMPLEX(out);
+
+        fn(z__, out__, z__len_);
+
+        UNPROTECT(1);
+        return out;
+      }
+
+---
+
+    Code
+      fn
+    Output
+      function (z) 
+      {
+          declare(type(z = complex(NA)))
+          out <- tanh(z)
+          out
+      }
+      <environment: 0x0>
+    Code
+      cat(fsub)
+    Output
+      subroutine fn(z, out, z__len_) bind(c)
+        use iso_c_binding, only: c_double_complex, c_ptrdiff_t
+        implicit none
+
+        ! manifest start
+        ! sizes
+        integer(c_ptrdiff_t), intent(in), value :: z__len_
+
+        ! args
+        complex(c_double_complex), intent(in) :: z(z__len_)
+        complex(c_double_complex), intent(out) :: out(z__len_)
+        ! manifest end
+
+
+        out = tanh(z)
+      end subroutine
+    Code
+      cat(cwrapper)
+    Output
+      #define R_NO_REMAP
+      #include <R.h>
+      #include <Rinternals.h>
+
+
       extern void fn(
         const Rcomplex* const z__, 
         Rcomplex* const out__, 

tests/testthat/test-r2f-r-attr.R

@@ -0,0 +1,16 @@
+test_that("r2f() attaches `r` metadata for bind(c) logical symbols", {
+  # Regression test: r2f() must attach attr(,"r") even for the symbol-lowering
+  # path used by bind(c) logical arguments. Missing `r` can break downstream
+  # compilation logic that relies on var@r (e.g. size inference).
+  fn <- function(m) {
+    declare(type(m = logical(NA)))
+    a <- m
+    a
+  }
+
+  fsub <- quickr:::r2f(fn)
+  a_var <- get0("a", fsub@scope)
+  expect_true(inherits(a_var, Variable))
+  expect_identical(a_var@r, quote(m))
+})
+