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_'atype_name`'` 29'header1`'` 30{ 31 index_type i; 32 index_type sstride; 33 index_type extent; 34 const 'atype_name`'` * restrict src; 35 36 extent = GFC_DESCRIPTOR_EXTENT(array,0); 37 if (extent <= 0) 38 return 0; 39 40 sstride = GFC_DESCRIPTOR_STRIDE(array,0) * 'base_mult`'`; 41 if (back) 42 { 43 src = array->base_addr + (extent - 1) * sstride; 44 for (i = extent; i >= 0; i--) 45 { 46 if ('comparison`'`) 47 return i; 48 src -= sstride; 49 } 50 } 51 else 52 { 53 src = array->base_addr; 54 for (i = 1; i <= extent; i++) 55 { 56 if ('comparison`'`) 57 return i; 58 src += sstride; 59 } 60 } 61 return 0; 62} 63 64'header2`'` 65{ 66 index_type i; 67 index_type sstride; 68 index_type extent; 69 const 'atype_name`'` * restrict src; 70 const GFC_LOGICAL_1 * restrict mbase; 71 int mask_kind; 72 index_type mstride; 73 74 extent = GFC_DESCRIPTOR_EXTENT(array,0); 75 if (extent <= 0) 76 return 0; 77 78 mask_kind = GFC_DESCRIPTOR_SIZE (mask); 79 mbase = mask->base_addr; 80 81 if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8 82#ifdef HAVE_GFC_LOGICAL_16 83 || mask_kind == 16 84#endif 85 ) 86 mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind); 87 else 88 internal_error (NULL, "Funny sized logical array"); 89 90 sstride = GFC_DESCRIPTOR_STRIDE(array,0) * 'base_mult`'`; 91 mstride = GFC_DESCRIPTOR_STRIDE_BYTES(mask,0); 92 93 if (back) 94 { 95 src = array->base_addr + (extent - 1) * sstride; 96 mbase += (extent - 1) * mstride; 97 for (i = extent; i >= 0; i--) 98 { 99 if (*mbase && ('comparison`'`)) 100 return i; 101 src -= sstride; 102 mbase -= mstride; 103 } 104 } 105 else 106 { 107 src = array->base_addr; 108 for (i = 1; i <= extent; i++) 109 { 110 if (*mbase && ('comparison`'`)) 111 return i; 112 src += sstride; 113 mbase += mstride; 114 } 115 } 116 return 0; 117} 118'header3`'` 119{ 120 if (mask == NULL || *mask) 121 { 122 return findloc2_'atype_code` (array, value, back, len_array, len_value); 123 } 124 return 0; 125} 126#endif' 127