Skip to content

Commit 87032d6

Browse files
t-kalinowskit-kalinowski
authored
Merge pull request #66 from t-kalinowski/fix/preserve-parens-precedence
Add parentheses-preserving translation and tests
2 parents 2169eeb + c632dd0 commit 87032d6

8 files changed

Lines changed: 434 additions & 13 deletions

File tree

‎R/r2f.R‎

Lines changed: 2 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -247,7 +247,8 @@ r2f_handlers[["Fortran"]] <- function(args, scope = NULL, ...) {
247247
}
248248

249249
r2f_handlers[["("]] <- function(args, scope, ...) {
250-
r2f(args[[1L]], scope, ...)
250+
x <- r2f(args[[1L]], scope, ...)
251+
Fortran(glue("({x})"), x@value)
251252
}
252253

253254
r2f_handlers[["{"]] <- function(args, scope, ..., hoist = NULL) {

‎tests/testthat/_snaps/example-heat_diffusion.md‎

Lines changed: 5 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -105,11 +105,11 @@
105105
temp(:, 1_c_int) = 0.0_c_double
106106
temp(:, ny) = 0.0_c_double
107107
temp_new = temp
108-
do i = 2_c_int, (nx - 1_c_int), sign(1, (nx - 1_c_int)-2_c_int)
109-
do j = 2_c_int, (ny - 1_c_int), sign(1, (ny - 1_c_int)-2_c_int)
110-
temp_new(i, j) = (temp(i, j) + ((k * dt) * ((((temp((i + 1_c_int), j) - (2.0_c_double * temp(i, j))) + temp((i - 1_c_int), j)) / &
111-
(dx ** 2.0_c_double)) + (((temp(i, (j + 1_c_int)) - (2.0_c_double * temp(i, j))) + temp(i, (j - 1_c_int))) / (dy ** &
112-
2.0_c_double)))))
108+
do i = 2_c_int, ((nx - 1_c_int)), sign(1, ((nx - 1_c_int))-2_c_int)
109+
do j = 2_c_int, ((ny - 1_c_int)), sign(1, ((ny - 1_c_int))-2_c_int)
110+
temp_new(i, j) = (temp(i, j) + ((k * dt) * ((((((temp((i + 1_c_int), j) - (2.0_c_double * temp(i, j))) + temp((i - 1_c_int), j))) &
111+
/ (dx ** 2.0_c_double)) + ((((temp(i, (j + 1_c_int)) - (2.0_c_double * temp(i, j))) + temp(i, (j - 1_c_int)))) / (dy ** &
112+
2.0_c_double))))))
113113
end do
114114
end do
115115
temp = temp_new

‎tests/testthat/_snaps/example-roll_mean.md‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -51,7 +51,7 @@
5151
weights = ((weights / sum(weights)) * size(weights))
5252
end if
5353
do i = 1, size(out)
54-
out(i) = (sum((x(i:((i + n) - 1_c_int):sign(1, ((i + n) - 1_c_int)-i)) * weights)) / real(size(weights), kind=c_double))
54+
out(i) = (sum((x(i:(((i + n) - 1_c_int)):sign(1, (((i + n) - 1_c_int))-i)) * weights)) / real(size(weights), kind=c_double))
5555
end do
5656
end subroutine
5757
Code

‎tests/testthat/_snaps/example-viterbi.md‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -119,7 +119,7 @@
119119
end do
120120
path = 0
121121
path(num_steps) = maxloc(trellis(:, num_steps), 1)
122-
do step = (num_steps - 1_c_int), 1_c_int, sign(1, 1_c_int-(num_steps - 1_c_int))
122+
do step = ((num_steps - 1_c_int)), 1_c_int, sign(1, 1_c_int-((num_steps - 1_c_int)))
123123
path(step) = backpointer(path((step + 1_c_int)), (step + 1_c_int))
124124
end do
125125
out = states(path)

‎tests/testthat/_snaps/logical.md‎

Lines changed: 164 additions & 5 deletions
Original file line numberDiff line numberDiff line change
@@ -145,12 +145,12 @@
145145
146146
delta = (a - b)
147147
if ((delta < 0.0_c_double)) then
148-
delta = (-1.0_c_double * delta)
148+
delta = ((-1.0_c_double) * delta)
149149
end if
150150
a_gt_b = (a > b)
151151
b_gt_a = (b > a)
152152
delta_lt_3 = (delta <= 3.0_c_double)
153-
out = a_gt_b .or. b_gt_a .and. delta_lt_3
153+
out = (a_gt_b .or. b_gt_a) .and. delta_lt_3
154154
end subroutine
155155
Code
156156
cat(cwrapper)
@@ -235,7 +235,7 @@
235235
236236
237237
delta = abs((a - b))
238-
out = (a /= b) .and. (delta <= 3.0_c_double)
238+
out = ((a /= b)) .and. ((delta <= 3.0_c_double))
239239
end subroutine
240240
Code
241241
cat(cwrapper)
@@ -311,7 +311,7 @@
311311
! manifest end
312312
313313
314-
out = (a /= b) .and. (abs((a - b)) <= 3.0_c_double)
314+
out = ((a /= b)) .and. (abs((a - b)) <= 3.0_c_double)
315315
end subroutine
316316
Code
317317
cat(cwrapper)
@@ -390,7 +390,7 @@
390390
! manifest end
391391
392392
393-
out = (a /= b) .and. (abs((a - b)) <= 3.0_c_double)
393+
out = ((a /= b)) .and. (abs((a - b)) <= 3.0_c_double)
394394
end subroutine
395395
Code
396396
cat(cwrapper)
@@ -443,3 +443,162 @@
443443
return out;
444444
}
445445

446+
# parentheses preserve logical precedence
447+
448+
Code
449+
fn
450+
Output
451+
function(x, y) {
452+
declare(type(x = integer(1)), type(y = integer(1)))
453+
cond <- (x > 8L || x <= 0L) && (y > 8L || y <= 0L)
454+
cond
455+
}
456+
<environment: 0x0>
457+
Code
458+
cat(fsub)
459+
Output
460+
subroutine fn(x, y, cond) bind(c)
461+
use iso_c_binding, only: c_int
462+
implicit none
463+
464+
! manifest start
465+
! args
466+
integer(c_int), intent(in) :: x
467+
integer(c_int), intent(in) :: y
468+
integer(c_int), intent(out) :: cond ! logical
469+
! manifest end
470+
471+
472+
cond = ((x > 8_c_int) .or. (x <= 0_c_int)) .and. ((y > 8_c_int) .or. (y <= 0_c_int))
473+
end subroutine
474+
Code
475+
cat(cwrapper)
476+
Output
477+
#define R_NO_REMAP
478+
#include <R.h>
479+
#include <Rinternals.h>
480+
481+
482+
extern void fn(
483+
const int* const x__,
484+
const int* const y__,
485+
int* const cond__);
486+
487+
SEXP fn_(SEXP _args) {
488+
// x
489+
_args = CDR(_args);
490+
SEXP x = CAR(_args);
491+
if (TYPEOF(x) != INTSXP) {
492+
Rf_error("typeof(x) must be 'integer', not '%s'", Rf_type2char(TYPEOF(x)));
493+
}
494+
const int* const x__ = INTEGER(x);
495+
const R_xlen_t x__len_ = Rf_xlength(x);
496+
497+
// y
498+
_args = CDR(_args);
499+
SEXP y = CAR(_args);
500+
if (TYPEOF(y) != INTSXP) {
501+
Rf_error("typeof(y) must be 'integer', not '%s'", Rf_type2char(TYPEOF(y)));
502+
}
503+
const int* const y__ = INTEGER(y);
504+
const R_xlen_t y__len_ = Rf_xlength(y);
505+
506+
if (x__len_ != 1)
507+
Rf_error("length(x) must be 1, not %0.f",
508+
(double)x__len_);
509+
if (y__len_ != 1)
510+
Rf_error("length(y) must be 1, not %0.f",
511+
(double)y__len_);
512+
const R_xlen_t cond__len_ = (1);
513+
SEXP cond = PROTECT(Rf_allocVector(LGLSXP, cond__len_));
514+
int* cond__ = LOGICAL(cond);
515+
516+
fn(x__, y__, cond__);
517+
518+
UNPROTECT(1);
519+
return cond;
520+
}
521+
522+
---
523+
524+
Code
525+
fn
526+
Output
527+
function(x, y) {
528+
declare(type(x = integer(1)), type(y = integer(1)))
529+
cond_x <- x > 8L || x <= 0L
530+
cond_y <- y > 8L || y <= 0L
531+
cond_x && cond_y
532+
}
533+
<environment: 0x0>
534+
Code
535+
cat(fsub)
536+
Output
537+
subroutine fn(x, y, out_) bind(c)
538+
use iso_c_binding, only: c_int
539+
implicit none
540+
541+
! manifest start
542+
! args
543+
integer(c_int), intent(in) :: x
544+
integer(c_int), intent(in) :: y
545+
integer(c_int), intent(out) :: out_ ! logical
546+
547+
! locals
548+
logical :: cond_x ! logical
549+
logical :: cond_y ! logical
550+
! manifest end
551+
552+
553+
cond_x = (x > 8_c_int) .or. (x <= 0_c_int)
554+
cond_y = (y > 8_c_int) .or. (y <= 0_c_int)
555+
out_ = cond_x .and. cond_y
556+
end subroutine
557+
Code
558+
cat(cwrapper)
559+
Output
560+
#define R_NO_REMAP
561+
#include <R.h>
562+
#include <Rinternals.h>
563+
564+
565+
extern void fn(
566+
const int* const x__,
567+
const int* const y__,
568+
int* const out___);
569+
570+
SEXP fn_(SEXP _args) {
571+
// x
572+
_args = CDR(_args);
573+
SEXP x = CAR(_args);
574+
if (TYPEOF(x) != INTSXP) {
575+
Rf_error("typeof(x) must be 'integer', not '%s'", Rf_type2char(TYPEOF(x)));
576+
}
577+
const int* const x__ = INTEGER(x);
578+
const R_xlen_t x__len_ = Rf_xlength(x);
579+
580+
// y
581+
_args = CDR(_args);
582+
SEXP y = CAR(_args);
583+
if (TYPEOF(y) != INTSXP) {
584+
Rf_error("typeof(y) must be 'integer', not '%s'", Rf_type2char(TYPEOF(y)));
585+
}
586+
const int* const y__ = INTEGER(y);
587+
const R_xlen_t y__len_ = Rf_xlength(y);
588+
589+
if (x__len_ != 1)
590+
Rf_error("length(x) must be 1, not %0.f",
591+
(double)x__len_);
592+
if (y__len_ != 1)
593+
Rf_error("length(y) must be 1, not %0.f",
594+
(double)y__len_);
595+
const R_xlen_t out___len_ = (1);
596+
SEXP out_ = PROTECT(Rf_allocVector(LGLSXP, out___len_));
597+
int* out___ = LOGICAL(out_);
598+
599+
fn(x__, y__, out___);
600+
601+
UNPROTECT(1);
602+
return out_;
603+
}
604+

0 commit comments

Comments
 (0)