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 *)&section, NULL, CFI_attribute_other,
142 			  CFI_type_float, 0, 1, NULL);
143       if (ind) return -1.0;
144       ind = CFI_section((CFI_cdesc_t *)&section, 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*)&section, 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 *)&section, NULL, CFI_attribute_other,
162 			  CFI_type_float, 0, 1, NULL);
163       if (ind) return -1.0;
164       ind = CFI_section((CFI_cdesc_t *)&section, 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*)&section, 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