1/* Implementation of the FINDLOC intrinsic
2   Copyright (C) 2018-2022 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_4
29index_type findloc2_s4 (gfc_array_s4 * const restrict array,
30			   const GFC_UINTEGER_4 * restrict value, GFC_LOGICAL_4 back,
31			   gfc_charlen_type len_array, gfc_charlen_type len_value);
32export_proto(findloc2_s4);
33
34index_type
35findloc2_s4 (gfc_array_s4 * const restrict array, const GFC_UINTEGER_4 * 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_4 * 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_char4 (len_array, src, len_value, 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_char4 (len_array, src, len_value, value) == 0)
65	    return i;
66	  src += sstride;
67	}
68    }
69  return 0;
70}
71
72index_type mfindloc2_s4 (gfc_array_s4 * const restrict array,
73			 const GFC_UINTEGER_4 * 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_s4);
77
78index_type
79mfindloc2_s4 (gfc_array_s4 * const restrict array,
80			   const GFC_UINTEGER_4 * 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_4 * 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_char4 (len_array, src, len_value, 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_char4 (len_array, src, len_value, value) == 0))
129	    return i;
130	  src += sstride;
131	  mbase += mstride;
132	}
133    }
134  return 0;
135}
136index_type sfindloc2_s4 (gfc_array_s4 * const restrict array,
137			 const GFC_UINTEGER_4 * 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_s4);
141
142index_type
143sfindloc2_s4 (gfc_array_s4 * const restrict array,
144			   const GFC_UINTEGER_4 * 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_s4 (array, value, back, len_array, len_value);
151    }
152  return 0;
153}
154#endif
155