Merge pull request t-kalinowski#53 from mns-nordicals/fix/unary-+,-,!

Add unary "+", "-" and "!"

Author: t-kalinowski

NEWS.md

@@ -1,4 +1,5 @@
 # quickr (development version)
+- Added support for `!` and unary `-` and `+` (#49, @mns-nordicals)
 
 - Functions can now return multiple arrays in a `list()`, optionally
   named (#49, @mns-nordicals).

R/r2f.R

@@ -658,13 +658,25 @@ maybe_cast_double <- function(x) {
 }
 
 r2f_handlers[["+"]] <- function(args, scope, ...) {
-  .[left, right] <- lapply(args, r2f, scope, ...)
-  Fortran(glue("({left} + {right})"), conform(left@value, right@value))
+  # Support both binary and unary plus
+  if (length(args) == 1L) {
+    x <- r2f(args[[1L]], scope, ...)
+    Fortran(glue("(+{x})"), x@value)
+  } else {
+    .[left, right] <- lapply(args, r2f, scope, ...)
+    Fortran(glue("({left} + {right})"), conform(left@value, right@value))
+  }
 }
 
 r2f_handlers[["-"]] <- function(args, scope, ...) {
-  .[left, right] <- lapply(args, r2f, scope, ...)
-  Fortran(glue("({left} - {right})"), conform(left@value, right@value))
+  # Support both binary and unary minus
+  if (length(args) == 1L) {
+    x <- r2f(args[[1L]], scope, ...)
+    Fortran(glue("(-{x})"), x@value)
+  } else {
+    .[left, right] <- lapply(args, r2f, scope, ...)
+    Fortran(glue("({left} - {right})"), conform(left@value, right@value))
+  }
 }
 
 r2f_handlers[["*"]] <- function(args, scope = NULL, ...) {
@@ -727,6 +739,16 @@ r2f_handlers[["!="]] <- function(args, scope, ...) {
   Fortran(glue("({left} /= {right})"), var)
 }
 
+# ---- unary logical not ----
+r2f_handlers[["!"]] <- function(args, scope, ...) {
+  stopifnot(length(args) == 1L)
+  x <- r2f(args[[1L]], scope, ...)
+  if (x@value@mode != "logical") {
+    stop("'!' expects a logical value; numeric coercions not yet supported")
+  }
+  Fortran(glue("(.not. {x})"), x@value)
+}
+
 
 # ---- remainder (%%) and integer division (%/%) ----
 #

tests/testthat/test-unary-intrinsics.R

@@ -100,3 +100,47 @@ test_that("complex unary intrinsics", {
     expect_quick_equal(fn, z)
   }
 })
+
+
+test_that("unary logical 'not'-operator on vector", {
+  fn <- function(x) {
+    declare(type(x = integer(n)))
+    lgl <- x > 1L
+    not_lgl <- !lgl
+    not_lgl
+  }
+
+  x1 <- -3:3
+  x2 <- 0:5
+  expect_quick_identical(fn, list(x1), list(x2))
+})
+
+test_that("unary minus and plus for integer and double", {
+  fn_neg_i <- function(x) {
+    declare(type(x = integer(n)))
+    y <- -x
+    y
+  }
+  fn_pos_i <- function(x) {
+    declare(type(x = integer(n)))
+    y <- +x
+    y
+  }
+  xi <- -5:5
+  expect_quick_identical(fn_neg_i, list(xi))
+  expect_quick_identical(fn_pos_i, list(xi))
+
+  fn_neg_d <- function(x) {
+    declare(type(x = double(n)))
+    y <- -x
+    y
+  }
+  fn_pos_d <- function(x) {
+    declare(type(x = double(n)))
+    y <- +x
+    y
+  }
+  xd <- -5:5 + 0.5
+  expect_quick_equal(fn_neg_d, list(xd))
+  expect_quick_equal(fn_pos_d, list(xd))
+})