175584Sru/* Implementation of the FINDLOC intrinsic 275584Sru Copyright (C) 2018-2020 Free Software Foundation, Inc. 375584Sru Contributed by Thomas K��nig <tk@tkoenig.net> 475584Sru 575584SruThis file is part of the GNU Fortran 95 runtime library (libgfortran). 675584Sru 775584SruLibgfortran is free software; you can redistribute it and/or 875584Srumodify it under the terms of the GNU General Public 975584SruLicense as published by the Free Software Foundation; either 1075584Sruversion 3 of the License, or (at your option) any later version. 1175584Sru 1275584SruLibgfortran is distributed in the hope that it will be useful, 1375584Srubut WITHOUT ANY WARRANTY; without even the implied warranty of 1475584SruMERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15114402SruGNU General Public License for more details. 16114402Sru 1775584SruUnder Section 7 of GPL version 3, you are granted additional 1875584Srupermissions described in the GCC Runtime Library Exception, version 1975584Sru3.1, as published by the Free Software Foundation. 2075584Sru 2175584SruYou should have received a copy of the GNU General Public License and 2275584Srua copy of the GCC Runtime Library Exception along with this program; 2375584Srusee the files COPYING3 and COPYING.RUNTIME respectively. If not, see 2475584Sru<http://www.gnu.org/licenses/>. */ 2575584Sru 2675584Sru#include "libgfortran.h" 2775584Sru 2875584Sru#ifdef HAVE_GFC_UINTEGER_1 2975584Sruindex_type findloc2_s1 (gfc_array_s1 * const restrict array, 3075584Sru const GFC_UINTEGER_1 * restrict value, GFC_LOGICAL_4 back, 3175584Sru gfc_charlen_type len_array, gfc_charlen_type len_value); 3275584Sruexport_proto(findloc2_s1); 3375584Sru 3475584Sruindex_type 3575584Srufindloc2_s1 (gfc_array_s1 * const restrict array, const GFC_UINTEGER_1 * restrict value, 3675584Sru GFC_LOGICAL_4 back, 3775584Sru gfc_charlen_type len_array, gfc_charlen_type len_value) 3875584Sru{ 3975584Sru index_type i; 4075584Sru index_type sstride; 4175584Sru index_type extent; 4275584Sru const GFC_UINTEGER_1 * restrict src; 4375584Sru 4475584Sru extent = GFC_DESCRIPTOR_EXTENT(array,0); 4575584Sru if (extent <= 0) 4675584Sru return 0; 4775584Sru 4875584Sru sstride = GFC_DESCRIPTOR_STRIDE(array,0) * len_array; 4975584Sru if (back) 5075584Sru { 5175584Sru src = array->base_addr + (extent - 1) * sstride; 5275584Sru for (i = extent; i >= 0; i--) 5375584Sru { 5475584Sru if (compare_string (len_array, (char *) src, len_value, (char *) value) == 0) 5575584Sru return i; 5675584Sru src -= sstride; 5775584Sru } 5875584Sru } 5975584Sru else 6075584Sru { 6175584Sru src = array->base_addr; 6275584Sru for (i = 1; i <= extent; i++) 6375584Sru { 6475584Sru if (compare_string (len_array, (char *) src, len_value, (char *) value) == 0) 6575584Sru return i; 6675584Sru src += sstride; 6775584Sru } 6875584Sru } 6975584Sru return 0; 7075584Sru} 7175584Sru 7275584Sruindex_type mfindloc2_s1 (gfc_array_s1 * const restrict array, 7375584Sru const GFC_UINTEGER_1 * restrict value, 7475584Sru gfc_array_l1 *const restrict mask, GFC_LOGICAL_4 back, 7575584Sru gfc_charlen_type len_array, gfc_charlen_type len_value); 7675584Sruexport_proto(mfindloc2_s1); 7775584Sru 7875584Sruindex_type 7975584Srumfindloc2_s1 (gfc_array_s1 * const restrict array, 8075584Sru const GFC_UINTEGER_1 * restrict value, gfc_array_l1 *const restrict mask, 8175584Sru GFC_LOGICAL_4 back, gfc_charlen_type len_array, 8275584Sru gfc_charlen_type len_value) 8375584Sru{ 8475584Sru index_type i; 8575584Sru index_type sstride; 8675584Sru index_type extent; 8775584Sru const GFC_UINTEGER_1 * restrict src; 8875584Sru const GFC_LOGICAL_1 * restrict mbase; 8975584Sru int mask_kind; 9075584Sru index_type mstride; 9175584Sru 9275584Sru extent = GFC_DESCRIPTOR_EXTENT(array,0); 9375584Sru if (extent <= 0) 9475584Sru return 0; 9575584Sru 9675584Sru mask_kind = GFC_DESCRIPTOR_SIZE (mask); 9775584Sru mbase = mask->base_addr; 9875584Sru 9975584Sru if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 10075584Sru#ifdef HAVE_GFC_LOGICAL_16 10175584Sru || mask_kind == 16 10275584Sru#endif 10375584Sru ) 10475584Sru mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); 10575584Sru else 10675584Sru internal_error (NULL, "Funny sized logical array"); 10775584Sru 10875584Sru sstride = GFC_DESCRIPTOR_STRIDE(array,0) * len_array; 10975584Sru mstride = GFC_DESCRIPTOR_STRIDE_BYTES(mask,0); 11075584Sru 11175584Sru if (back) 11275584Sru { 11375584Sru src = array->base_addr + (extent - 1) * sstride; 11475584Sru mbase += (extent - 1) * mstride; 11575584Sru for (i = extent; i >= 0; i--) 11675584Sru { 11775584Sru if (*mbase && (compare_string (len_array, (char *) src, len_value, (char *) value) == 0)) 11875584Sru return i; 11975584Sru src -= sstride; 12075584Sru mbase -= mstride; 12175584Sru } 12275584Sru } 12375584Sru else 12475584Sru { 12575584Sru src = array->base_addr; 12675584Sru for (i = 1; i <= extent; i++) 12775584Sru { 12875584Sru if (*mbase && (compare_string (len_array, (char *) src, len_value, (char *) value) == 0)) 12975584Sru return i; 13075584Sru src += sstride; 13175584Sru mbase += mstride; 13275584Sru } 13375584Sru } 13475584Sru return 0; 13575584Sru} 13675584Sruindex_type sfindloc2_s1 (gfc_array_s1 * const restrict array, 13775584Sru const GFC_UINTEGER_1 * restrict value, 13875584Sru GFC_LOGICAL_4 *const restrict mask, GFC_LOGICAL_4 back, 13975584Sru gfc_charlen_type len_array, gfc_charlen_type len_value); 14075584Sruexport_proto(sfindloc2_s1); 14175584Sru 14275584Sruindex_type 14375584Srusfindloc2_s1 (gfc_array_s1 * const restrict array, 14475584Sru const GFC_UINTEGER_1 * restrict value, GFC_LOGICAL_4 *const restrict mask, 14575584Sru GFC_LOGICAL_4 back, gfc_charlen_type len_array, 14675584Sru gfc_charlen_type len_value) 14775584Sru{ 14875584Sru if (mask == NULL || *mask) 14975584Sru { 15075584Sru return findloc2_s1 (array, value, back, len_array, len_value); 15175584Sru } 15275584Sru return 0; 15375584Sru} 15475584Sru#endif 15575584Sru