1 /* Test F2008 18.5: ISO_Fortran_binding.h functions. */
2
3 #include <ISO_Fortran_binding.h>
4 #include <assert.h>
5 #include <stdio.h>
6 #include <stdlib.h>
7 #include <complex.h>
8
9 /* Test the example in F2008 C.12.9: Processing assumed-shape arrays in C,
10 modified to use CFI_address instead of pointer arithmetic. */
11
12 int elemental_mult_c(CFI_cdesc_t * a_desc, CFI_cdesc_t * b_desc,
13 CFI_cdesc_t * c_desc)
14 {
15 CFI_index_t idx[2];
16 int *res_addr;
17 int err = 1; /* this error code represents all errors */
18
19 if (a_desc->rank == 0)
20 {
21 err = *(int*)a_desc->base_addr;
22 *(int*)a_desc->base_addr = 0;
23 return err;
24 }
25
26 if (a_desc->type != CFI_type_int
27 || b_desc->type != CFI_type_int
28 || c_desc->type != CFI_type_int)
29 return err;
30
31 /* Only support two dimensions. */
32 if (a_desc->rank != 2
33 || b_desc->rank != 2
34 || c_desc->rank != 2)
35 return err;
36
37 if (a_desc->attribute == CFI_attribute_other)
38 {
39 assert (a_desc->dim[0].lower_bound == 0);
40 assert (a_desc->dim[1].lower_bound == 0);
41 for (idx[0] = 0; idx[0] < a_desc->dim[0].extent; idx[0]++)
42 for (idx[1] = 0; idx[1] < a_desc->dim[1].extent; idx[1]++)
43 {
44 res_addr = CFI_address (a_desc, idx);
45 *res_addr = *(int*)CFI_address (b_desc, idx)
46 * *(int*)CFI_address (c_desc, idx);
47 }
48 }
49 else
50 {
51 assert (a_desc->attribute == CFI_attribute_allocatable
52 || a_desc->attribute == CFI_attribute_pointer);
53 for (idx[0] = a_desc->dim[0].lower_bound;
54 idx[0] < a_desc->dim[0].extent + a_desc->dim[0].lower_bound;
55 idx[0]++)
56 for (idx[1] = a_desc->dim[1].lower_bound;
57 idx[1] < a_desc->dim[1].extent + a_desc->dim[1].lower_bound;
58 idx[1]++)
59 {
60 res_addr = CFI_address (a_desc, idx);
61 *res_addr = *(int*)CFI_address (b_desc, idx)
62 * *(int*)CFI_address (c_desc, idx);
63 }
64 }
65
66 return 0;
67 }
68
69
70 int deallocate_c(CFI_cdesc_t * dd)
71 {
72 return CFI_deallocate(dd);
73 }
74
75
76 int allocate_c(CFI_cdesc_t * da, CFI_index_t lower[], CFI_index_t upper[])
77 {
78 int err = 1;
79 CFI_index_t idx[2];
80 int *res_addr;
81
82 if (da->attribute == CFI_attribute_other) return err;
83 if (CFI_allocate(da, lower, upper, 0)) return err;
84 assert (da->dim[0].lower_bound == lower[0]);
85 assert (da->dim[1].lower_bound == lower[1]);
86
87 for (idx[0] = lower[0]; idx[0] < da->dim[0].extent + lower[0]; idx[0]++)
88 for (idx[1] = lower[1]; idx[1] < da->dim[1].extent + lower[1]; idx[1]++)
89 {
90 res_addr = CFI_address (da, idx);
91 *res_addr = (int)(idx[0] * idx[1]);
92 }
93
94 return 0;
95 }
96
97 int establish_c(CFI_cdesc_t * desc)
98 {
99 typedef struct {double x; double _Complex y;} t;
100 int err;
101 CFI_index_t idx[1], extent[1];
102 t *res_addr;
103 double value = 1.0;
104 double complex z_value = 0.0 + 2.0 * I;
105
106 extent[0] = 10;
107 err = CFI_establish((CFI_cdesc_t *)desc,
108 malloc ((size_t)(extent[0] * sizeof(t))),
109 CFI_attribute_pointer,
110 CFI_type_struct,
111 sizeof(t), 1, extent);
112 assert (desc->dim[0].lower_bound == 0);
113 for (idx[0] = 0; idx[0] < extent[0]; idx[0]++)
114 {
115 res_addr = (t*)CFI_address (desc, idx);
116 res_addr->x = value++;
117 res_addr->y = z_value * (idx[0] + 1);
118 }
119 return err;
120 }
121
122 int contiguous_c(CFI_cdesc_t * desc)
123 {
124 return CFI_is_contiguous(desc);
125 }
126
127 float section_c(int *std_case, CFI_cdesc_t * source, int *low, int *str)
128 {
129 CFI_index_t idx[CFI_MAX_RANK], lower[CFI_MAX_RANK],
130 strides[CFI_MAX_RANK], upper[CFI_MAX_RANK];
131 CFI_CDESC_T(1) section;
132 int ind;
133 float *ret_addr;
134 float ans = 0.0;
135
136 /* Case (i) from F2018:18.5.5.7. */
137 if (*std_case == 1)
138 {
139 lower[0] = (CFI_index_t)low[0];
140 strides[0] = (CFI_index_t)str[0];
141 ind = CFI_establish((CFI_cdesc_t *)§ion, NULL, CFI_attribute_other,
142 CFI_type_float, 0, 1, NULL);
143 if (ind) return -1.0;
144 ind = CFI_section((CFI_cdesc_t *)§ion, source, lower, NULL, strides);
145 if (ind) return -2.0;
146
147 /* Sum over the section */
148 for (idx[0] = section.dim[0].lower_bound;
149 idx[0] < section.dim[0].extent + section.dim[0].lower_bound;
150 idx[0]++)
151 ans += *(float*)CFI_address ((CFI_cdesc_t*)§ion, idx);
152 return ans;
153 }
154 else if (*std_case == 2)
155 {
156 int ind;
157 lower[0] = source->dim[0].lower_bound;
158 upper[0] = source->dim[0].lower_bound + source->dim[0].extent - 1;
159 strides[0] = str[0];
160 lower[1] = upper[1] = source->dim[1].lower_bound + low[1] - 1;
161 strides[1] = 0;
162 ind = CFI_establish((CFI_cdesc_t *)§ion, NULL, CFI_attribute_other,
163 CFI_type_float, 0, 1, NULL);
164 if (ind) return -1.0;
165 ind = CFI_section((CFI_cdesc_t *)§ion, source,
166 lower, upper, strides);
167 assert (section.rank == 1);
168 if (ind) return -2.0;
169
170 /* Sum over the section */
171 for (idx[0] = section.dim[0].lower_bound;
172 idx[0] < section.dim[0].extent + section.dim[0].lower_bound;
173 idx[0]++)
174 ans += *(float*)CFI_address ((CFI_cdesc_t*)§ion, idx);
175 return ans;
176 }
177
178 return 0.0;
179 }
180
181
182 double select_part_c (CFI_cdesc_t * source)
183 {
184 typedef struct {
185 double x; double _Complex y;
186 } t;
187 CFI_CDESC_T(2) component;
188 CFI_cdesc_t * comp_cdesc = (CFI_cdesc_t *)&component;
189 CFI_index_t extent[] = {10,10};
190 CFI_index_t idx[] = {4,0};
191 double ans = 0.0;
192 int size;
193
194 (void)CFI_establish(comp_cdesc, NULL, CFI_attribute_other,
195 CFI_type_double_Complex, sizeof(double _Complex),
196 2, extent);
197 (void)CFI_select_part(comp_cdesc, source, offsetof(t,y), 0);
198 assert (comp_cdesc->dim[0].lower_bound == 0);
199 assert (comp_cdesc->dim[1].lower_bound == 0);
200
201 /* Sum over comp_cdesc[4,:] */
202 size = comp_cdesc->dim[1].extent;
203 for (idx[1] = 0; idx[1] < size; idx[1]++)
204 ans += cimag (*(double _Complex*)CFI_address ((CFI_cdesc_t*)comp_cdesc,
205 idx));
206 return ans;
207 }
208
209
210 int setpointer_c(CFI_cdesc_t * ptr, int lbounds[])
211 {
212 CFI_index_t lower_bounds[] = {lbounds[0],lbounds[1]};
213 int ind;
214 ind = CFI_setpointer(ptr, ptr, lower_bounds);
215 return ind;
216 }
217
218
219 int assumed_size_c(CFI_cdesc_t * desc)
220 {
221 int res;
222
223 res = CFI_is_contiguous(desc);
224 if (!res)
225 return 1;
226 if (desc->rank)
227 res = 2 * (desc->dim[desc->rank-1].extent
228 != (CFI_index_t)(long long)(-1));
229 else
230 res = 3;
231 return res;
232 }