Mercurial > hg > CbC > CbC_gcc

comparison libgfortran/m4/ifindloc1.m4 @ 145:1830386684a0

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
gcc-9.2.0
author anatofuz
date Thu, 13 Feb 2020 11:34:05 +0900
parents
children
comparison
equal deleted inserted replaced
131:84e7813d76e9 145:1830386684a0
1 `/* Implementation of the FINDLOC intrinsic
2 Copyright (C) 2018-2020 Free Software Foundation, Inc.
3 Contributed by Thomas König <tk@tkoenig.net>
4
5 This file is part of the GNU Fortran 95 runtime library (libgfortran).
6
7 Libgfortran is free software; you can redistribute it and/or
8 modify it under the terms of the GNU General Public
9 License as published by the Free Software Foundation; either
10 version 3 of the License, or (at your option) any later version.
11
12 Libgfortran is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
16
17 Under Section 7 of GPL version 3, you are granted additional
18 permissions described in the GCC Runtime Library Exception, version
19 3.1, as published by the Free Software Foundation.
20
21 You should have received a copy of the GNU General Public License and
22 a copy of the GCC Runtime Library Exception along with this program;
23 see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
24 <http://www.gnu.org/licenses/>. */
25
26 #include "libgfortran.h"
27 #include <assert.h>
28
29 #if defined (HAVE_'atype_name`)
30 'header1`
31 {
32 index_type count[GFC_MAX_DIMENSIONS];
33 index_type extent[GFC_MAX_DIMENSIONS];
34 index_type sstride[GFC_MAX_DIMENSIONS];
35 index_type dstride[GFC_MAX_DIMENSIONS];
36 const 'atype_name`'` * restrict base;
37 index_type * restrict dest;
38 index_type rank;
39 index_type n;
40 index_type len;
41 index_type delta;
42 index_type dim;
43 int continue_loop;
44
45 /* Make dim zero based to avoid confusion. */
46 rank = GFC_DESCRIPTOR_RANK (array) - 1;
47 dim = (*pdim) - 1;
48
49 if (unlikely (dim < 0 || dim > rank))
50 {
51 runtime_error ("Dim argument incorrect in FINDLOC intrinsic: "
52 "is %ld, should be between 1 and %ld",
53 (long int) dim + 1, (long int) rank + 1);
54 }
55
56 len = GFC_DESCRIPTOR_EXTENT(array,dim);
57 if (len < 0)
58 len = 0;
59 delta = GFC_DESCRIPTOR_STRIDE(array,dim);
60
61 for (n = 0; n < dim; n++)
62 {
63 sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
64 extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
65
66 if (extent[n] < 0)
67 extent[n] = 0;
68 }
69 for (n = dim; n < rank; n++)
70 {
71 sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1);
72 extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
73
74 if (extent[n] < 0)
75 extent[n] = 0;
76 }
77
78 if (retarray->base_addr == NULL)
79 {
80 size_t alloc_size, str;
81
82 for (n = 0; n < rank; n++)
83 {
84 if (n == 0)
85 str = 1;
86 else
87 str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
88
89 GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
90
91 }
92
93 retarray->offset = 0;
94 retarray->dtype.rank = rank;
95
96 alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
97
98 retarray->base_addr = xmallocarray (alloc_size, sizeof (index_type));
99 if (alloc_size == 0)
100 {
101 /* Make sure we have a zero-sized array. */
102 GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
103 return;
104 }
105 }
106 else
107 {
108 if (rank != GFC_DESCRIPTOR_RANK (retarray))
109 runtime_error ("rank of return array incorrect in"
110 " FINDLOC intrinsic: is %ld, should be %ld",
111 (long int) (GFC_DESCRIPTOR_RANK (retarray)),
112 (long int) rank);
113
114 if (unlikely (compile_options.bounds_check))
115 bounds_ifunction_return ((array_t *) retarray, extent,
116 "return value", "FINDLOC");
117 }
118
119 for (n = 0; n < rank; n++)
120 {
121 count[n] = 0;
122 dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
123 if (extent[n] <= 0)
124 return;
125 }
126
127 dest = retarray->base_addr;
128 continue_loop = 1;
129
130 base = array->base_addr;
131 while (continue_loop)
132 {
133 const 'atype_name`'` * restrict src;
134 index_type result;
135
136 result = 0;
137 if (back)
138 {
139 src = base + (len - 1) * delta * 'base_mult`;
140 for (n = len; n > 0; n--, src -= delta * 'base_mult`)
141 {
142 if ('comparison`'`)
143 {
144 result = n;
145 break;
146 }
147 }
148 }
149 else
150 {
151 src = base;
152 for (n = 1; n <= len; n++, src += delta * 'base_mult`)
153 {
154 if ('comparison`'`)
155 {
156 result = n;
157 break;
158 }
159 }
160 }
161 *dest = result;
162
163 count[0]++;
164 base += sstride[0] * 'base_mult`;
165 dest += dstride[0];
166 n = 0;
167 while (count[n] == extent[n])
168 {
169 count[n] = 0;
170 base -= sstride[n] * extent[n] * 'base_mult`;
171 dest -= dstride[n] * extent[n];
172 n++;
173 if (n >= rank)
174 {
175 continue_loop = 0;
176 break;
177 }
178 else
179 {
180 count[n]++;
181 base += sstride[n] * 'base_mult`;
182 dest += dstride[n];
183 }
184 }
185 }
186 }
187 'header2`'`
188 {
189 index_type count[GFC_MAX_DIMENSIONS];
190 index_type extent[GFC_MAX_DIMENSIONS];
191 index_type sstride[GFC_MAX_DIMENSIONS];
192 index_type mstride[GFC_MAX_DIMENSIONS];
193 index_type dstride[GFC_MAX_DIMENSIONS];
194 const 'atype_name`'` * restrict base;
195 const GFC_LOGICAL_1 * restrict mbase;
196 index_type * restrict dest;
197 index_type rank;
198 index_type n;
199 index_type len;
200 index_type delta;
201 index_type mdelta;
202 index_type dim;
203 int mask_kind;
204 int continue_loop;
205
206 /* Make dim zero based to avoid confusion. */
207 rank = GFC_DESCRIPTOR_RANK (array) - 1;
208 dim = (*pdim) - 1;
209
210 if (unlikely (dim < 0 || dim > rank))
211 {
212 runtime_error ("Dim argument incorrect in FINDLOC intrinsic: "
213 "is %ld, should be between 1 and %ld",
214 (long int) dim + 1, (long int) rank + 1);
215 }
216
217 len = GFC_DESCRIPTOR_EXTENT(array,dim);
218 if (len < 0)
219 len = 0;
220
221 delta = GFC_DESCRIPTOR_STRIDE(array,dim);
222 mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim);
223
224 mbase = mask->base_addr;
225
226 mask_kind = GFC_DESCRIPTOR_SIZE (mask);
227
228 if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
229 #ifdef HAVE_GFC_LOGICAL_16
230 || mask_kind == 16
231 #endif
232 )
233 mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
234 else
235 internal_error (NULL, "Funny sized logical array");
236
237 for (n = 0; n < dim; n++)
238 {
239 sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
240 mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
241 extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
242
243 if (extent[n] < 0)
244 extent[n] = 0;
245 }
246 for (n = dim; n < rank; n++)
247 {
248 sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1);
249 mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1);
250 extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1);
251
252 if (extent[n] < 0)
253 extent[n] = 0;
254 }
255
256 if (retarray->base_addr == NULL)
257 {
258 size_t alloc_size, str;
259
260 for (n = 0; n < rank; n++)
261 {
262 if (n == 0)
263 str = 1;
264 else
265 str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
266
267 GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
268
269 }
270
271 retarray->offset = 0;
272 retarray->dtype.rank = rank;
273
274 alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
275
276 retarray->base_addr = xmallocarray (alloc_size, sizeof (index_type));
277 if (alloc_size == 0)
278 {
279 /* Make sure we have a zero-sized array. */
280 GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
281 return;
282 }
283 }
284 else
285 {
286 if (rank != GFC_DESCRIPTOR_RANK (retarray))
287 runtime_error ("rank of return array incorrect in"
288 " FINDLOC intrinsic: is %ld, should be %ld",
289 (long int) (GFC_DESCRIPTOR_RANK (retarray)),
290 (long int) rank);
291
292 if (unlikely (compile_options.bounds_check))
293 bounds_ifunction_return ((array_t *) retarray, extent,
294 "return value", "FINDLOC");
295 }
296
297 for (n = 0; n < rank; n++)
298 {
299 count[n] = 0;
300 dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
301 if (extent[n] <= 0)
302 return;
303 }
304
305 dest = retarray->base_addr;
306 continue_loop = 1;
307
308 base = array->base_addr;
309 while (continue_loop)
310 {
311 const 'atype_name`'` * restrict src;
312 const GFC_LOGICAL_1 * restrict msrc;
313 index_type result;
314
315 result = 0;
316 if (back)
317 {
318 src = base + (len - 1) * delta * 'base_mult`;
319 msrc = mbase + (len - 1) * mdelta;
320 for (n = len; n > 0; n--, src -= delta * 'base_mult`, msrc -= mdelta)
321 {
322 if (*msrc && 'comparison`'`)
323 {
324 result = n;
325 break;
326 }
327 }
328 }
329 else
330 {
331 src = base;
332 msrc = mbase;
333 for (n = 1; n <= len; n++, src += delta * 'base_mult`, msrc += mdelta)
334 {
335 if (*msrc && 'comparison`'`)
336 {
337 result = n;
338 break;
339 }
340 }
341 }
342 *dest = result;
343
344 count[0]++;
345 base += sstride[0] * 'base_mult`;
346 mbase += mstride[0];
347 dest += dstride[0];
348 n = 0;
349 while (count[n] == extent[n])
350 {
351 count[n] = 0;
352 base -= sstride[n] * extent[n] * 'base_mult`;
353 mbase -= mstride[n] * extent[n];
354 dest -= dstride[n] * extent[n];
355 n++;
356 if (n >= rank)
357 {
358 continue_loop = 0;
359 break;
360 }
361 else
362 {
363 count[n]++;
364 base += sstride[n] * 'base_mult`;
365 dest += dstride[n];
366 }
367 }
368 }
369 }
370 'header3`'`
371 {
372 index_type count[GFC_MAX_DIMENSIONS];
373 index_type extent[GFC_MAX_DIMENSIONS];
374 index_type dstride[GFC_MAX_DIMENSIONS];
375 index_type * restrict dest;
376 index_type rank;
377 index_type n;
378 index_type len;
379 index_type dim;
380 bool continue_loop;
381
382 if (mask == NULL || *mask)
383 {
384 findloc1_'atype_code`'` (retarray, array, value, pdim, back'len_arg`'`);
385 return;
386 }
387 /* Make dim zero based to avoid confusion. */
388 rank = GFC_DESCRIPTOR_RANK (array) - 1;
389 dim = (*pdim) - 1;
390
391 if (unlikely (dim < 0 || dim > rank))
392 {
393 runtime_error ("Dim argument incorrect in FINDLOC intrinsic: "
394 "is %ld, should be between 1 and %ld",
395 (long int) dim + 1, (long int) rank + 1);
396 }
397
398 len = GFC_DESCRIPTOR_EXTENT(array,dim);
399 if (len < 0)
400 len = 0;
401
402 for (n = 0; n < dim; n++)
403 {
404 extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
405
406 if (extent[n] <= 0)
407 extent[n] = 0;
408 }
409
410 for (n = dim; n < rank; n++)
411 {
412 extent[n] =
413 GFC_DESCRIPTOR_EXTENT(array,n + 1);
414
415 if (extent[n] <= 0)
416 extent[n] = 0;
417 }
418
419
420 if (retarray->base_addr == NULL)
421 {
422 size_t alloc_size, str;
423
424 for (n = 0; n < rank; n++)
425 {
426 if (n == 0)
427 str = 1;
428 else
429 str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
430
431 GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
432 }
433
434 retarray->offset = 0;
435 retarray->dtype.rank = rank;
436
437 alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
438
439 retarray->base_addr = xmallocarray (alloc_size, sizeof (index_type));
440 if (alloc_size == 0)
441 {
442 /* Make sure we have a zero-sized array. */
443 GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
444 return;
445 }
446 }
447 else
448 {
449 if (rank != GFC_DESCRIPTOR_RANK (retarray))
450 runtime_error ("rank of return array incorrect in"
451 " FINDLOC intrinsic: is %ld, should be %ld",
452 (long int) (GFC_DESCRIPTOR_RANK (retarray)),
453 (long int) rank);
454
455 if (unlikely (compile_options.bounds_check))
456 bounds_ifunction_return ((array_t *) retarray, extent,
457 "return value", "FINDLOC");
458 }
459
460 for (n = 0; n < rank; n++)
461 {
462 count[n] = 0;
463 dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
464 if (extent[n] <= 0)
465 return;
466 }
467 dest = retarray->base_addr;
468 continue_loop = 1;
469
470 while (continue_loop)
471 {
472 *dest = 0;
473
474 count[0]++;
475 dest += dstride[0];
476 n = 0;
477 while (count[n] == extent[n])
478 {
479 count[n] = 0;
480 dest -= dstride[n] * extent[n];
481 n++;
482 if (n >= rank)
483 {
484 continue_loop = 0;
485 break;
486 }
487 else
488 {
489 count[n]++;
490 dest += dstride[n];
491 }
492 }
493 }
494 }
495 #endif'