1 /* Implementation of the MAXVAL intrinsic
2 Copyright 2002, 2007, 2009, 2010 Free Software Foundation, Inc.
3 Contributed by Paul Brook <paul@nowt.org>
5 This file is part of the GNU Fortran runtime library (libgfortran).
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.
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.
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.
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/>. */
26 #include "libgfortran.h"
31 #if defined (HAVE_GFC_INTEGER_16) && defined (HAVE_GFC_INTEGER_16)
34 extern void maxval_i16 (gfc_array_i16
* const restrict
,
35 gfc_array_i16
* const restrict
, const index_type
* const restrict
);
36 export_proto(maxval_i16
);
39 maxval_i16 (gfc_array_i16
* const restrict retarray
,
40 gfc_array_i16
* const restrict array
,
41 const index_type
* const restrict pdim
)
43 index_type count
[GFC_MAX_DIMENSIONS
];
44 index_type extent
[GFC_MAX_DIMENSIONS
];
45 index_type sstride
[GFC_MAX_DIMENSIONS
];
46 index_type dstride
[GFC_MAX_DIMENSIONS
];
47 const GFC_INTEGER_16
* restrict base
;
48 GFC_INTEGER_16
* restrict dest
;
56 /* Make dim zero based to avoid confusion. */
58 rank
= GFC_DESCRIPTOR_RANK (array
) - 1;
60 len
= GFC_DESCRIPTOR_EXTENT(array
,dim
);
63 delta
= GFC_DESCRIPTOR_STRIDE(array
,dim
);
65 for (n
= 0; n
< dim
; n
++)
67 sstride
[n
] = GFC_DESCRIPTOR_STRIDE(array
,n
);
68 extent
[n
] = GFC_DESCRIPTOR_EXTENT(array
,n
);
73 for (n
= dim
; n
< rank
; n
++)
75 sstride
[n
] = GFC_DESCRIPTOR_STRIDE(array
, n
+ 1);
76 extent
[n
] = GFC_DESCRIPTOR_EXTENT(array
, n
+ 1);
82 if (retarray
->base_addr
== NULL
)
84 size_t alloc_size
, str
;
86 for (n
= 0; n
< rank
; n
++)
91 str
= GFC_DESCRIPTOR_STRIDE(retarray
,n
-1) * extent
[n
-1];
93 GFC_DIMENSION_SET(retarray
->dim
[n
], 0, extent
[n
] - 1, str
);
98 retarray
->dtype
= (array
->dtype
& ~GFC_DTYPE_RANK_MASK
) | rank
;
100 alloc_size
= sizeof (GFC_INTEGER_16
) * GFC_DESCRIPTOR_STRIDE(retarray
,rank
-1)
103 retarray
->base_addr
= xmalloc (alloc_size
);
106 /* Make sure we have a zero-sized array. */
107 GFC_DIMENSION_SET(retarray
->dim
[0], 0, -1, 1);
114 if (rank
!= GFC_DESCRIPTOR_RANK (retarray
))
115 runtime_error ("rank of return array incorrect in"
116 " MAXVAL intrinsic: is %ld, should be %ld",
117 (long int) (GFC_DESCRIPTOR_RANK (retarray
)),
120 if (unlikely (compile_options
.bounds_check
))
121 bounds_ifunction_return ((array_t
*) retarray
, extent
,
122 "return value", "MAXVAL");
125 for (n
= 0; n
< rank
; n
++)
128 dstride
[n
] = GFC_DESCRIPTOR_STRIDE(retarray
,n
);
133 base
= array
->base_addr
;
134 dest
= retarray
->base_addr
;
137 while (continue_loop
)
139 const GFC_INTEGER_16
* restrict src
;
140 GFC_INTEGER_16 result
;
144 #if defined (GFC_INTEGER_16_INFINITY)
145 result
= -GFC_INTEGER_16_INFINITY
;
147 result
= (-GFC_INTEGER_16_HUGE
-1);
150 *dest
= (-GFC_INTEGER_16_HUGE
-1);
153 for (n
= 0; n
< len
; n
++, src
+= delta
)
156 #if defined (GFC_INTEGER_16_QUIET_NAN)
160 if (unlikely (n
>= len
))
161 result
= GFC_INTEGER_16_QUIET_NAN
;
162 else for (; n
< len
; n
++, src
+= delta
)
172 /* Advance to the next element. */
177 while (count
[n
] == extent
[n
])
179 /* When we get to the end of a dimension, reset it and increment
180 the next dimension. */
182 /* We could precalculate these products, but this is a less
183 frequently used path so probably not worth it. */
184 base
-= sstride
[n
] * extent
[n
];
185 dest
-= dstride
[n
] * extent
[n
];
189 /* Break out of the look. */
204 extern void mmaxval_i16 (gfc_array_i16
* const restrict
,
205 gfc_array_i16
* const restrict
, const index_type
* const restrict
,
206 gfc_array_l1
* const restrict
);
207 export_proto(mmaxval_i16
);
210 mmaxval_i16 (gfc_array_i16
* const restrict retarray
,
211 gfc_array_i16
* const restrict array
,
212 const index_type
* const restrict pdim
,
213 gfc_array_l1
* const restrict mask
)
215 index_type count
[GFC_MAX_DIMENSIONS
];
216 index_type extent
[GFC_MAX_DIMENSIONS
];
217 index_type sstride
[GFC_MAX_DIMENSIONS
];
218 index_type dstride
[GFC_MAX_DIMENSIONS
];
219 index_type mstride
[GFC_MAX_DIMENSIONS
];
220 GFC_INTEGER_16
* restrict dest
;
221 const GFC_INTEGER_16
* restrict base
;
222 const GFC_LOGICAL_1
* restrict mbase
;
232 rank
= GFC_DESCRIPTOR_RANK (array
) - 1;
234 len
= GFC_DESCRIPTOR_EXTENT(array
,dim
);
238 mbase
= mask
->base_addr
;
240 mask_kind
= GFC_DESCRIPTOR_SIZE (mask
);
242 if (mask_kind
== 1 || mask_kind
== 2 || mask_kind
== 4 || mask_kind
== 8
243 #ifdef HAVE_GFC_LOGICAL_16
247 mbase
= GFOR_POINTER_TO_L1 (mbase
, mask_kind
);
249 runtime_error ("Funny sized logical array");
251 delta
= GFC_DESCRIPTOR_STRIDE(array
,dim
);
252 mdelta
= GFC_DESCRIPTOR_STRIDE_BYTES(mask
,dim
);
254 for (n
= 0; n
< dim
; n
++)
256 sstride
[n
] = GFC_DESCRIPTOR_STRIDE(array
,n
);
257 mstride
[n
] = GFC_DESCRIPTOR_STRIDE_BYTES(mask
,n
);
258 extent
[n
] = GFC_DESCRIPTOR_EXTENT(array
,n
);
264 for (n
= dim
; n
< rank
; n
++)
266 sstride
[n
] = GFC_DESCRIPTOR_STRIDE(array
,n
+ 1);
267 mstride
[n
] = GFC_DESCRIPTOR_STRIDE_BYTES(mask
, n
+ 1);
268 extent
[n
] = GFC_DESCRIPTOR_EXTENT(array
, n
+ 1);
274 if (retarray
->base_addr
== NULL
)
276 size_t alloc_size
, str
;
278 for (n
= 0; n
< rank
; n
++)
283 str
= GFC_DESCRIPTOR_STRIDE(retarray
,n
-1) * extent
[n
-1];
285 GFC_DIMENSION_SET(retarray
->dim
[n
], 0, extent
[n
] - 1, str
);
289 alloc_size
= sizeof (GFC_INTEGER_16
) * GFC_DESCRIPTOR_STRIDE(retarray
,rank
-1)
292 retarray
->offset
= 0;
293 retarray
->dtype
= (array
->dtype
& ~GFC_DTYPE_RANK_MASK
) | rank
;
297 /* Make sure we have a zero-sized array. */
298 GFC_DIMENSION_SET(retarray
->dim
[0], 0, -1, 1);
302 retarray
->base_addr
= xmalloc (alloc_size
);
307 if (rank
!= GFC_DESCRIPTOR_RANK (retarray
))
308 runtime_error ("rank of return array incorrect in MAXVAL intrinsic");
310 if (unlikely (compile_options
.bounds_check
))
312 bounds_ifunction_return ((array_t
*) retarray
, extent
,
313 "return value", "MAXVAL");
314 bounds_equal_extents ((array_t
*) mask
, (array_t
*) array
,
315 "MASK argument", "MAXVAL");
319 for (n
= 0; n
< rank
; n
++)
322 dstride
[n
] = GFC_DESCRIPTOR_STRIDE(retarray
,n
);
327 dest
= retarray
->base_addr
;
328 base
= array
->base_addr
;
332 const GFC_INTEGER_16
* restrict src
;
333 const GFC_LOGICAL_1
* restrict msrc
;
334 GFC_INTEGER_16 result
;
339 #if defined (GFC_INTEGER_16_INFINITY)
340 result
= -GFC_INTEGER_16_INFINITY
;
342 result
= (-GFC_INTEGER_16_HUGE
-1);
344 #if defined (GFC_INTEGER_16_QUIET_NAN)
347 for (n
= 0; n
< len
; n
++, src
+= delta
, msrc
+= mdelta
)
350 #if defined (GFC_INTEGER_16_INFINITY) || defined (GFC_INTEGER_16_QUIET_NAN)
353 #if defined (GFC_INTEGER_16_QUIET_NAN)
360 if (unlikely (n
>= len
))
362 #if defined (GFC_INTEGER_16_QUIET_NAN)
363 result
= non_empty_p
? GFC_INTEGER_16_QUIET_NAN
: (-GFC_INTEGER_16_HUGE
-1);
365 result
= (-GFC_INTEGER_16_HUGE
-1);
368 else for (; n
< len
; n
++, src
+= delta
, msrc
+= mdelta
)
371 if (*msrc
&& *src
> result
)
376 /* Advance to the next element. */
382 while (count
[n
] == extent
[n
])
384 /* When we get to the end of a dimension, reset it and increment
385 the next dimension. */
387 /* We could precalculate these products, but this is a less
388 frequently used path so probably not worth it. */
389 base
-= sstride
[n
] * extent
[n
];
390 mbase
-= mstride
[n
] * extent
[n
];
391 dest
-= dstride
[n
] * extent
[n
];
395 /* Break out of the look. */
411 extern void smaxval_i16 (gfc_array_i16
* const restrict
,
412 gfc_array_i16
* const restrict
, const index_type
* const restrict
,
414 export_proto(smaxval_i16
);
417 smaxval_i16 (gfc_array_i16
* const restrict retarray
,
418 gfc_array_i16
* const restrict array
,
419 const index_type
* const restrict pdim
,
420 GFC_LOGICAL_4
* mask
)
422 index_type count
[GFC_MAX_DIMENSIONS
];
423 index_type extent
[GFC_MAX_DIMENSIONS
];
424 index_type dstride
[GFC_MAX_DIMENSIONS
];
425 GFC_INTEGER_16
* restrict dest
;
433 maxval_i16 (retarray
, array
, pdim
);
436 /* Make dim zero based to avoid confusion. */
438 rank
= GFC_DESCRIPTOR_RANK (array
) - 1;
440 for (n
= 0; n
< dim
; n
++)
442 extent
[n
] = GFC_DESCRIPTOR_EXTENT(array
,n
);
448 for (n
= dim
; n
< rank
; n
++)
451 GFC_DESCRIPTOR_EXTENT(array
,n
+ 1);
457 if (retarray
->base_addr
== NULL
)
459 size_t alloc_size
, str
;
461 for (n
= 0; n
< rank
; n
++)
466 str
= GFC_DESCRIPTOR_STRIDE(retarray
,n
-1) * extent
[n
-1];
468 GFC_DIMENSION_SET(retarray
->dim
[n
], 0, extent
[n
] - 1, str
);
472 retarray
->offset
= 0;
473 retarray
->dtype
= (array
->dtype
& ~GFC_DTYPE_RANK_MASK
) | rank
;
475 alloc_size
= sizeof (GFC_INTEGER_16
) * GFC_DESCRIPTOR_STRIDE(retarray
,rank
-1)
480 /* Make sure we have a zero-sized array. */
481 GFC_DIMENSION_SET(retarray
->dim
[0], 0, -1, 1);
485 retarray
->base_addr
= xmalloc (alloc_size
);
489 if (rank
!= GFC_DESCRIPTOR_RANK (retarray
))
490 runtime_error ("rank of return array incorrect in"
491 " MAXVAL intrinsic: is %ld, should be %ld",
492 (long int) (GFC_DESCRIPTOR_RANK (retarray
)),
495 if (unlikely (compile_options
.bounds_check
))
497 for (n
=0; n
< rank
; n
++)
499 index_type ret_extent
;
501 ret_extent
= GFC_DESCRIPTOR_EXTENT(retarray
,n
);
502 if (extent
[n
] != ret_extent
)
503 runtime_error ("Incorrect extent in return value of"
504 " MAXVAL intrinsic in dimension %ld:"
505 " is %ld, should be %ld", (long int) n
+ 1,
506 (long int) ret_extent
, (long int) extent
[n
]);
511 for (n
= 0; n
< rank
; n
++)
514 dstride
[n
] = GFC_DESCRIPTOR_STRIDE(retarray
,n
);
517 dest
= retarray
->base_addr
;
521 *dest
= (-GFC_INTEGER_16_HUGE
-1);
525 while (count
[n
] == extent
[n
])
527 /* When we get to the end of a dimension, reset it and increment
528 the next dimension. */
530 /* We could precalculate these products, but this is a less
531 frequently used path so probably not worth it. */
532 dest
-= dstride
[n
] * extent
[n
];