Add float-to-int conversions (as.integer/trunc) and fix floor/ceiling typing

NEWS.md

@@ -1,5 +1,8 @@
 # quickr (development version)
 
+- Added support for `as.integer()` coercion from `double`, `logical`, and
+  `integer` values (with `double` truncating towards 0).
+
 - Added initial matrix/linear algebra handler support from base R, using the
   same BLAS/LAPACK as R: `%*%`, `t()`, `crossprod()`, `tcrossprod()`,
   `outer()` (with `FUN="*"`), `%o%`, `forwardsolve()`, `backsolve()`, `diag()`,

R/r2f-coercions.R

@@ -1,9 +1,28 @@
 # r2f-coercions.R
-# Handlers for type coercions: as.double
+# Handlers for type coercions: as.double, as.integer
 
 # --- Handlers ---
 
 r2f_handlers[["as.double"]] <- function(args, scope = NULL, ...) {
   stopifnot(length(args) == 1L)
   maybe_cast_double(r2f(args[[1]], scope, ...))
 }
+
+r2f_handlers[["as.integer"]] <- function(args, scope = NULL, ...) {
+  stopifnot(length(args) == 1L)
+  arg <- r2f(args[[1L]], scope, ...)
+
+  # R semantics:
+  # - numeric -> integer truncates toward 0
+  # - logical -> integer is 0/1
+  # - result is an integer vector
+  out_val <- Variable("integer", arg@value@dims)
+
+  switch(
+    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),
+    stop("as.integer() only implemented for logical, integer, and double")
+  )
+}

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, log10, abs, Re, Im, Mod, Arg, Conj
+# log, floor, ceiling, trunc, log10, abs, Re, Im, Mod, Arg, Conj
 
 # --- Local Helpers ---
 
@@ -35,14 +35,67 @@ register_unary_intrinsic(
     "atan",
     "sqrt",
     "exp",
-    "log",
-    "floor",
-    "ceiling"
+    "log"
   ),
   mode_fun = function(arg) arg@value@mode,
   expr_fun = function(arg, intrinsic) glue("{intrinsic}({arg})")
 )
 
+r2f_handlers[["floor"]] <- function(args, scope, ...) {
+  stopifnot(length(args) == 1L)
+  arg <- r2f(args[[1L]], scope, ...)
+
+  arg <- maybe_cast_double(arg)
+  if (!identical(arg@value@mode, "double")) {
+    stop("floor() only implemented for logical, integer, and double")
+  }
+  out_val <- Variable("double", arg@value@dims)
+
+  # Avoid Fortran FLOOR() overflow (it returns an integer) by staying in the
+  # real domain:
+  # - aint(x) truncates toward 0 (real result)
+  # - adjust by -1 where trunc differs from floor (negative non-integers)
+  aint <- glue("aint({arg})")
+  Fortran(
+    glue("({aint} - merge(1.0_c_double, 0.0_c_double, ({arg} < {aint})))"),
+    out_val
+  )
+}
+
+r2f_handlers[["ceiling"]] <- function(args, scope, ...) {
+  stopifnot(length(args) == 1L)
+  arg <- r2f(args[[1L]], scope, ...)
+
+  arg <- maybe_cast_double(arg)
+  if (!identical(arg@value@mode, "double")) {
+    stop("ceiling() only implemented for logical, integer, and double")
+  }
+  out_val <- Variable("double", arg@value@dims)
+
+  # As with floor(): avoid integer overflow by implementing in real arithmetic.
+  aint <- glue("aint({arg})")
+  Fortran(
+    glue("({aint} + merge(1.0_c_double, 0.0_c_double, ({arg} > {aint})))"),
+    out_val
+  )
+}
+
+r2f_handlers[["trunc"]] <- function(args, scope, ...) {
+  stopifnot(length(args) == 1L)
+  arg <- r2f(args[[1L]], scope, ...)
+
+  # R's trunc() always returns a double and truncates toward 0.
+  # - For double input we can use Fortran AINT(), which returns a real.
+  # - For integer/logical inputs, a cast-to-double is sufficient.
+  if (arg@value@mode == "double") {
+    return(Fortran(glue("aint({arg})"), Variable("double", arg@value@dims)))
+  }
+  if (arg@value@mode %in% c("integer", "logical")) {
+    return(maybe_cast_double(arg))
+  }
+  stop("trunc() only implemented for logical, integer, and double")
+}
+
 r2f_handlers[["log10"]] <- function(args, scope, ...) {
   stopifnot(length(args) == 1L)
   arg <- r2f(args[[1]], scope, ...)

tests/testthat/_snaps/float-to-int.md

@@ -0,0 +1,189 @@
+# as.integer(double) truncates toward zero
+
+    Code
+      fn
+    Output
+      function(x) {
+          declare(type(x = double(NA)))
+          out <- as.integer(x)
+          out
+        }
+      <environment: 0x0>
+    Code
+      cat(fsub)
+    Output
+      subroutine fn(x, out, x__len_) bind(c)
+        use iso_c_binding, only: c_double, c_int, 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_)
+        integer(c_int), intent(out) :: out(x__len_)
+        ! manifest end
+
+
+        out = int(x, kind=c_int)
+      end subroutine
+    Code
+      cat(cwrapper)
+    Output
+      #define R_NO_REMAP
+      #include <R.h>
+      #include <Rinternals.h>
+
+
+      extern void fn(
+        const double* const x__, 
+        int* 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(INTSXP, out__len_));
+        int* out__ = INTEGER(out);
+
+        fn(x__, out__, x__len_);
+
+        UNPROTECT(1);
+        return out;
+      }
+
+# trunc() returns double and truncates toward zero
+
+    Code
+      fn
+    Output
+      function(x) {
+          declare(type(x = double(NA)))
+          out <- trunc(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 = aint(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__, 
+        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 = integer(NA)))
+          out <- trunc(x)
+          out
+        }
+      <environment: 0x0>
+    Code
+      cat(fsub)
+    Output
+      subroutine fn(x, out, x__len_) bind(c)
+        use iso_c_binding, only: c_double, c_int, c_ptrdiff_t
+        implicit none
+
+        ! manifest start
+        ! sizes
+        integer(c_ptrdiff_t), intent(in), value :: x__len_
+
+        ! args
+        integer(c_int), intent(in) :: x(x__len_)
+        real(c_double), intent(out) :: out(x__len_)
+        ! manifest end
+
+
+        out = real(x, kind=c_double)
+      end subroutine
+    Code
+      cat(cwrapper)
+    Output
+      #define R_NO_REMAP
+      #include <R.h>
+      #include <Rinternals.h>
+
+
+      extern void fn(
+        const int* 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) != INTSXP) {
+          Rf_error("typeof(x) must be 'integer', not '%s'", Rf_type2char(TYPEOF(x)));
+        }
+        const int* const x__ = INTEGER(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;
+      }
+

tests/testthat/_snaps/unary-intrinsics.md

@@ -667,7 +667,7 @@
         ! manifest end
 
 
-        out = floor(x)
+        out = (aint(x) - merge(1.0_c_double, 0.0_c_double, (x < aint(x))))
       end subroutine
     Code
       cat(cwrapper)
@@ -731,7 +731,7 @@
         ! manifest end
 
 
-        out = ceiling(x)
+        out = (aint(x) + merge(1.0_c_double, 0.0_c_double, (x > aint(x))))
       end subroutine
     Code
       cat(cwrapper)

tests/testthat/test-float-to-int.R

@@ -0,0 +1,39 @@
+# Float-to-int conversion semantics (truncation vs floor/ceiling).
+
+test_that("as.integer(double) truncates toward zero", {
+  fn <- function(x) {
+    declare(type(x = double(NA)))
+    out <- as.integer(x)
+    out
+  }
+
+  expect_translation_snapshots(fn)
+
+  x <- c(-2.9, -2.1, -1.9, -1.1, -0.9, -0.1, 0, 0.1, 0.9, 1.1, 1.9, 2.1)
+  expect_quick_identical(fn, x)
+})
+
+test_that("trunc() returns double and truncates toward zero", {
+  fn_d <- function(x) {
+    declare(type(x = double(NA)))
+    out <- trunc(x)
+    out
+  }
+
+  expect_translation_snapshots(fn_d)
+
+  x <- c(-2.9, -2.1, -1.9, -1.1, -0.9, -0.1, 0, 0.1, 0.9, 1.1, 1.9, 2.1)
+  expect_quick_equal(fn_d, x)
+
+  fn_i <- function(x) {
+    declare(type(x = integer(NA)))
+    out <- trunc(x)
+    out
+  }
+
+  expect_translation_snapshots(fn_i)
+
+  xi <- as.integer(c(-3, -1, 0, 2, 5))
+  expect_quick_equal(fn_i, xi)
+  expect_identical(typeof(fn_i(xi)), "double")
+})