Mercurial > hg > CbC > CbC_gcc
comparison libgfortran/generated/minval_i4.c @ 111:04ced10e8804
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 /* Implementation of the MINVAL intrinsic | |
2 Copyright (C) 2002-2017 Free Software Foundation, Inc. | |
3 Contributed by Paul Brook <paul@nowt.org> | |
4 | |
5 This file is part of the GNU Fortran 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 | |
28 | |
29 #if defined (HAVE_GFC_INTEGER_4) && defined (HAVE_GFC_INTEGER_4) | |
30 | |
31 | |
32 extern void minval_i4 (gfc_array_i4 * const restrict, | |
33 gfc_array_i4 * const restrict, const index_type * const restrict); | |
34 export_proto(minval_i4); | |
35 | |
36 void | |
37 minval_i4 (gfc_array_i4 * const restrict retarray, | |
38 gfc_array_i4 * const restrict array, | |
39 const index_type * const restrict pdim) | |
40 { | |
41 index_type count[GFC_MAX_DIMENSIONS]; | |
42 index_type extent[GFC_MAX_DIMENSIONS]; | |
43 index_type sstride[GFC_MAX_DIMENSIONS]; | |
44 index_type dstride[GFC_MAX_DIMENSIONS]; | |
45 const GFC_INTEGER_4 * restrict base; | |
46 GFC_INTEGER_4 * restrict dest; | |
47 index_type rank; | |
48 index_type n; | |
49 index_type len; | |
50 index_type delta; | |
51 index_type dim; | |
52 int continue_loop; | |
53 | |
54 /* Make dim zero based to avoid confusion. */ | |
55 rank = GFC_DESCRIPTOR_RANK (array) - 1; | |
56 dim = (*pdim) - 1; | |
57 | |
58 if (unlikely (dim < 0 || dim > rank)) | |
59 { | |
60 runtime_error ("Dim argument incorrect in MINVAL intrinsic: " | |
61 "is %ld, should be between 1 and %ld", | |
62 (long int) dim + 1, (long int) rank + 1); | |
63 } | |
64 | |
65 len = GFC_DESCRIPTOR_EXTENT(array,dim); | |
66 if (len < 0) | |
67 len = 0; | |
68 delta = GFC_DESCRIPTOR_STRIDE(array,dim); | |
69 | |
70 for (n = 0; n < dim; n++) | |
71 { | |
72 sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); | |
73 extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); | |
74 | |
75 if (extent[n] < 0) | |
76 extent[n] = 0; | |
77 } | |
78 for (n = dim; n < rank; n++) | |
79 { | |
80 sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1); | |
81 extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); | |
82 | |
83 if (extent[n] < 0) | |
84 extent[n] = 0; | |
85 } | |
86 | |
87 if (retarray->base_addr == NULL) | |
88 { | |
89 size_t alloc_size, str; | |
90 | |
91 for (n = 0; n < rank; n++) | |
92 { | |
93 if (n == 0) | |
94 str = 1; | |
95 else | |
96 str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; | |
97 | |
98 GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); | |
99 | |
100 } | |
101 | |
102 retarray->offset = 0; | |
103 retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; | |
104 | |
105 alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]; | |
106 | |
107 retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_4)); | |
108 if (alloc_size == 0) | |
109 { | |
110 /* Make sure we have a zero-sized array. */ | |
111 GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); | |
112 return; | |
113 | |
114 } | |
115 } | |
116 else | |
117 { | |
118 if (rank != GFC_DESCRIPTOR_RANK (retarray)) | |
119 runtime_error ("rank of return array incorrect in" | |
120 " MINVAL intrinsic: is %ld, should be %ld", | |
121 (long int) (GFC_DESCRIPTOR_RANK (retarray)), | |
122 (long int) rank); | |
123 | |
124 if (unlikely (compile_options.bounds_check)) | |
125 bounds_ifunction_return ((array_t *) retarray, extent, | |
126 "return value", "MINVAL"); | |
127 } | |
128 | |
129 for (n = 0; n < rank; n++) | |
130 { | |
131 count[n] = 0; | |
132 dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); | |
133 if (extent[n] <= 0) | |
134 return; | |
135 } | |
136 | |
137 base = array->base_addr; | |
138 dest = retarray->base_addr; | |
139 | |
140 continue_loop = 1; | |
141 while (continue_loop) | |
142 { | |
143 const GFC_INTEGER_4 * restrict src; | |
144 GFC_INTEGER_4 result; | |
145 src = base; | |
146 { | |
147 | |
148 #if defined (GFC_INTEGER_4_INFINITY) | |
149 result = GFC_INTEGER_4_INFINITY; | |
150 #else | |
151 result = GFC_INTEGER_4_HUGE; | |
152 #endif | |
153 if (len <= 0) | |
154 *dest = GFC_INTEGER_4_HUGE; | |
155 else | |
156 { | |
157 for (n = 0; n < len; n++, src += delta) | |
158 { | |
159 | |
160 #if defined (GFC_INTEGER_4_QUIET_NAN) | |
161 if (*src <= result) | |
162 break; | |
163 } | |
164 if (unlikely (n >= len)) | |
165 result = GFC_INTEGER_4_QUIET_NAN; | |
166 else for (; n < len; n++, src += delta) | |
167 { | |
168 #endif | |
169 if (*src < result) | |
170 result = *src; | |
171 } | |
172 | |
173 *dest = result; | |
174 } | |
175 } | |
176 /* Advance to the next element. */ | |
177 count[0]++; | |
178 base += sstride[0]; | |
179 dest += dstride[0]; | |
180 n = 0; | |
181 while (count[n] == extent[n]) | |
182 { | |
183 /* When we get to the end of a dimension, reset it and increment | |
184 the next dimension. */ | |
185 count[n] = 0; | |
186 /* We could precalculate these products, but this is a less | |
187 frequently used path so probably not worth it. */ | |
188 base -= sstride[n] * extent[n]; | |
189 dest -= dstride[n] * extent[n]; | |
190 n++; | |
191 if (n >= rank) | |
192 { | |
193 /* Break out of the loop. */ | |
194 continue_loop = 0; | |
195 break; | |
196 } | |
197 else | |
198 { | |
199 count[n]++; | |
200 base += sstride[n]; | |
201 dest += dstride[n]; | |
202 } | |
203 } | |
204 } | |
205 } | |
206 | |
207 | |
208 extern void mminval_i4 (gfc_array_i4 * const restrict, | |
209 gfc_array_i4 * const restrict, const index_type * const restrict, | |
210 gfc_array_l1 * const restrict); | |
211 export_proto(mminval_i4); | |
212 | |
213 void | |
214 mminval_i4 (gfc_array_i4 * const restrict retarray, | |
215 gfc_array_i4 * const restrict array, | |
216 const index_type * const restrict pdim, | |
217 gfc_array_l1 * const restrict mask) | |
218 { | |
219 index_type count[GFC_MAX_DIMENSIONS]; | |
220 index_type extent[GFC_MAX_DIMENSIONS]; | |
221 index_type sstride[GFC_MAX_DIMENSIONS]; | |
222 index_type dstride[GFC_MAX_DIMENSIONS]; | |
223 index_type mstride[GFC_MAX_DIMENSIONS]; | |
224 GFC_INTEGER_4 * restrict dest; | |
225 const GFC_INTEGER_4 * restrict base; | |
226 const GFC_LOGICAL_1 * restrict mbase; | |
227 index_type rank; | |
228 index_type dim; | |
229 index_type n; | |
230 index_type len; | |
231 index_type delta; | |
232 index_type mdelta; | |
233 int mask_kind; | |
234 | |
235 dim = (*pdim) - 1; | |
236 rank = GFC_DESCRIPTOR_RANK (array) - 1; | |
237 | |
238 | |
239 if (unlikely (dim < 0 || dim > rank)) | |
240 { | |
241 runtime_error ("Dim argument incorrect in MINVAL intrinsic: " | |
242 "is %ld, should be between 1 and %ld", | |
243 (long int) dim + 1, (long int) rank + 1); | |
244 } | |
245 | |
246 len = GFC_DESCRIPTOR_EXTENT(array,dim); | |
247 if (len <= 0) | |
248 return; | |
249 | |
250 mbase = mask->base_addr; | |
251 | |
252 mask_kind = GFC_DESCRIPTOR_SIZE (mask); | |
253 | |
254 if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 | |
255 #ifdef HAVE_GFC_LOGICAL_16 | |
256 || mask_kind == 16 | |
257 #endif | |
258 ) | |
259 mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); | |
260 else | |
261 runtime_error ("Funny sized logical array"); | |
262 | |
263 delta = GFC_DESCRIPTOR_STRIDE(array,dim); | |
264 mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim); | |
265 | |
266 for (n = 0; n < dim; n++) | |
267 { | |
268 sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n); | |
269 mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); | |
270 extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); | |
271 | |
272 if (extent[n] < 0) | |
273 extent[n] = 0; | |
274 | |
275 } | |
276 for (n = dim; n < rank; n++) | |
277 { | |
278 sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1); | |
279 mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1); | |
280 extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); | |
281 | |
282 if (extent[n] < 0) | |
283 extent[n] = 0; | |
284 } | |
285 | |
286 if (retarray->base_addr == NULL) | |
287 { | |
288 size_t alloc_size, str; | |
289 | |
290 for (n = 0; n < rank; n++) | |
291 { | |
292 if (n == 0) | |
293 str = 1; | |
294 else | |
295 str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; | |
296 | |
297 GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); | |
298 | |
299 } | |
300 | |
301 alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]; | |
302 | |
303 retarray->offset = 0; | |
304 retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; | |
305 | |
306 if (alloc_size == 0) | |
307 { | |
308 /* Make sure we have a zero-sized array. */ | |
309 GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); | |
310 return; | |
311 } | |
312 else | |
313 retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_4)); | |
314 | |
315 } | |
316 else | |
317 { | |
318 if (rank != GFC_DESCRIPTOR_RANK (retarray)) | |
319 runtime_error ("rank of return array incorrect in MINVAL intrinsic"); | |
320 | |
321 if (unlikely (compile_options.bounds_check)) | |
322 { | |
323 bounds_ifunction_return ((array_t *) retarray, extent, | |
324 "return value", "MINVAL"); | |
325 bounds_equal_extents ((array_t *) mask, (array_t *) array, | |
326 "MASK argument", "MINVAL"); | |
327 } | |
328 } | |
329 | |
330 for (n = 0; n < rank; n++) | |
331 { | |
332 count[n] = 0; | |
333 dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); | |
334 if (extent[n] <= 0) | |
335 return; | |
336 } | |
337 | |
338 dest = retarray->base_addr; | |
339 base = array->base_addr; | |
340 | |
341 while (base) | |
342 { | |
343 const GFC_INTEGER_4 * restrict src; | |
344 const GFC_LOGICAL_1 * restrict msrc; | |
345 GFC_INTEGER_4 result; | |
346 src = base; | |
347 msrc = mbase; | |
348 { | |
349 | |
350 #if defined (GFC_INTEGER_4_INFINITY) | |
351 result = GFC_INTEGER_4_INFINITY; | |
352 #else | |
353 result = GFC_INTEGER_4_HUGE; | |
354 #endif | |
355 #if defined (GFC_INTEGER_4_QUIET_NAN) | |
356 int non_empty_p = 0; | |
357 #endif | |
358 for (n = 0; n < len; n++, src += delta, msrc += mdelta) | |
359 { | |
360 | |
361 #if defined (GFC_INTEGER_4_INFINITY) || defined (GFC_INTEGER_4_QUIET_NAN) | |
362 if (*msrc) | |
363 { | |
364 #if defined (GFC_INTEGER_4_QUIET_NAN) | |
365 non_empty_p = 1; | |
366 if (*src <= result) | |
367 #endif | |
368 break; | |
369 } | |
370 } | |
371 if (unlikely (n >= len)) | |
372 { | |
373 #if defined (GFC_INTEGER_4_QUIET_NAN) | |
374 result = non_empty_p ? GFC_INTEGER_4_QUIET_NAN : GFC_INTEGER_4_HUGE; | |
375 #else | |
376 result = GFC_INTEGER_4_HUGE; | |
377 #endif | |
378 } | |
379 else for (; n < len; n++, src += delta, msrc += mdelta) | |
380 { | |
381 #endif | |
382 if (*msrc && *src < result) | |
383 result = *src; | |
384 } | |
385 *dest = result; | |
386 } | |
387 /* Advance to the next element. */ | |
388 count[0]++; | |
389 base += sstride[0]; | |
390 mbase += mstride[0]; | |
391 dest += dstride[0]; | |
392 n = 0; | |
393 while (count[n] == extent[n]) | |
394 { | |
395 /* When we get to the end of a dimension, reset it and increment | |
396 the next dimension. */ | |
397 count[n] = 0; | |
398 /* We could precalculate these products, but this is a less | |
399 frequently used path so probably not worth it. */ | |
400 base -= sstride[n] * extent[n]; | |
401 mbase -= mstride[n] * extent[n]; | |
402 dest -= dstride[n] * extent[n]; | |
403 n++; | |
404 if (n >= rank) | |
405 { | |
406 /* Break out of the loop. */ | |
407 base = NULL; | |
408 break; | |
409 } | |
410 else | |
411 { | |
412 count[n]++; | |
413 base += sstride[n]; | |
414 mbase += mstride[n]; | |
415 dest += dstride[n]; | |
416 } | |
417 } | |
418 } | |
419 } | |
420 | |
421 | |
422 extern void sminval_i4 (gfc_array_i4 * const restrict, | |
423 gfc_array_i4 * const restrict, const index_type * const restrict, | |
424 GFC_LOGICAL_4 *); | |
425 export_proto(sminval_i4); | |
426 | |
427 void | |
428 sminval_i4 (gfc_array_i4 * const restrict retarray, | |
429 gfc_array_i4 * const restrict array, | |
430 const index_type * const restrict pdim, | |
431 GFC_LOGICAL_4 * mask) | |
432 { | |
433 index_type count[GFC_MAX_DIMENSIONS]; | |
434 index_type extent[GFC_MAX_DIMENSIONS]; | |
435 index_type dstride[GFC_MAX_DIMENSIONS]; | |
436 GFC_INTEGER_4 * restrict dest; | |
437 index_type rank; | |
438 index_type n; | |
439 index_type dim; | |
440 | |
441 | |
442 if (*mask) | |
443 { | |
444 minval_i4 (retarray, array, pdim); | |
445 return; | |
446 } | |
447 /* Make dim zero based to avoid confusion. */ | |
448 dim = (*pdim) - 1; | |
449 rank = GFC_DESCRIPTOR_RANK (array) - 1; | |
450 | |
451 if (unlikely (dim < 0 || dim > rank)) | |
452 { | |
453 runtime_error ("Dim argument incorrect in MINVAL intrinsic: " | |
454 "is %ld, should be between 1 and %ld", | |
455 (long int) dim + 1, (long int) rank + 1); | |
456 } | |
457 | |
458 for (n = 0; n < dim; n++) | |
459 { | |
460 extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); | |
461 | |
462 if (extent[n] <= 0) | |
463 extent[n] = 0; | |
464 } | |
465 | |
466 for (n = dim; n < rank; n++) | |
467 { | |
468 extent[n] = | |
469 GFC_DESCRIPTOR_EXTENT(array,n + 1); | |
470 | |
471 if (extent[n] <= 0) | |
472 extent[n] = 0; | |
473 } | |
474 | |
475 if (retarray->base_addr == NULL) | |
476 { | |
477 size_t alloc_size, str; | |
478 | |
479 for (n = 0; n < rank; n++) | |
480 { | |
481 if (n == 0) | |
482 str = 1; | |
483 else | |
484 str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; | |
485 | |
486 GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); | |
487 | |
488 } | |
489 | |
490 retarray->offset = 0; | |
491 retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; | |
492 | |
493 alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1]; | |
494 | |
495 if (alloc_size == 0) | |
496 { | |
497 /* Make sure we have a zero-sized array. */ | |
498 GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); | |
499 return; | |
500 } | |
501 else | |
502 retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_INTEGER_4)); | |
503 } | |
504 else | |
505 { | |
506 if (rank != GFC_DESCRIPTOR_RANK (retarray)) | |
507 runtime_error ("rank of return array incorrect in" | |
508 " MINVAL intrinsic: is %ld, should be %ld", | |
509 (long int) (GFC_DESCRIPTOR_RANK (retarray)), | |
510 (long int) rank); | |
511 | |
512 if (unlikely (compile_options.bounds_check)) | |
513 { | |
514 for (n=0; n < rank; n++) | |
515 { | |
516 index_type ret_extent; | |
517 | |
518 ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); | |
519 if (extent[n] != ret_extent) | |
520 runtime_error ("Incorrect extent in return value of" | |
521 " MINVAL intrinsic in dimension %ld:" | |
522 " is %ld, should be %ld", (long int) n + 1, | |
523 (long int) ret_extent, (long int) extent[n]); | |
524 } | |
525 } | |
526 } | |
527 | |
528 for (n = 0; n < rank; n++) | |
529 { | |
530 count[n] = 0; | |
531 dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n); | |
532 } | |
533 | |
534 dest = retarray->base_addr; | |
535 | |
536 while(1) | |
537 { | |
538 *dest = GFC_INTEGER_4_HUGE; | |
539 count[0]++; | |
540 dest += dstride[0]; | |
541 n = 0; | |
542 while (count[n] == extent[n]) | |
543 { | |
544 /* When we get to the end of a dimension, reset it and increment | |
545 the next dimension. */ | |
546 count[n] = 0; | |
547 /* We could precalculate these products, but this is a less | |
548 frequently used path so probably not worth it. */ | |
549 dest -= dstride[n] * extent[n]; | |
550 n++; | |
551 if (n >= rank) | |
552 return; | |
553 else | |
554 { | |
555 count[n]++; | |
556 dest += dstride[n]; | |
557 } | |
558 } | |
559 } | |
560 } | |
561 | |
562 #endif |