1 /* Test F2008 18.5: ISO_Fortran_binding.h functions. */
2
3 #include "../../../libgfortran/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
elemental_mult_c(CFI_cdesc_t * a_desc,CFI_cdesc_t * b_desc,CFI_cdesc_t * c_desc)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
deallocate_c(CFI_cdesc_t * dd)70 int deallocate_c(CFI_cdesc_t * dd)
71 {
72 return CFI_deallocate(dd);
73 }
74
75
allocate_c(CFI_cdesc_t * da,CFI_index_t lower[],CFI_index_t upper[])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
establish_c(CFI_cdesc_t * desc)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
contiguous_c(CFI_cdesc_t * desc)122 int contiguous_c(CFI_cdesc_t * desc)
123 {
124 return CFI_is_contiguous(desc);
125 }
126
section_c(int * std_case,CFI_cdesc_t * source,int * low,int * str)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 assert (section.dim[0].lower_bound == lower[0]);
146 if (ind) return -2.0;
147
148 /* Sum over the section */
149 for (idx[0] = lower[0]; idx[0] < section.dim[0].extent + lower[0]; idx[0]++)
150 ans += *(float*)CFI_address ((CFI_cdesc_t*)§ion, idx);
151 return ans;
152 }
153 else if (*std_case == 2)
154 {
155 int ind;
156 lower[0] = source->dim[0].lower_bound;
157 upper[0] = source->dim[0].lower_bound + source->dim[0].extent - 1;
158 strides[0] = str[0];
159 lower[1] = upper[1] = source->dim[1].lower_bound + low[1] - 1;
160 strides[1] = 0;
161 ind = CFI_establish((CFI_cdesc_t *)§ion, NULL, CFI_attribute_other,
162 CFI_type_float, 0, 1, NULL);
163 if (ind) return -1.0;
164 ind = CFI_section((CFI_cdesc_t *)§ion, source,
165 lower, upper, strides);
166 assert (section.rank == 1);
167 assert (section.dim[0].lower_bound == lower[0]);
168 if (ind) return -2.0;
169
170 /* Sum over the section */
171 for (idx[0] = lower[0]; idx[0] < section.dim[0].extent + lower[0]; idx[0]++)
172 ans += *(float*)CFI_address ((CFI_cdesc_t*)§ion, idx);
173 return ans;
174 }
175
176 return 0.0;
177 }
178
179
select_part_c(CFI_cdesc_t * source)180 double select_part_c (CFI_cdesc_t * source)
181 {
182 typedef struct {
183 double x; double _Complex y;
184 } t;
185 CFI_CDESC_T(2) component;
186 CFI_cdesc_t * comp_cdesc = (CFI_cdesc_t *)&component;
187 CFI_index_t extent[] = {10,10};
188 CFI_index_t idx[] = {4,0};
189 double ans = 0.0;
190 int size;
191
192 (void)CFI_establish(comp_cdesc, NULL, CFI_attribute_other,
193 CFI_type_double_Complex, sizeof(double _Complex),
194 2, extent);
195 (void)CFI_select_part(comp_cdesc, source, offsetof(t,y), 0);
196 assert (comp_cdesc->dim[0].lower_bound == 0);
197 assert (comp_cdesc->dim[1].lower_bound == 0);
198
199 /* Sum over comp_cdesc[4,:] */
200 size = comp_cdesc->dim[1].extent;
201 for (idx[1] = 0; idx[1] < size; idx[1]++)
202 ans += cimag (*(double _Complex*)CFI_address ((CFI_cdesc_t*)comp_cdesc,
203 idx));
204 return ans;
205 }
206
207
setpointer_c(CFI_cdesc_t * ptr,int lbounds[])208 int setpointer_c(CFI_cdesc_t * ptr, int lbounds[])
209 {
210 CFI_index_t lower_bounds[] = {lbounds[0],lbounds[1]};
211 int ind;
212 ind = CFI_setpointer(ptr, ptr, lower_bounds);
213 return ind;
214 }
215
216
assumed_size_c(CFI_cdesc_t * desc)217 int assumed_size_c(CFI_cdesc_t * desc)
218 {
219 int res;
220
221 res = CFI_is_contiguous(desc);
222 if (!res)
223 return 1;
224 if (desc->rank)
225 res = 2 * (desc->dim[desc->rank-1].extent
226 != (CFI_index_t)(long long)(-1));
227 else
228 res = 3;
229 return res;
230 }
231