Mercurial > hg > CbC > CbC_gcc

comparison libgfortran/m4/iforeach.m4 @ 111:04ced10e8804

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
gcc 7
author kono
date Fri, 27 Oct 2017 22:46:09 +0900
parents
children 84e7813d76e9
comparison
equal deleted inserted replaced
68:561a7518be6b 111:04ced10e8804
1 dnl Support macro file for intrinsic functions.
2 dnl Contains the generic sections of the array functions.
3 dnl This file is part of the GNU Fortran Runtime Library (libgfortran)
4 dnl Distributed under the GNU GPL with exception. See COPYING for details.
5 define(START_FOREACH_FUNCTION,
6 `
7 extern void name`'rtype_qual`_'atype_code (rtype * const restrict retarray,
8 atype * const restrict array);
9 export_proto(name`'rtype_qual`_'atype_code);
10
11 void
12 name`'rtype_qual`_'atype_code (rtype * const restrict retarray,
13 atype * const restrict array)
14 {
15 index_type count[GFC_MAX_DIMENSIONS];
16 index_type extent[GFC_MAX_DIMENSIONS];
17 index_type sstride[GFC_MAX_DIMENSIONS];
18 index_type dstride;
19 const atype_name *base;
20 rtype_name * restrict dest;
21 index_type rank;
22 index_type n;
23
24 rank = GFC_DESCRIPTOR_RANK (array);
25 if (rank <= 0)
26 runtime_error ("Rank of array needs to be > 0");
27
28 if (retarray->base_addr == NULL)
29 {
30 GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1);
31 retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1;
32 retarray->offset = 0;
33 retarray->base_addr = xmallocarray (rank, sizeof (rtype_name));
34 }
35 else
36 {
37 if (unlikely (compile_options.bounds_check))
38 bounds_iforeach_return ((array_t *) retarray, (array_t *) array,
39 "u_name");
40 }
41
42 dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
43 dest = retarray->base_addr;
44 for (n = 0; n < rank; n++)
45 {
46 sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
47 extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
48 count[n] = 0;
49 if (extent[n] <= 0)
50 {
51 /* Set the return value. */
52 for (n = 0; n < rank; n++)
53 dest[n * dstride] = 0;
54 return;
55 }
56 }
57
58 base = array->base_addr;
59
60 /* Initialize the return value. */
61 for (n = 0; n < rank; n++)
62 dest[n * dstride] = 1;
63 {
64 ')dnl
65 define(START_FOREACH_BLOCK,
66 ` while (base)
67 {
68 do
69 {
70 /* Implementation start. */
71 ')dnl
72 define(FINISH_FOREACH_FUNCTION,
73 ` /* Implementation end. */
74 /* Advance to the next element. */
75 base += sstride[0];
76 }
77 while (++count[0] != extent[0]);
78 n = 0;
79 do
80 {
81 /* When we get to the end of a dimension, reset it and increment
82 the next dimension. */
83 count[n] = 0;
84 /* We could precalculate these products, but this is a less
85 frequently used path so probably not worth it. */
86 base -= sstride[n] * extent[n];
87 n++;
88 if (n >= rank)
89 {
90 /* Break out of the loop. */
91 base = NULL;
92 break;
93 }
94 else
95 {
96 count[n]++;
97 base += sstride[n];
98 }
99 }
100 while (count[n] == extent[n]);
101 }
102 }
103 }')dnl
104 define(START_MASKED_FOREACH_FUNCTION,
105 `
106 extern void `m'name`'rtype_qual`_'atype_code (rtype * const restrict,
107 atype * const restrict, gfc_array_l1 * const restrict);
108 export_proto(`m'name`'rtype_qual`_'atype_code);
109
110 void
111 `m'name`'rtype_qual`_'atype_code (rtype * const restrict retarray,
112 atype * const restrict array,
113 gfc_array_l1 * const restrict mask)
114 {
115 index_type count[GFC_MAX_DIMENSIONS];
116 index_type extent[GFC_MAX_DIMENSIONS];
117 index_type sstride[GFC_MAX_DIMENSIONS];
118 index_type mstride[GFC_MAX_DIMENSIONS];
119 index_type dstride;
120 rtype_name *dest;
121 const atype_name *base;
122 GFC_LOGICAL_1 *mbase;
123 int rank;
124 index_type n;
125 int mask_kind;
126
127 rank = GFC_DESCRIPTOR_RANK (array);
128 if (rank <= 0)
129 runtime_error ("Rank of array needs to be > 0");
130
131 if (retarray->base_addr == NULL)
132 {
133 GFC_DIMENSION_SET(retarray->dim[0], 0, rank - 1, 1);
134 retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1;
135 retarray->offset = 0;
136 retarray->base_addr = xmallocarray (rank, sizeof (rtype_name));
137 }
138 else
139 {
140 if (unlikely (compile_options.bounds_check))
141 {
142
143 bounds_iforeach_return ((array_t *) retarray, (array_t *) array,
144 "u_name");
145 bounds_equal_extents ((array_t *) mask, (array_t *) array,
146 "MASK argument", "u_name");
147 }
148 }
149
150 mask_kind = GFC_DESCRIPTOR_SIZE (mask);
151
152 mbase = mask->base_addr;
153
154 if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
155 #ifdef HAVE_GFC_LOGICAL_16
156 || mask_kind == 16
157 #endif
158 )
159 mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
160 else
161 runtime_error ("Funny sized logical array");
162
163 dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
164 dest = retarray->base_addr;
165 for (n = 0; n < rank; n++)
166 {
167 sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
168 mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
169 extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
170 count[n] = 0;
171 if (extent[n] <= 0)
172 {
173 /* Set the return value. */
174 for (n = 0; n < rank; n++)
175 dest[n * dstride] = 0;
176 return;
177 }
178 }
179
180 base = array->base_addr;
181
182 /* Initialize the return value. */
183 for (n = 0; n < rank; n++)
184 dest[n * dstride] = 0;
185 {
186 ')dnl
187 define(START_MASKED_FOREACH_BLOCK, `START_FOREACH_BLOCK')dnl
188 define(FINISH_MASKED_FOREACH_FUNCTION,
189 ` /* Implementation end. */
190 /* Advance to the next element. */
191 base += sstride[0];
192 mbase += mstride[0];
193 }
194 while (++count[0] != extent[0]);
195 n = 0;
196 do
197 {
198 /* When we get to the end of a dimension, reset it and increment
199 the next dimension. */
200 count[n] = 0;
201 /* We could precalculate these products, but this is a less
202 frequently used path so probably not worth it. */
203 base -= sstride[n] * extent[n];
204 mbase -= mstride[n] * extent[n];
205 n++;
206 if (n >= rank)
207 {
208 /* Break out of the loop. */
209 base = NULL;
210 break;
211 }
212 else
213 {
214 count[n]++;
215 base += sstride[n];
216 mbase += mstride[n];
217 }
218 }
219 while (count[n] == extent[n]);
220 }
221 }
222 }')dnl
223 define(FOREACH_FUNCTION,
224 `START_FOREACH_FUNCTION
225 $1
226 START_FOREACH_BLOCK
227 $2
228 FINISH_FOREACH_FUNCTION')dnl
229 define(MASKED_FOREACH_FUNCTION,
230 `START_MASKED_FOREACH_FUNCTION
231 $1
232 START_MASKED_FOREACH_BLOCK
233 $2
234 FINISH_MASKED_FOREACH_FUNCTION')dnl
235 define(SCALAR_FOREACH_FUNCTION,
236 `
237 extern void `s'name`'rtype_qual`_'atype_code (rtype * const restrict,
238 atype * const restrict, GFC_LOGICAL_4 *);
239 export_proto(`s'name`'rtype_qual`_'atype_code);
240
241 void
242 `s'name`'rtype_qual`_'atype_code (rtype * const restrict retarray,
243 atype * const restrict array,
244 GFC_LOGICAL_4 * mask)
245 {
246 index_type rank;
247 index_type dstride;
248 index_type n;
249 rtype_name *dest;
250
251 if (*mask)
252 {
253 name`'rtype_qual`_'atype_code (retarray, array);
254 return;
255 }
256
257 rank = GFC_DESCRIPTOR_RANK (array);
258
259 if (rank <= 0)
260 runtime_error ("Rank of array needs to be > 0");
261
262 if (retarray->base_addr == NULL)
263 {
264 GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1);
265 retarray->dtype = (retarray->dtype & ~GFC_DTYPE_RANK_MASK) | 1;
266 retarray->offset = 0;
267 retarray->base_addr = xmallocarray (rank, sizeof (rtype_name));
268 }
269 else if (unlikely (compile_options.bounds_check))
270 {
271 bounds_iforeach_return ((array_t *) retarray, (array_t *) array,
272 "u_name");
273 }
274
275 dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
276 dest = retarray->base_addr;
277 for (n = 0; n<rank; n++)
278 dest[n * dstride] = $1 ;
279 }')dnl