1 #include <stdlib.h>
2 #include <stdio.h>
3
4 #include <ISO_Fortran_binding.h>
5 #include "dump-descriptors.h"
6
7 struct m {
8 int x, y;
9 };
10
11 extern void ctest (CFI_cdesc_t *a, int lb0, int lb1,
12 int ub0, int ub1, int s0, int s1, CFI_cdesc_t *r);
13
14 /* Take a section of array A. OFF is the start index of A on the Fortran
15 side and the bounds LB and UB for the section to take are relative to
16 that base index. Store the result in R, which is supposed to be a pointer
17 array with lower bound 1. */
18
19 void
20 ctest (CFI_cdesc_t *a, int lb0, int lb1,
21 int ub0, int ub1, int s0, int s1, CFI_cdesc_t *r)
22 {
23 CFI_index_t lb_array[2], ub_array[2], s_array[2];
24 int i0, i1, o0, o1;
25
26 /* Dump the descriptor contents to test that we can access the fields
27 correctly, etc. */
28 fprintf (stderr, "\n%s: lb0=%d lb1=%d ub0=%d ub1=%d s0=%d s1=%d\n",
29 (a->attribute == CFI_attribute_other) ? "non-pointer" : "pointer",
30 lb0, lb1, ub0, ub1, s0, s1);
31 if (! (lb0 == ub0 || lb1 == ub1))
32 abort ();
33 dump_CFI_cdesc_t (a);
34 dump_CFI_cdesc_t (r);
35
36 /* Make sure we got a valid input descriptor. */
37 if (!a->base_addr)
38 abort ();
39 if (a->elem_len != sizeof(struct m))
40 abort ();
41 if (a->rank != 2)
42 abort ();
43 if (a->type != CFI_type_struct)
44 abort ();
45 if (a->attribute == CFI_attribute_other)
46 {
47 if (a->dim[0].lower_bound != 0)
48 abort ();
49 /* Adjust the 1-based bounds. */
50 lb0 = lb0 - 1;
51 lb1 = lb1 - 1;
52 ub0 = ub0 - 1;
53 ub1 = ub1 - 1;
54 }
55 /* For pointer arrays, the bounds use the same indexing as the lower
56 bound in the array descriptor. */
57
58 /* Make sure we got a valid output descriptor. */
59 if (r->base_addr)
60 abort ();
61 if (r->elem_len != sizeof(struct m))
62 abort ();
63 if (r->rank != 1)
64 abort ();
65 if (r->type != CFI_type_struct)
66 abort ();
67 if (r->attribute != CFI_attribute_pointer)
68 abort ();
69
70 /* Create an array section. */
71 lb_array[0] = lb0;
72 lb_array[1] = lb1;
73 ub_array[0] = ub0;
74 ub_array[1] = ub1;
75 s_array[0] = s0;
76 s_array[1] = s1;
77
78 check_CFI_status ("CFI_section",
79 CFI_section (r, a, lb_array, ub_array, s_array));
80
81 /* Check that the output descriptor is correct. */
82 dump_CFI_cdesc_t (r);
83 if (!r->base_addr)
84 abort ();
85 if (r->elem_len != sizeof(struct m))
86 abort ();
87 if (r->rank != 1)
88 abort ();
89 if (r->type != CFI_type_struct)
90 abort ();
91 if (r->attribute != CFI_attribute_pointer)
92 abort ();
93
94 /* Check the contents of the output array. */
95 #if 0
96 if (lb1 == ub1)
97 {
98 /* Output is 1-d array that varies in dimension 0. */
99 for (o0 = r->dim[0].lower_bound, i0 = lb0;
100 (s0 > 0 ? i0 <= ub0 : i0 >= ub0);
101 o0++, i0 += s0)
102 {
103 CFI_index_t index[2];
104 struct m *input, *output;
105 index[0] = i0;
106 index[1] = lb1;
107 input = (struct m *) CFI_address (a, index);
108 index[0] = o0;
109 output = (struct m *) CFI_address (r, index);
110 fprintf (stderr, "a(%d,%d) = (%d,%d), r(%d) = (%d,%d)\n",
111 i0, lb1, input->x, input->y, o0, output->x, output->y);
112 }
113 }
114 else if (lb0 == ub0)
115 {
116 /* Output is 1-d array that varies in dimension 1. */
117 for (o1 = r->dim[0].lower_bound, i1 = lb1;
118 (s1 > 0 ? i1 <= ub1 : i1 >= ub1);
119 o1++, i1 += s1)
120 {
121 CFI_index_t index[2];
122 struct m *input, *output;
123 index[0] = lb0;
124 index[1] = i1;
125 input = (struct m *) CFI_address (a, index);
126 index[0] = o1;
127 output = (struct m *) CFI_address (r, index);
128 fprintf (stderr, "a(%d,%d) = (%d,%d), r(%d) = (%d,%d)\n",
129 lb0, i1, input->x, input->y, o1, output->x, output->y);
130 }
131 }
132 else
133 abort ();
134 #endif
135 if (lb1 == ub1)
136 {
137 /* Output is 1-d array that varies in dimension 0. */
138 for (o0 = r->dim[0].lower_bound, i0 = lb0;
139 (s0 > 0 ? i0 <= ub0 : i0 >= ub0);
140 o0++, i0 += s0)
141 {
142 CFI_index_t index[2];
143 struct m *input, *output;
144 index[0] = i0;
145 index[1] = lb1;
146 input = (struct m *) CFI_address (a, index);
147 index[0] = o0;
148 output = (struct m *) CFI_address (r, index);
149 if (input->x != output->x || input->y != output->y)
150 abort ();
151 }
152 }
153 else if (lb0 == ub0)
154 {
155 /* Output is 1-d array that varies in dimension 1. */
156 for (o1 = r->dim[0].lower_bound, i1 = lb1;
157 (s1 > 0 ? i1 <= ub1 : i1 >= ub1);
158 o1++, i1 += s1)
159 {
160 CFI_index_t index[2];
161 struct m *input, *output;
162 index[0] = lb0;
163 index[1] = i1;
164 input = (struct m *) CFI_address (a, index);
165 index[0] = o1;
166 output = (struct m *) CFI_address (r, index);
167 if (input->x != output->x || input->y != output->y)
168 abort ();
169 }
170 }
171 else
172 abort ();
173
174 /* Force the output array to be 1-based. */
175 lb_array[0] = 1;
176 lb_array[1] = 1;
177 check_CFI_status ("CFI_setpointer", CFI_setpointer (r, r, lb_array));
178 /* Check that the output descriptor is correct. */
179 dump_CFI_cdesc_t (r);
180 if (!r->base_addr)
181 abort ();
182 if (r->elem_len != sizeof(struct m))
183 abort ();
184 if (r->rank != 1)
185 abort ();
186 if (r->type != CFI_type_struct)
187 abort ();
188 if (r->attribute != CFI_attribute_pointer)
189 abort ();
190 if (r->dim[0].lower_bound != 1)
191 abort ();
192
193 /* Check the contents of the output array again. */
194 if (lb1 == ub1)
195 {
196 /* Output is 1-d array that varies in dimension 0. */
197 for (o0 = r->dim[0].lower_bound, i0 = lb0;
198 (s0 > 0 ? i0 <= ub0 : i0 >= ub0);
199 o0++, i0 += s0)
200 {
201 CFI_index_t index[2];
202 struct m *input, *output;
203 index[0] = i0;
204 index[1] = lb1;
205 input = (struct m *) CFI_address (a, index);
206 index[0] = o0;
207 output = (struct m *) CFI_address (r, index);
208 if (input->x != output->x || input->y != output->y)
209 abort ();
210 }
211 }
212 else if (lb0 == ub0)
213 {
214 /* Output is 1-d array that varies in dimension 1. */
215 for (o1 = r->dim[0].lower_bound, i1 = lb1;
216 (s1 > 0 ? i1 <= ub1 : i1 >= ub1);
217 o1++, i1 += s1)
218 {
219 CFI_index_t index[2];
220 struct m *input, *output;
221 index[0] = lb0;
222 index[1] = i1;
223 input = (struct m *) CFI_address (a, index);
224 index[0] = o1;
225 output = (struct m *) CFI_address (r, index);
226 if (input->x != output->x || input->y != output->y)
227 abort ();
228 }
229 }
230 else
231 abort ();
232 }
233
234
235