diff options
Diffstat (limited to 'libgfortran/m4')
| -rw-r--r-- | libgfortran/m4/iforeach-s2.m4 | 222 | ||||
| -rw-r--r-- | libgfortran/m4/ifunction-s2.m4 | 542 | ||||
| -rw-r--r-- | libgfortran/m4/iparm.m4 | 1 | ||||
| -rw-r--r-- | libgfortran/m4/maxval0s.m4 | 58 | ||||
| -rw-r--r-- | libgfortran/m4/maxval1s.m4 | 61 | ||||
| -rw-r--r-- | libgfortran/m4/minval0s.m4 | 58 | ||||
| -rw-r--r-- | libgfortran/m4/minval1s.m4 | 61 |
7 files changed, 1003 insertions, 0 deletions
diff --git a/libgfortran/m4/iforeach-s2.m4 b/libgfortran/m4/iforeach-s2.m4 new file mode 100644 index 00000000000..19d016f7c65 --- /dev/null +++ b/libgfortran/m4/iforeach-s2.m4 @@ -0,0 +1,222 @@ +dnl Support macro file for intrinsic functions. +dnl Contains the generic sections of the array functions. +dnl This file is part of the GNU Fortran Runtime Library (libgfortran) +dnl Distributed under the GNU GPL with exception. See COPYING for details. +define(START_FOREACH_FUNCTION, +`static inline int +compare_fcn (const atype_name *a, const atype_name *b, gfc_charlen_type n) +{ + if (sizeof ('atype_name`) == 1) + return memcmp (a, b, n); + else + return memcmp_char4 (a, b, n); + +} + +#define INITVAL 'initval` + +extern void 'name`'rtype_qual`_'atype_code (atype_name * restrict, + gfc_charlen_type, + atype * const restrict array, gfc_charlen_type); +export_proto(name`'rtype_qual`_'atype_code); + +void +name`'rtype_qual`_'atype_code` ('atype_name` * restrict ret, + gfc_charlen_type xlen, + 'atype` * const restrict array, gfc_charlen_type len) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + const 'atype_name` *base; + index_type rank; + index_type n; + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + assert (xlen == len); + + /* Initialize return value. */ + memset (ret, INITVAL, sizeof(*ret) * len); + + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n) * len; + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + count[n] = 0; + if (extent[n] <= 0) + return; + } + + base = array->base_addr; + + { +')dnl +define(START_FOREACH_BLOCK, +` while (base) + { + do + { + /* Implementation start. */ +')dnl +define(FINISH_FOREACH_FUNCTION, +` /* Implementation end. */ + /* Advance to the next element. */ + base += sstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + } + } + while (count[n] == extent[n]); + } + memcpy (ret, retval, len * sizeof (*ret)); + } +}')dnl +define(START_MASKED_FOREACH_FUNCTION, +` +extern void `m'name`'rtype_qual`_'atype_code (atype_name * restrict, + gfc_charlen_type, atype * const restrict array, + gfc_array_l1 * const restrict mask, gfc_charlen_type len); +export_proto(`m'name`'rtype_qual`_'atype_code); + +void +`m'name`'rtype_qual`_'atype_code (atype_name * const restrict ret, + gfc_charlen_type xlen, atype * const restrict array, + gfc_array_l1 * const restrict mask, gfc_charlen_type len) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type mstride[GFC_MAX_DIMENSIONS]; + const atype_name *base; + GFC_LOGICAL_1 *mbase; + int rank; + index_type n; + int mask_kind; + + rank = GFC_DESCRIPTOR_RANK (array); + if (rank <= 0) + runtime_error ("Rank of array needs to be > 0"); + + assert (xlen == len); + +/* Initialize return value. */ + memset (ret, INITVAL, sizeof(*ret) * len); + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + mbase = mask->base_addr; + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + for (n = 0; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n) * len; + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + count[n] = 0; + if (extent[n] <= 0) + return; + } + + base = array->base_addr; + { +')dnl +define(START_MASKED_FOREACH_BLOCK, `START_FOREACH_BLOCK')dnl +define(FINISH_MASKED_FOREACH_FUNCTION, +` /* Implementation end. */ + /* Advance to the next element. */ + base += sstride[0]; + mbase += mstride[0]; + } + while (++count[0] != extent[0]); + n = 0; + do + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + mbase -= mstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + mbase += mstride[n]; + } + } + while (count[n] == extent[n]); + } + memcpy (ret, retval, len * sizeof (*ret)); + } +}')dnl +define(FOREACH_FUNCTION, +`START_FOREACH_FUNCTION +$1 +START_FOREACH_BLOCK +$2 +FINISH_FOREACH_FUNCTION')dnl +define(MASKED_FOREACH_FUNCTION, +`START_MASKED_FOREACH_FUNCTION +$1 +START_MASKED_FOREACH_BLOCK +$2 +FINISH_MASKED_FOREACH_FUNCTION')dnl +define(SCALAR_FOREACH_FUNCTION, +` +extern void `s'name`'rtype_qual`_'atype_code (atype_name * restrict, + gfc_charlen_type, + atype * const restrict array, GFC_LOGICAL_4 *, gfc_charlen_type); +export_proto(`s'name`'rtype_qual`_'atype_code); + +void +`s'name`'rtype_qual`_'atype_code (atype_name * restrict ret, + gfc_charlen_type xlen, atype * const restrict array, + GFC_LOGICAL_4 *mask, gfc_charlen_type len) + +{ + if (*mask) + { + name`'rtype_qual`_'atype_code (ret, xlen, array, len); + return; + } + memset (ret, INITVAL, sizeof (*ret) * len); +}')dnl diff --git a/libgfortran/m4/ifunction-s2.m4 b/libgfortran/m4/ifunction-s2.m4 new file mode 100644 index 00000000000..4eb09084dde --- /dev/null +++ b/libgfortran/m4/ifunction-s2.m4 @@ -0,0 +1,542 @@ +dnl Support macro file for intrinsic functions. +dnl Contains the generic sections of the array functions. +dnl This file is part of the GNU Fortran Runtime Library (libgfortran) +dnl Distributed under the GNU GPL with exception. See COPYING for details. +dnl +dnl Pass the implementation for a single section as the parameter to +dnl {MASK_}ARRAY_FUNCTION. +dnl The variables base, delta, and len describe the input section. +dnl For masked section the mask is described by mbase and mdelta. +dnl These should not be modified. The result should be stored in *dest. +dnl The names count, extent, sstride, dstride, base, dest, rank, dim +dnl retarray, array, pdim and mstride should not be used. +dnl The variable n is declared as index_type and may be used. +dnl Other variable declarations may be placed at the start of the code, +dnl The types of the array parameter and the return value are +dnl atype_name and rtype_name respectively. +dnl Execution should be allowed to continue to the end of the block. +dnl You should not return or break from the inner loop of the implementation. +dnl Care should also be taken to avoid using the names defined in iparm.m4 +define(START_ARRAY_FUNCTION, +`#include <string.h> +#include <assert.h> + +static inline int +compare_fcn (const atype_name *a, const atype_name *b, gfc_charlen_type n) +{ + if (sizeof ('atype_name`) == 1) + return memcmp (a, b, n); + else + return memcmp_char4 (a, b, n); +} + +extern void name`'rtype_qual`_'atype_code (rtype * const restrict, + gfc_charlen_type, atype * const restrict, + const index_type * const restrict, gfc_charlen_type); +export_proto(name`'rtype_qual`_'atype_code); + +void +name`'rtype_qual`_'atype_code (rtype * const restrict retarray, + gfc_charlen_type xlen, atype * const restrict array, + const index_type * const restrict pdim, gfc_charlen_type string_len) +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + const atype_name * restrict base; + rtype_name * restrict dest; + index_type rank; + index_type n; + index_type len; + index_type delta; + index_type dim; + int continue_loop; + + assert (xlen == string_len); + /* Make dim zero based to avoid confusion. */ + rank = GFC_DESCRIPTOR_RANK (array) - 1; + dim = (*pdim) - 1; + + if (unlikely (dim < 0 || dim > rank)) + { + runtime_error ("Dim argument incorrect in u_name intrinsic: " + "is %ld, should be between 1 and %ld", + (long int) dim + 1, (long int) rank + 1); + } + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len < 0) + len = 0; + + delta = GFC_DESCRIPTOR_STRIDE(array,dim) * string_len; + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n) * string_len; + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array, n + 1) * string_len; + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->base_addr == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1] + * string_len; + + retarray->base_addr = xmallocarray (alloc_size, sizeof (rtype_name)); + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + + } + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " u_name intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "u_name"); + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n) * string_len; + if (extent[n] <= 0) + return; + } + + base = array->base_addr; + dest = retarray->base_addr; + + continue_loop = 1; + while (continue_loop) + { + const atype_name * restrict src; + src = base; + { +')dnl +define(START_ARRAY_BLOCK, +` if (len <= 0) + memset (dest, '$1`, sizeof (*dest) * string_len); + else + { + for (n = 0; n < len; n++, src += delta) + { +')dnl +define(FINISH_ARRAY_FUNCTION, +` } + '$1` + memcpy (dest, retval, sizeof (*dest) * string_len); + } + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + continue_loop = 0; + break; + } + else + { + count[n]++; + base += sstride[n]; + dest += dstride[n]; + } + } + } +}')dnl +define(START_MASKED_ARRAY_FUNCTION, +` +extern void `m'name`'rtype_qual`_'atype_code (rtype * const restrict, + gfc_charlen_type, atype * const restrict, + const index_type * const restrict, + gfc_array_l1 * const restrict, gfc_charlen_type); +export_proto(`m'name`'rtype_qual`_'atype_code); + +void +`m'name`'rtype_qual`_'atype_code (rtype * const restrict retarray, + gfc_charlen_type xlen, atype * const restrict array, + const index_type * const restrict pdim, + gfc_array_l1 * const restrict mask, + gfc_charlen_type string_len) + +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type sstride[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + index_type mstride[GFC_MAX_DIMENSIONS]; + rtype_name * restrict dest; + const atype_name * restrict base; + const GFC_LOGICAL_1 * restrict mbase; + index_type rank; + index_type dim; + index_type n; + index_type len; + index_type delta; + index_type mdelta; + int mask_kind; + + assert (xlen == string_len); + + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + if (unlikely (dim < 0 || dim > rank)) + { + runtime_error ("Dim argument incorrect in u_name intrinsic: " + "is %ld, should be between 1 and %ld", + (long int) dim + 1, (long int) rank + 1); + } + + len = GFC_DESCRIPTOR_EXTENT(array,dim); + if (len <= 0) + return; + + mbase = mask->base_addr; + + mask_kind = GFC_DESCRIPTOR_SIZE (mask); + + if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 +#ifdef HAVE_GFC_LOGICAL_16 + || mask_kind == 16 +#endif + ) + mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); + else + runtime_error ("Funny sized logical array"); + + delta = GFC_DESCRIPTOR_STRIDE(array,dim) * string_len; + mdelta = GFC_DESCRIPTOR_STRIDE_BYTES(mask,dim); + + for (n = 0; n < dim; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n) * string_len; + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n); + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] < 0) + extent[n] = 0; + + } + for (n = dim; n < rank; n++) + { + sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n + 1) * string_len; + mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask, n + 1); + extent[n] = GFC_DESCRIPTOR_EXTENT(array, n + 1); + + if (extent[n] < 0) + extent[n] = 0; + } + + if (retarray->base_addr == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str= GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1] + * string_len; + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->base_addr = xmallocarray (alloc_size, sizeof (rtype_name)); + + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in u_name intrinsic"); + + if (unlikely (compile_options.bounds_check)) + { + bounds_ifunction_return ((array_t *) retarray, extent, + "return value", "u_name"); + bounds_equal_extents ((array_t *) mask, (array_t *) array, + "MASK argument", "u_name"); + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n) * string_len; + if (extent[n] <= 0) + return; + } + + dest = retarray->base_addr; + base = array->base_addr; + + while (base) + { + const atype_name * restrict src; + const GFC_LOGICAL_1 * restrict msrc; + + src = base; + msrc = mbase; + { +')dnl +define(START_MASKED_ARRAY_BLOCK, +` for (n = 0; n < len; n++, src += delta, msrc += mdelta) + { +')dnl +define(FINISH_MASKED_ARRAY_FUNCTION, +` } + memcpy (dest, retval, sizeof (*dest) * string_len); + } + /* Advance to the next element. */ + count[0]++; + base += sstride[0]; + mbase += mstride[0]; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + base -= sstride[n] * extent[n]; + mbase -= mstride[n] * extent[n]; + dest -= dstride[n] * extent[n]; + n++; + if (n >= rank) + { + /* Break out of the loop. */ + base = NULL; + break; + } + else + { + count[n]++; + base += sstride[n]; + mbase += mstride[n]; + dest += dstride[n]; + } + } + } +}')dnl +define(SCALAR_ARRAY_FUNCTION, +` +void `s'name`'rtype_qual`_'atype_code (rtype * const restrict, + gfc_charlen_type, atype * const restrict, + const index_type * const restrict, + GFC_LOGICAL_4 *, gfc_charlen_type); + +export_proto(`s'name`'rtype_qual`_'atype_code); + +void +`s'name`'rtype_qual`_'atype_code (rtype * const restrict retarray, + gfc_charlen_type xlen, atype * const restrict array, + const index_type * const restrict pdim, + GFC_LOGICAL_4 *mask, gfc_charlen_type string_len) + +{ + index_type count[GFC_MAX_DIMENSIONS]; + index_type extent[GFC_MAX_DIMENSIONS]; + index_type dstride[GFC_MAX_DIMENSIONS]; + rtype_name * restrict dest; + index_type rank; + index_type n; + index_type dim; + + + if (*mask) + { + name`'rtype_qual`_'atype_code (retarray, xlen, array, pdim, string_len); + return; + } + /* Make dim zero based to avoid confusion. */ + dim = (*pdim) - 1; + rank = GFC_DESCRIPTOR_RANK (array) - 1; + + if (unlikely (dim < 0 || dim > rank)) + { + runtime_error ("Dim argument incorrect in u_name intrinsic: " + "is %ld, should be between 1 and %ld", + (long int) dim + 1, (long int) rank + 1); + } + + for (n = 0; n < dim; n++) + { + extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); + + if (extent[n] <= 0) + extent[n] = 0; + } + + for (n = dim; n < rank; n++) + { + extent[n] = + GFC_DESCRIPTOR_EXTENT(array,n + 1); + + if (extent[n] <= 0) + extent[n] = 0; + } + + if (retarray->base_addr == NULL) + { + size_t alloc_size, str; + + for (n = 0; n < rank; n++) + { + if (n == 0) + str = 1; + else + str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1]; + + GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str); + + } + + retarray->offset = 0; + retarray->dtype = (array->dtype & ~GFC_DTYPE_RANK_MASK) | rank; + + alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1] + * string_len; + + if (alloc_size == 0) + { + /* Make sure we have a zero-sized array. */ + GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1); + return; + } + else + retarray->base_addr = xmallocarray (alloc_size, sizeof (rtype_name)); + } + else + { + if (rank != GFC_DESCRIPTOR_RANK (retarray)) + runtime_error ("rank of return array incorrect in" + " u_name intrinsic: is %ld, should be %ld", + (long int) (GFC_DESCRIPTOR_RANK (retarray)), + (long int) rank); + + if (unlikely (compile_options.bounds_check)) + { + for (n=0; n < rank; n++) + { + index_type ret_extent; + + ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n); + if (extent[n] != ret_extent) + runtime_error ("Incorrect extent in return value of" + " u_name intrinsic in dimension %ld:" + " is %ld, should be %ld", (long int) n + 1, + (long int) ret_extent, (long int) extent[n]); + } + } + } + + for (n = 0; n < rank; n++) + { + count[n] = 0; + dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n) * string_len; + } + + dest = retarray->base_addr; + + while(1) + { + memset (dest, '$1`, sizeof (*dest) * string_len); + count[0]++; + dest += dstride[0]; + n = 0; + while (count[n] == extent[n]) + { + /* When we get to the end of a dimension, reset it and increment + the next dimension. */ + count[n] = 0; + /* We could precalculate these products, but this is a less + frequently used path so probably not worth it. */ + dest -= dstride[n] * extent[n]; + n++; + if (n >= rank) + return; + else + { + count[n]++; + dest += dstride[n]; + } + } + } +}')dnl +define(ARRAY_FUNCTION, +`START_ARRAY_FUNCTION($1) +$2 +START_ARRAY_BLOCK($1) +$3 +FINISH_ARRAY_FUNCTION($4)')dnl +define(MASKED_ARRAY_FUNCTION, +`START_MASKED_ARRAY_FUNCTION +$2 +START_MASKED_ARRAY_BLOCK +$3 +FINISH_MASKED_ARRAY_FUNCTION')dnl diff --git a/libgfortran/m4/iparm.m4 b/libgfortran/m4/iparm.m4 index 4bf2a3010cf..a5596c98a16 100644 --- a/libgfortran/m4/iparm.m4 +++ b/libgfortran/m4/iparm.m4 @@ -35,3 +35,4 @@ define(name, regexp(regexp(file, `[^/]*$', `\&'), `^\([^_]*\)_', `\1'))dnl define(`upcase', `translit(`$*', `a-z', `A-Z')')dnl define(`u_name',`regexp(upcase(name),`\([A-Z]*\)',`\1')')dnl define(rtype_ccode,ifelse(rtype_letter,`i',rtype_kind,rtype_code))dnl +define(initval,ifelse(index(name,`maxval'),0,0,index(name,`minval'),0,255))dnl diff --git a/libgfortran/m4/maxval0s.m4 b/libgfortran/m4/maxval0s.m4 new file mode 100644 index 00000000000..eeb4d7b27e2 --- /dev/null +++ b/libgfortran/m4/maxval0s.m4 @@ -0,0 +1,58 @@ +`/* Implementation of the MAXLOC intrinsic + Copyright 2017 Free Software Foundation, Inc. + Contributed by Thomas Koenig + +This file is part of the GNU Fortran runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 3 of the License, or (at your option) any later version. + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +<http://www.gnu.org/licenses/>. */ + +#include "libgfortran.h" +#include <stdlib.h> +#include <string.h> +#include <assert.h> +#include <limits.h>' + +include(iparm.m4)dnl +include(iforeach-s2.m4)dnl + +`#if defined (HAVE_'atype_name`) && defined (HAVE_'rtype_name`)' + +FOREACH_FUNCTION( +` const atype_name *retval; + retval = ret;' +, +` if (compare_fcn (base, retval, len) > 0) + { + retval = base; + }') + +MASKED_FOREACH_FUNCTION( +` const atype_name *retval; + + retval = ret;' +, +` if (*mbase && compare_fcn (base, retval, len) > 0) + { + retval = base; + }') + +SCALAR_FOREACH_FUNCTION + +#endif diff --git a/libgfortran/m4/maxval1s.m4 b/libgfortran/m4/maxval1s.m4 new file mode 100644 index 00000000000..edf0ef1ba04 --- /dev/null +++ b/libgfortran/m4/maxval1s.m4 @@ -0,0 +1,61 @@ +`/* Implementation of the MAXVAL intrinsic + Copyright 2017 Free Software Foundation, Inc. + Contributed by Thomas Koenig + +This file is part of the GNU Fortran runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 3 of the License, or (at your option) any later version. + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +<http://www.gnu.org/licenses/>. */ + +#include "libgfortran.h"' + +include(iparm.m4)dnl +include(ifunction-s2.m4)dnl + +`#if defined (HAVE_'atype_name`) && defined (HAVE_'rtype_name`)' + +ARRAY_FUNCTION(0, +` const atype_name *retval; + retval = base;', +` if (compare_fcn (src, retval, string_len) > 0) + { + retval = src; + }', `') + +MASKED_ARRAY_FUNCTION(0, +` const atype_name *retval; + memset (dest, 0, sizeof (*dest) * string_len); + retval = dest;', +` if (*msrc) + { + retval = src; + break; + } + } + for (; n < len; n++, src += delta, msrc += mdelta) + { + if (*msrc && compare_fcn (src, retval, string_len) > 0) + { + retval = src; + } + ') + +SCALAR_ARRAY_FUNCTION(0) + +#endif diff --git a/libgfortran/m4/minval0s.m4 b/libgfortran/m4/minval0s.m4 new file mode 100644 index 00000000000..0bcf543503a --- /dev/null +++ b/libgfortran/m4/minval0s.m4 @@ -0,0 +1,58 @@ +`/* Implementation of the MAXLOC intrinsic + Copyright 2017 Free Software Foundation, Inc. + Contributed by Thomas Koenig + +This file is part of the GNU Fortran runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 3 of the License, or (at your option) any later version. + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +<http://www.gnu.org/licenses/>. */ + +#include "libgfortran.h" +#include <stdlib.h> +#include <string.h> +#include <assert.h> +#include <limits.h>' + +include(iparm.m4)dnl +include(iforeach-s2.m4)dnl + +`#if defined (HAVE_'atype_name`) && defined (HAVE_'rtype_name`)' + +FOREACH_FUNCTION( +` const atype_name *retval; + retval = ret;' +, +` if (compare_fcn (base, retval, len) < 0) + { + retval = base; + }') + +MASKED_FOREACH_FUNCTION( +` const atype_name *retval; + + retval = ret;' +, +` if (*mbase && compare_fcn (base, retval, len) < 0) + { + retval = base; + }') + +SCALAR_FOREACH_FUNCTION + +#endif diff --git a/libgfortran/m4/minval1s.m4 b/libgfortran/m4/minval1s.m4 new file mode 100644 index 00000000000..3f52bd9bdab --- /dev/null +++ b/libgfortran/m4/minval1s.m4 @@ -0,0 +1,61 @@ +`/* Implementation of the MAXVAL intrinsic + Copyright 2017 Free Software Foundation, Inc. + Contributed by Thomas Koenig + +This file is part of the GNU Fortran runtime library (libgfortran). + +Libgfortran is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public +License as published by the Free Software Foundation; either +version 3 of the License, or (at your option) any later version. + +Libgfortran is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +Under Section 7 of GPL version 3, you are granted additional +permissions described in the GCC Runtime Library Exception, version +3.1, as published by the Free Software Foundation. + +You should have received a copy of the GNU General Public License and +a copy of the GCC Runtime Library Exception along with this program; +see the files COPYING3 and COPYING.RUNTIME respectively. If not, see +<http://www.gnu.org/licenses/>. */ + +#include "libgfortran.h"' + +include(iparm.m4)dnl +include(ifunction-s2.m4)dnl + +`#if defined (HAVE_'atype_name`) && defined (HAVE_'rtype_name`)' + +ARRAY_FUNCTION(255, +` const atype_name *retval; + retval = base;', +` if (compare_fcn (src, retval, string_len) < 0) + { + retval = src; + }', `') + +MASKED_ARRAY_FUNCTION(255, +` const atype_name *retval; + memset (dest, 255, sizeof (*dest) * string_len); + retval = dest;', +` if (*msrc) + { + retval = src; + break; + } + } + for (; n < len; n++, src += delta, msrc += mdelta) + { + if (*msrc && compare_fcn (src, retval, string_len) < 0) + { + retval = src; + } + ') + +SCALAR_ARRAY_FUNCTION(255) + +#endif |