Emit Re() with an explicit c_double kind

Re() lowered to kind-less real(arg). For a complex argument that is
correct (F2018: the result takes the argument's kind), but the handler
accepts any mode, and for a double or integer argument kind-less
real() is single precision — so Re(0.1) returned 0.100000001490116,
silently rounded through a float while declared real(c_double). Emit
real(arg, kind=c_double), which is exact for double/integer arguments
and a no-op change of meaning for complex ones.

Author: mns-nordicals

R/r2f-math.R

@@ -131,7 +131,9 @@ r2f_handlers[["abs"]] <- function(args, scope, ...) {
 register_unary_intrinsic(
   "Re",
   mode_fun = function(arg) "double",
-  expr_fun = function(arg, intrinsic) glue("real({arg})")
+  # kind-less real() of an integer or double argument is single precision;
+  # kind=c_double is a no-op change of meaning for complex arguments (F2018).
+  expr_fun = function(arg, intrinsic) glue("real({arg}, kind=c_double)")
 )
 
 register_unary_intrinsic(

tests/testthat/_snaps/unary-intrinsics.md

@@ -1691,7 +1691,7 @@
         ! manifest end
       
       
-        out = real(z)
+        out = real(z, kind=c_double)
       end subroutine
     Code
       cat(cwrapper)
@@ -1982,6 +1982,69 @@
         return out;
       }
 
+# Re() on a double argument keeps double precision
+
+    Code
+      fn
+    Output
+      function(x) {
+          declare(type(x = double(n)))
+          out <- Re(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 = 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 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;
+      }
+
 # logical not local used as ifelse mask compiles and runs
 
     Code

tests/testthat/test-unary-intrinsics.R

@@ -106,6 +106,21 @@ test_that("complex unary intrinsics", {
 })
 
 
+test_that("Re() on a double argument keeps double precision", {
+  fn <- function(x) {
+    declare(type(x = double(n)))
+    out <- Re(x)
+    out
+  }
+
+  # locks real(x, kind=c_double): kind-less real() of a double argument
+  # is single precision, so Re() silently rounded its input
+  expect_translation_snapshots(fn)
+
+  expect_quick_identical(fn, list(c(0.1, 1 / 3, -2.5)))
+})
+
+
 test_that("unary logical 'not'-operator on vector", {
   fn <- function(x) {
     declare(type(x = integer(n)))