test: add division casting coverage

tests/testthat/_snaps/div-cast.md

@@ -0,0 +1,387 @@
+# division casts integers
+
+    Code
+      fn
+    Output
+      function(a, b) {
+          declare(type(a = integer(n)), type(b = integer(n)))
+          a / b
+        }
+      <environment: 0x0>
+    Code
+      cat(fsub)
+    Output
+      subroutine fn(a, b, out_, a__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 :: a__len_
+
+        ! args
+        integer(c_int), intent(in) :: a(a__len_)
+        integer(c_int), intent(in) :: b(a__len_)
+        real(c_double), intent(out) :: out_(a__len_)
+        ! manifest end
+
+
+        out_ = (real(a, kind=c_double) / real(b, 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 a__, 
+        const int* const b__, 
+        double* const out___, 
+        const R_xlen_t a__len_);
+
+      SEXP fn_(SEXP _args) {
+        // a
+        _args = CDR(_args);
+        SEXP a = CAR(_args);
+        if (TYPEOF(a) != INTSXP) {
+          Rf_error("typeof(a) must be 'integer', not '%s'", R_typeToChar(a));
+        }
+        const int* const a__ = INTEGER(a);
+        const R_xlen_t a__len_ = Rf_xlength(a);
+
+        // b
+        _args = CDR(_args);
+        SEXP b = CAR(_args);
+        if (TYPEOF(b) != INTSXP) {
+          Rf_error("typeof(b) must be 'integer', not '%s'", R_typeToChar(b));
+        }
+        const int* const b__ = INTEGER(b);
+        const R_xlen_t b__len_ = Rf_xlength(b);
+
+        if (a__len_ != b__len_)
+          Rf_error("length(b) must equal length(a),"
+                   " but are %0.f and %0.f",
+                    (double)b__len_, (double)a__len_);
+        const R_xlen_t out___len_ = a__len_;
+        SEXP out_ = PROTECT(Rf_allocVector(REALSXP, out___len_));
+        double* out___ = REAL(out_);
+
+        fn(
+          a__,
+          b__,
+          out___,
+          a__len_);
+
+        UNPROTECT(1);
+        return out_;
+      }
+
+# division casts double and integer
+
+    Code
+      fn
+    Output
+      function(a, b) {
+          declare(type(a = double(n)), type(b = integer(n)))
+          a / b
+        }
+      <environment: 0x0>
+    Code
+      cat(fsub)
+    Output
+      subroutine fn(a, b, out_, a__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 :: a__len_
+
+        ! args
+        real(c_double), intent(in) :: a(a__len_)
+        integer(c_int), intent(in) :: b(a__len_)
+        real(c_double), intent(out) :: out_(a__len_)
+        ! manifest end
+
+
+        out_ = (a / real(b, 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 a__, 
+        const int* const b__, 
+        double* const out___, 
+        const R_xlen_t a__len_);
+
+      SEXP fn_(SEXP _args) {
+        // a
+        _args = CDR(_args);
+        SEXP a = CAR(_args);
+        if (TYPEOF(a) != REALSXP) {
+          Rf_error("typeof(a) must be 'double', not '%s'", R_typeToChar(a));
+        }
+        const double* const a__ = REAL(a);
+        const R_xlen_t a__len_ = Rf_xlength(a);
+
+        // b
+        _args = CDR(_args);
+        SEXP b = CAR(_args);
+        if (TYPEOF(b) != INTSXP) {
+          Rf_error("typeof(b) must be 'integer', not '%s'", R_typeToChar(b));
+        }
+        const int* const b__ = INTEGER(b);
+        const R_xlen_t b__len_ = Rf_xlength(b);
+
+        if (a__len_ != b__len_)
+          Rf_error("length(b) must equal length(a),"
+                   " but are %0.f and %0.f",
+                    (double)b__len_, (double)a__len_);
+        const R_xlen_t out___len_ = a__len_;
+        SEXP out_ = PROTECT(Rf_allocVector(REALSXP, out___len_));
+        double* out___ = REAL(out_);
+
+        fn(
+          a__,
+          b__,
+          out___,
+          a__len_);
+
+        UNPROTECT(1);
+        return out_;
+      }
+
+# division casts logical
+
+    Code
+      fn
+    Output
+      function(a, b) {
+          declare(type(a = double(n)), type(b = logical(n)))
+          a / b
+        }
+      <environment: 0x0>
+    Code
+      cat(fsub)
+    Output
+      subroutine fn(a, b, out_, a__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 :: a__len_
+
+        ! args
+        real(c_double), intent(in) :: a(a__len_)
+        integer(c_int), intent(in) :: b(a__len_) ! logical
+        real(c_double), intent(out) :: out_(a__len_)
+        ! manifest end
+
+
+        out_ = (a / merge(1_c_double, 0_c_double, (b/=0)))
+      end subroutine
+    Code
+      cat(cwrapper)
+    Output
+      #define R_NO_REMAP
+      #include <R.h>
+      #include <Rinternals.h>
+
+
+      extern void fn(
+        const double* const a__, 
+        const int* const b__, 
+        double* const out___, 
+        const R_xlen_t a__len_);
+
+      SEXP fn_(SEXP _args) {
+        // a
+        _args = CDR(_args);
+        SEXP a = CAR(_args);
+        if (TYPEOF(a) != REALSXP) {
+          Rf_error("typeof(a) must be 'double', not '%s'", R_typeToChar(a));
+        }
+        const double* const a__ = REAL(a);
+        const R_xlen_t a__len_ = Rf_xlength(a);
+
+        // b
+        _args = CDR(_args);
+        SEXP b = CAR(_args);
+        if (TYPEOF(b) != LGLSXP) {
+          Rf_error("typeof(b) must be 'logical', not '%s'", R_typeToChar(b));
+        }
+        const int* const b__ = LOGICAL(b);
+        const R_xlen_t b__len_ = Rf_xlength(b);
+
+        if (a__len_ != b__len_)
+          Rf_error("length(b) must equal length(a),"
+                   " but are %0.f and %0.f",
+                    (double)b__len_, (double)a__len_);
+        const R_xlen_t out___len_ = a__len_;
+        SEXP out_ = PROTECT(Rf_allocVector(REALSXP, out___len_));
+        double* out___ = REAL(out_);
+
+        fn(
+          a__,
+          b__,
+          out___,
+          a__len_);
+
+        UNPROTECT(1);
+        return out_;
+      }
+
+# division casts complex
+
+    Code
+      fn
+    Output
+      function(a, b) {
+          declare(type(a = complex(n)), type(b = complex(n)))
+          a / b
+        }
+      <environment: 0x0>
+    Code
+      cat(fsub)
+    Output
+      subroutine fn(a, b, out_, a__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 :: a__len_
+
+        ! args
+        complex(c_double_complex), intent(in) :: a(a__len_)
+        complex(c_double_complex), intent(in) :: b(a__len_)
+        complex(c_double_complex), intent(out) :: out_(a__len_)
+        ! manifest end
+
+
+        out_ = (a / b)
+      end subroutine
+    Code
+      cat(cwrapper)
+    Output
+      #define R_NO_REMAP
+      #include <R.h>
+      #include <Rinternals.h>
+
+
+      extern void fn(
+        const Rcomplex* const a__, 
+        const Rcomplex* const b__, 
+        Rcomplex* const out___, 
+        const R_xlen_t a__len_);
+
+      SEXP fn_(SEXP _args) {
+        // a
+        _args = CDR(_args);
+        SEXP a = CAR(_args);
+        if (TYPEOF(a) != CPLXSXP) {
+          Rf_error("typeof(a) must be 'complex', not '%s'", R_typeToChar(a));
+        }
+        const Rcomplex* const a__ = COMPLEX(a);
+        const R_xlen_t a__len_ = Rf_xlength(a);
+
+        // b
+        _args = CDR(_args);
+        SEXP b = CAR(_args);
+        if (TYPEOF(b) != CPLXSXP) {
+          Rf_error("typeof(b) must be 'complex', not '%s'", R_typeToChar(b));
+        }
+        const Rcomplex* const b__ = COMPLEX(b);
+        const R_xlen_t b__len_ = Rf_xlength(b);
+
+        if (a__len_ != b__len_)
+          Rf_error("length(b) must equal length(a),"
+                   " but are %0.f and %0.f",
+                    (double)b__len_, (double)a__len_);
+        const R_xlen_t out___len_ = a__len_;
+        SEXP out_ = PROTECT(Rf_allocVector(CPLXSXP, out___len_));
+        Rcomplex* out___ = COMPLEX(out_);
+
+        fn(
+          a__,
+          b__,
+          out___,
+          a__len_);
+
+        UNPROTECT(1);
+        return out_;
+      }
+
+# division in my_mean maintains double precision
+
+    Code
+      fn
+    Output
+      function(x) {
+          declare(type(x = double(NA)))
+          mu <- sum(x) / length(x)
+          mu
+        }
+      <environment: 0x0>
+    Code
+      cat(fsub)
+    Output
+      subroutine fn(x, mu, 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) :: mu
+        ! manifest end
+
+
+        mu = (sum(x) / real(size(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 mu__, 
+        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'", R_typeToChar(x));
+        }
+        const double* const x__ = REAL(x);
+        const R_xlen_t x__len_ = Rf_xlength(x);
+
+        const R_xlen_t mu__len_ = (1);
+        SEXP mu = PROTECT(Rf_allocVector(REALSXP, mu__len_));
+        double* mu__ = REAL(mu);
+
+        fn(x__, mu__, x__len_);
+
+        UNPROTECT(1);
+        return mu;
+      }
+