1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
|
library(inline)
isSolaris <- Sys.info()[["sysname"]] == "SunOS"
n <- 10L
x <- 1:10
## A simple Fortran example - n and x: assumed-size vector
code <- "
integer i
do 1 i=1, n(1)
1 x(i) = x(i)**3
"
cubefn <- cfunction(signature(n = "integer", x = "numeric"), code,
convention = ".Fortran")
res_cube <- list(
n = 10L,
x = c(1, 8, 27, 64, 125, 216, 343, 512, 729, 1000))
res_1 <- cubefn(n, x)
expect_identical(res_cube, res_1)
cubefn_named <- cfunction(signature(n = "integer", x = "numeric"), code,
convention = ".Fortran", name = "cubefn")
expect_identical(cubefn_named(n, x), res_1)
expect_true(grepl("cubefn", cubefn_named@code))
## Same Fortran example - now n is one number
code2 <- "
integer i
do 1 i=1, n
1 x(i) = x(i)**3
"
cubefn2 <- cfunction(signature(n = "integer", x = "numeric"),
implicit = "none", dim = c("", "(*)"), code2, convention=".Fortran")
res_2 <- cubefn2(n, x)
expect_identical(res_2, res_cube)
## Same in F95, now x is fixed-size vector (length = n)
code3 <- "x = x*x*x"
cubefn3 <- cfunction(signature(n = "integer", x = "numeric"),
implicit = "none", dim = c("", "(n)"), code3, language="F95")
res_3 <- cubefn3(n, x)
expect_identical(res_3, res_cube)
## Same example in C
code4 <- "
int i;
for (i = 0; i < *n; i++)
x[i] = x[i]*x[i]*x[i];
"
cubefn4 <- cfunction(signature(n = "integer", x = "numeric"), code4,
language = "C", convention = ".C")
res_4 <- cubefn4(n, x)
expect_identical(res_4, res_cube)
if (isSolaris) exit_file("Skip remainder")
## use of a module in F95
modct <- "module modcts
double precision, parameter :: pi = 3.14159265358979
double precision, parameter :: e = 2.71828182845905
end"
getconstants <- "x(1) = pi
x(2) = e"
cgetcts <- cfunction(body = getconstants, module = "modcts", implicit = "none",
includes = modct, sig = c(x = "double"), dim = c("(2)"), language = "F95")
res_5 <- cgetcts(x = c(1, 2))
expect_equal(res_5$x, c(pi, exp(1)), tolerance = 1e-7)
## Use of .C convention with C code
## Defining two functions, one of which calls the other
sigSq <- signature(n = "integer", x = "numeric")
codeSq <- "
for (int i=0; i < *n; i++) {
x[i] = x[i]*x[i];
}"
sigQd <- signature(n = "integer", x = "numeric")
codeQd <- "
squarefn(n, x);
squarefn(n, x);
"
fns <- cfunction(
sig = list(squarefn = sigSq, quadfn = sigQd),
body = list(codeSq, codeQd),
convention = ".C")
res_square <- list(
n = 10L,
x = c(1, 4, 9, 16, 25, 36, 49, 64, 81, 100))
res_quad <- list(
n = 10L,
x = c(1, 16, 81, 256, 625, 1296, 2401, 4096, 6561, 10000))
res_6_square <- fns[["squarefn"]](n, x)
res_6_quad <- fns[["quadfn"]](n, x)
expect_identical(res_6_square, res_square)
expect_identical(res_6_quad, res_quad)
## Alternative declaration using 'setCMethod'
setCMethod(c("squarefn", "quadfn"), list(sigSq, sigQd),
list(codeSq, codeQd), convention = ".C")
res_7_square <- squarefn(n, x)
res_7_quad <- quadfn(n, x)
expect_identical(res_7_square, res_square)
expect_identical(res_7_quad, res_quad)
|
