1 /* Implementation of the FINDLOC intrinsic 2 Copyright (C) 2018-2019 Free Software Foundation, Inc. 3 Contributed by Thomas König <tk@tkoenig.net> 4 5 This file is part of the GNU Fortran 95 runtime library (libgfortran). 6 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. 11 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. 16 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. 20 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/>. */ 25 26 #include "libgfortran.h" 27 28 #ifdef HAVE_GFC_UINTEGER_1 29 index_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); 32 export_proto(findloc2_s1); 33 34 index_type 35 findloc2_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 72 index_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); 76 export_proto(mfindloc2_s1); 77 78 index_type 79 mfindloc2_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 } 136 index_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); 140 export_proto(sfindloc2_s1); 141 142 index_type 143 sfindloc2_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