Add tanh() intrinsic and rev() handler

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-rev.R

@@ -0,0 +1,43 @@
+# 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)) {
+    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)
+    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 then booleanize the resulting section.
+  if (identical(x@value@mode, "logical") && logical_as_int(x@value)) {
+    out_val <- Variable("logical", x@value@dims)
+    return(Fortran(
+      glue("({base_name}(size({base_name}):1:-1) /= 0)"),
+      out_val
+    ))
+  }
+
+  out_val <- Variable(x@value@mode, x@value@dims)
+  Fortran(glue("{base_name}(size({base_name}):1:-1)"), out_val)
+}

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-rev.R

@@ -0,0 +1,40 @@
+test_that("rev() reverses vectors", {
+  fn_dbl <- function(x) {
+    declare(type(x = double(NA)))
+    rev(x)
+  }
+  expect_quick_identical(
+    fn_dbl,
+    list(as.double(1:5)),
+    list(as.double(c(2, -1, 3, 0)))
+  )
+
+  fn_int <- function(x) {
+    declare(type(x = integer(NA)))
+    rev(x)
+  }
+  expect_quick_identical(fn_int, list(as.integer(c(1, 0, -3, 2))))
+
+  # Logical arguments are passed via the bind(c) interface as integer storage.
+  fn_lgl <- function(x) {
+    declare(type(x = logical(NA)))
+    rev(x)
+  }
+  expect_quick_identical(fn_lgl, list(c(TRUE, FALSE, TRUE, FALSE)))
+})
+
+test_that("rev() hoists array expressions", {
+  fn <- function(x) {
+    declare(type(x = double(NA)))
+    rev(x + 1)
+  }
+  expect_quick_identical(fn, list(as.double(1:6)))
+})
+
+test_that("rev() is a no-op for scalars", {
+  fn <- function(x) {
+    declare(type(x = double(1)))
+    rev(x)
+  }
+  expect_quick_identical(fn, list(as.double(3)))
+})

tests/testthat/test-unary-intrinsics.R

@@ -5,6 +5,7 @@ test_that("double unary intrinsics", {
     "sin",
     "cos",
     "tan",
+    "tanh",
     "asin",
     "acos",
     "atan",
@@ -72,6 +73,7 @@ test_that("complex unary intrinsics", {
     "sin",
     "cos",
     "tan",
+    "tanh",
     "asin",
     "acos",
     "atan",