1/* Implementation of the FINDLOC intrinsic 2 Copyright (C) 2018-2020 Free Software Foundation, Inc. 3 Contributed by Thomas K��nig <tk@tkoenig.net> 4 5This file is part of the GNU Fortran 95 runtime library (libgfortran). 6 7Libgfortran is free software; you can redistribute it and/or 8modify it under the terms of the GNU General Public 9License as published by the Free Software Foundation; either 10version 3 of the License, or (at your option) any later version. 11 12Libgfortran is distributed in the hope that it will be useful, 13but WITHOUT ANY WARRANTY; without even the implied warranty of 14MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15GNU General Public License for more details. 16 17Under Section 7 of GPL version 3, you are granted additional 18permissions described in the GCC Runtime Library Exception, version 193.1, as published by the Free Software Foundation. 20 21You should have received a copy of the GNU General Public License and 22a copy of the GCC Runtime Library Exception along with this program; 23see the files COPYING3 and COPYING.RUNTIME respectively. If not, see 24<http://www.gnu.org/licenses/>. */ 25 26#include "libgfortran.h" 27 28#ifdef HAVE_GFC_UINTEGER_1 29index_type findloc2_s1 (gfc_array_s1 * const restrict array, 30 const GFC_UINTEGER_1 * restrict value, GFC_LOGICAL_4 back, 31 gfc_charlen_type len_array, gfc_charlen_type len_value); 32export_proto(findloc2_s1); 33 34index_type 35findloc2_s1 (gfc_array_s1 * const restrict array, const GFC_UINTEGER_1 * restrict value, 36 GFC_LOGICAL_4 back, 37 gfc_charlen_type len_array, gfc_charlen_type len_value) 38{ 39 index_type i; 40 index_type sstride; 41 index_type extent; 42 const GFC_UINTEGER_1 * restrict src; 43 44 extent = GFC_DESCRIPTOR_EXTENT(array,0); 45 if (extent <= 0) 46 return 0; 47 48 sstride = GFC_DESCRIPTOR_STRIDE(array,0) * len_array; 49 if (back) 50 { 51 src = array->base_addr + (extent - 1) * sstride; 52 for (i = extent; i >= 0; i--) 53 { 54 if (compare_string (len_array, (char *) src, len_value, (char *) value) == 0) 55 return i; 56 src -= sstride; 57 } 58 } 59 else 60 { 61 src = array->base_addr; 62 for (i = 1; i <= extent; i++) 63 { 64 if (compare_string (len_array, (char *) src, len_value, (char *) value) == 0) 65 return i; 66 src += sstride; 67 } 68 } 69 return 0; 70} 71 72index_type mfindloc2_s1 (gfc_array_s1 * const restrict array, 73 const GFC_UINTEGER_1 * restrict value, 74 gfc_array_l1 *const restrict mask, GFC_LOGICAL_4 back, 75 gfc_charlen_type len_array, gfc_charlen_type len_value); 76export_proto(mfindloc2_s1); 77 78index_type 79mfindloc2_s1 (gfc_array_s1 * const restrict array, 80 const GFC_UINTEGER_1 * restrict value, gfc_array_l1 *const restrict mask, 81 GFC_LOGICAL_4 back, gfc_charlen_type len_array, 82 gfc_charlen_type len_value) 83{ 84 index_type i; 85 index_type sstride; 86 index_type extent; 87 const GFC_UINTEGER_1 * restrict src; 88 const GFC_LOGICAL_1 * restrict mbase; 89 int mask_kind; 90 index_type mstride; 91 92 extent = GFC_DESCRIPTOR_EXTENT(array,0); 93 if (extent <= 0) 94 return 0; 95 96 mask_kind = GFC_DESCRIPTOR_SIZE (mask); 97 mbase = mask->base_addr; 98 99 if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 100#ifdef HAVE_GFC_LOGICAL_16 101 || mask_kind == 16 102#endif 103 ) 104 mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); 105 else 106 internal_error (NULL, "Funny sized logical array"); 107 108 sstride = GFC_DESCRIPTOR_STRIDE(array,0) * len_array; 109 mstride = GFC_DESCRIPTOR_STRIDE_BYTES(mask,0); 110 111 if (back) 112 { 113 src = array->base_addr + (extent - 1) * sstride; 114 mbase += (extent - 1) * mstride; 115 for (i = extent; i >= 0; i--) 116 { 117 if (*mbase && (compare_string (len_array, (char *) src, len_value, (char *) value) == 0)) 118 return i; 119 src -= sstride; 120 mbase -= mstride; 121 } 122 } 123 else 124 { 125 src = array->base_addr; 126 for (i = 1; i <= extent; i++) 127 { 128 if (*mbase && (compare_string (len_array, (char *) src, len_value, (char *) value) == 0)) 129 return i; 130 src += sstride; 131 mbase += mstride; 132 } 133 } 134 return 0; 135} 136index_type sfindloc2_s1 (gfc_array_s1 * const restrict array, 137 const GFC_UINTEGER_1 * restrict value, 138 GFC_LOGICAL_4 *const restrict mask, GFC_LOGICAL_4 back, 139 gfc_charlen_type len_array, gfc_charlen_type len_value); 140export_proto(sfindloc2_s1); 141 142index_type 143sfindloc2_s1 (gfc_array_s1 * const restrict array, 144 const GFC_UINTEGER_1 * restrict value, GFC_LOGICAL_4 *const restrict mask, 145 GFC_LOGICAL_4 back, gfc_charlen_type len_array, 146 gfc_charlen_type len_value) 147{ 148 if (mask == NULL || *mask) 149 { 150 return findloc2_s1 (array, value, back, len_array, len_value); 151 } 152 return 0; 153} 154#endif 155