01ce9e31a0
2017-10-28 Thomas Koenig <tkoenig@gcc.gnu.org> PR fortran/54613 * gfortran.h (gfc_isym_id): Add GFC_ISYM_FINDLOC. (gfc_check_f): Add f6fl field. (gfc_simplify_f): Add f6 field. (gfc_resolve_f): Likewise. (gfc_type_letter): Add optional logical_equas_int flag. * check.c (intrinsic_type_check): New function. (gfc_check_findloc): New function. * intrinsics.c (gfc_type_letter): If logical_equals_int is set, act accordingly. (add_sym_5ml): Reformat comment. (add_sym_6fl): New function. (add_functions): Add findloc. (check_arglist): Add sixth argument, handle it. (resolve_intrinsic): Likewise. (check_specific): Handle findloc. * intrinsic.h (gfc_check_findloc): Add prototype. (gfc_simplify_findloc): Likewise. (gfc_resolve_findloc): Likewise. (MAX_INTRINSIC_ARGS): Adjust. * iresolve.c (gfc_resolve_findloc): New function. * simplify.c (gfc_simplify_minmaxloc): Make static. (simplify_findloc_to_scalar): New function. (simplify_findloc_nodim): New function. (simplify_findloc_to_array): New function. (gfc_simplify_findloc): New function. (gfc_conv_intrinsic_findloc): New function. (gfc_conv_intrinsic_function): Handle GFC_ISYM_FINDLOC. (gfc_is_intrinsic_libcall): Likewise. 2017-10-28 Thomas Koenig <tkoenig@gcc.gnu.org> PR fortran/54613 * Makefile.am: Add files for findloc. * Makefile.in: Regenerated. * libgfortran.h (gfc_array_index_type): Add. (gfc_array_s1): Add using GFC_UINTEGER_1. (gfc_array_s4): Likewise. Replace unnecessary comment. (HAVE_GFC_UINTEGER_1): Define. (HAVE_GFC_UINTEGER_4): Define. * m4/findloc0.m4: New file. * m4/findloc0s.m4: New file. * m4/findloc1.m4: New file. * m4/findloc1s.m4: New file. * m4/findloc2s.m4: New file. * m4/ifindloc0.m4: New file. * m4/ifindloc1.m4: New file. * m4/ifindloc2.m4: New file. * m4/iparm.m4: Use unsigned integer for characters. * generated/findloc0_c16.c: New file. * generated/findloc0_c4.c: New file. * generated/findloc0_c8.c: New file. * generated/findloc0_i1.c: New file. * generated/findloc0_i16.c: New file. * generated/findloc0_i2.c: New file. * generated/findloc0_i4.c: New file. * generated/findloc0_i8.c: New file. * generated/findloc0_r16.c: New file. * generated/findloc0_r4.c: New file. * generated/findloc0_r8.c: New file. * generated/findloc0_s1.c: New file. * generated/findloc0_s4.c: New file. * generated/findloc1_c16.c: New file. * generated/findloc1_c4.c: New file. * generated/findloc1_c8.c: New file. * generated/findloc1_i1.c: New file. * generated/findloc1_i16.c: New file. * generated/findloc1_i2.c: New file. * generated/findloc1_i4.c: New file. * generated/findloc1_i8.c: New file. * generated/findloc1_r16.c: New file. * generated/findloc1_r4.c: New file. * generated/findloc1_r8.c: New file. * generated/findloc1_s1.c: New file. * generated/findloc1_s4.c: New file. * generated/findloc2_s1.c: New file. * generated/findloc2_s4.c: New file. * generated/maxloc0_16_s1.c: Regenerated. * generated/maxloc0_16_s4.c: Regenerated. * generated/maxloc0_4_s1.c: Regenerated. * generated/maxloc0_4_s4.c: Regenerated. * generated/maxloc0_8_s1.c: Regenerated. * generated/maxloc0_8_s4.c: Regenerated. * generated/maxloc1_16_s1.c: Regenerated. * generated/maxloc1_16_s4.c: Regenerated. * generated/maxloc1_4_s1.c: Regenerated. * generated/maxloc1_4_s4.c: Regenerated. * generated/maxloc1_8_s1.c: Regenerated. * generated/maxloc1_8_s4.c: Regenerated. * generated/maxloc2_16_s1.c: Regenerated. * generated/maxloc2_16_s4.c: Regenerated. * generated/maxloc2_4_s1.c: Regenerated. * generated/maxloc2_4_s4.c: Regenerated. * generated/maxloc2_8_s1.c: Regenerated. * generated/maxloc2_8_s4.c: Regenerated. * generated/maxval0_s1.c: Regenerated. * generated/maxval0_s4.c: Regenerated. * generated/maxval1_s1.c: Regenerated. * generated/maxval1_s4.c: Regenerated. * generated/minloc0_16_s1.c: Regenerated. * generated/minloc0_16_s4.c: Regenerated. * generated/minloc0_4_s1.c: Regenerated. * generated/minloc0_4_s4.c: Regenerated. * generated/minloc0_8_s1.c: Regenerated. * generated/minloc0_8_s4.c: Regenerated. * generated/minloc1_16_s1.c: Regenerated. * generated/minloc1_16_s4.c: Regenerated. * generated/minloc1_4_s1.c: Regenerated. * generated/minloc1_4_s4.c: Regenerated. * generated/minloc1_8_s1.c: Regenerated. * generated/minloc1_8_s4.c: Regenerated. * generated/minloc2_16_s1.c: Regenerated. * generated/minloc2_16_s4.c: Regenerated. * generated/minloc2_4_s1.c: Regenerated. * generated/minloc2_4_s4.c: Regenerated. * generated/minloc2_8_s1.c: Regenerated. * generated/minloc2_8_s4.c: Regenerated. * generated/minval0_s1.c: Regenerated. * generated/minval0_s4.c: Regenerated. * generated/minval1_s1.c: Regenerated. * generated/minval1_s4.c: Regenerated. 2017-10-28 Thomas Koenig <tkoenig@gcc.gnu.org> PR fortran/54613 * gfortran.dg/findloc_1.f90: New test. * gfortran.dg/findloc_2.f90: New test. * gfortran.dg/findloc_3.f90: New test. * gfortran.dg/findloc_4.f90: New test. * gfortran.dg/findloc_5.f90: New test. * gfortran.dg/findloc_6.f90: New test. From-SVN: r265570
162 lines
4.2 KiB
C
162 lines
4.2 KiB
C
/* Implementation of the MAXLOC intrinsic
|
|
Copyright (C) 2017-2018 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>
|
|
|
|
#if defined (HAVE_GFC_UINTEGER_4) && defined (HAVE_GFC_INTEGER_4)
|
|
|
|
static inline int
|
|
compare_fcn (const GFC_UINTEGER_4 *a, const GFC_UINTEGER_4 *b, gfc_charlen_type n)
|
|
{
|
|
if (sizeof (GFC_UINTEGER_4) == 1)
|
|
return memcmp (a, b, n);
|
|
else
|
|
return memcmp_char4 (a, b, n);
|
|
}
|
|
|
|
extern GFC_INTEGER_4 maxloc2_4_s4 (gfc_array_s4 * const restrict, GFC_LOGICAL_4 back,
|
|
gfc_charlen_type);
|
|
export_proto(maxloc2_4_s4);
|
|
|
|
GFC_INTEGER_4
|
|
maxloc2_4_s4 (gfc_array_s4 * const restrict array, GFC_LOGICAL_4 back, gfc_charlen_type len)
|
|
{
|
|
index_type ret;
|
|
index_type sstride;
|
|
index_type extent;
|
|
const GFC_UINTEGER_4 *src;
|
|
const GFC_UINTEGER_4 *maxval;
|
|
index_type i;
|
|
|
|
extent = GFC_DESCRIPTOR_EXTENT(array,0);
|
|
if (extent <= 0)
|
|
return 0;
|
|
|
|
sstride = GFC_DESCRIPTOR_STRIDE(array,0) * len;
|
|
|
|
ret = 1;
|
|
src = array->base_addr;
|
|
maxval = NULL;
|
|
for (i=1; i<=extent; i++)
|
|
{
|
|
if (maxval == NULL || (back ? compare_fcn (src, maxval, len) >= 0 :
|
|
compare_fcn (src, maxval, len) > 0))
|
|
{
|
|
ret = i;
|
|
maxval = src;
|
|
}
|
|
src += sstride;
|
|
}
|
|
return ret;
|
|
}
|
|
|
|
extern GFC_INTEGER_4 mmaxloc2_4_s4 (gfc_array_s4 * const restrict,
|
|
gfc_array_l1 *const restrict mask, GFC_LOGICAL_4 back,
|
|
gfc_charlen_type);
|
|
export_proto(mmaxloc2_4_s4);
|
|
|
|
GFC_INTEGER_4
|
|
mmaxloc2_4_s4 (gfc_array_s4 * const restrict array,
|
|
gfc_array_l1 * const restrict mask, GFC_LOGICAL_4 back,
|
|
gfc_charlen_type len)
|
|
{
|
|
index_type ret;
|
|
index_type sstride;
|
|
index_type extent;
|
|
const GFC_UINTEGER_4 *src;
|
|
const GFC_UINTEGER_4 *maxval;
|
|
index_type i, j;
|
|
GFC_LOGICAL_1 *mbase;
|
|
int mask_kind;
|
|
index_type mstride;
|
|
|
|
extent = GFC_DESCRIPTOR_EXTENT(array,0);
|
|
if (extent <= 0)
|
|
return 0;
|
|
|
|
sstride = GFC_DESCRIPTOR_STRIDE(array,0) * 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
|
|
internal_error (NULL, "Funny sized logical array");
|
|
|
|
mstride = GFC_DESCRIPTOR_STRIDE_BYTES(mask,0);
|
|
|
|
/* Search for the first occurrence of a true element in mask. */
|
|
for (j=0; j<extent; j++)
|
|
{
|
|
if (*mbase)
|
|
break;
|
|
mbase += mstride;
|
|
}
|
|
|
|
if (j == extent)
|
|
return 0;
|
|
|
|
ret = j + 1;
|
|
src = array->base_addr + j * sstride;
|
|
maxval = src;
|
|
|
|
for (i=j+1; i<=extent; i++)
|
|
{
|
|
if (*mbase && (back ? compare_fcn (src, maxval, len) >= 0 :
|
|
compare_fcn (src, maxval, len) > 0))
|
|
{
|
|
ret = i;
|
|
maxval = src;
|
|
}
|
|
src += sstride;
|
|
mbase += mstride;
|
|
}
|
|
return ret;
|
|
}
|
|
|
|
extern GFC_INTEGER_4 smaxloc2_4_s4 (gfc_array_s4 * const restrict,
|
|
GFC_LOGICAL_4 *mask, GFC_LOGICAL_4 back, gfc_charlen_type);
|
|
export_proto(smaxloc2_4_s4);
|
|
|
|
GFC_INTEGER_4
|
|
smaxloc2_4_s4 (gfc_array_s4 * const restrict array,
|
|
GFC_LOGICAL_4 *mask, GFC_LOGICAL_4 back, gfc_charlen_type len)
|
|
{
|
|
if (mask)
|
|
return maxloc2_4_s4 (array, len, back);
|
|
else
|
|
return 0;
|
|
}
|
|
|
|
#endif
|