1 
2 /* Implementation of the FINDLOC intrinsic
3    Copyright (C) 2018-2020 Free Software Foundation, Inc.
4    Contributed by Thomas König <tk@tkoenig.net>
5 
6 This file is part of the GNU Fortran 95 runtime library (libgfortran).
7 
8 Libgfortran is free software; you can redistribute it and/or
9 modify it under the terms of the GNU General Public
10 License as published by the Free Software Foundation; either
11 version 3 of the License, or (at your option) any later version.
12 
13 Libgfortran is distributed in the hope that it will be useful,
14 but WITHOUT ANY WARRANTY; without even the implied warranty of
15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
16 GNU General Public License for more details.
17 
18 Under Section 7 of GPL version 3, you are granted additional
19 permissions described in the GCC Runtime Library Exception, version
20 3.1, as published by the Free Software Foundation.
21 
22 You should have received a copy of the GNU General Public License and
23 a copy of the GCC Runtime Library Exception along with this program;
24 see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
25 <http://www.gnu.org/licenses/>.  */
26 
27 #include "libgfortran.h"
28 #include <assert.h>
29 
30 #if defined (HAVE_GFC_INTEGER_16)
31 extern void findloc0_i16 (gfc_array_index_type * const restrict retarray,
32        	    		gfc_array_i16 * const restrict array, GFC_INTEGER_16 value,
33 			 GFC_LOGICAL_4);
34 export_proto(findloc0_i16);
35 
36 void
findloc0_i16(gfc_array_index_type * const restrict retarray,gfc_array_i16 * const restrict array,GFC_INTEGER_16 value,GFC_LOGICAL_4 back)37 findloc0_i16 (gfc_array_index_type * const restrict retarray,
38     	    gfc_array_i16 * const restrict array, GFC_INTEGER_16 value,
39 	    GFC_LOGICAL_4 back)
40 {
41   index_type count[GFC_MAX_DIMENSIONS];
42   index_type extent[GFC_MAX_DIMENSIONS];
43   index_type sstride[GFC_MAX_DIMENSIONS];
44   index_type dstride;
45   const GFC_INTEGER_16 *base;
46   index_type * restrict dest;
47   index_type rank;
48   index_type n;
49   index_type sz;
50 
51   rank = GFC_DESCRIPTOR_RANK (array);
52   if (rank <= 0)
53     runtime_error ("Rank of array needs to be > 0");
54 
55   if (retarray->base_addr == NULL)
56     {
57       GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1);
58       retarray->dtype.rank = 1;
59       retarray->offset = 0;
60       retarray->base_addr = xmallocarray (rank, sizeof (index_type));
61     }
62   else
63     {
64       if (unlikely (compile_options.bounds_check))
65 	bounds_iforeach_return ((array_t *) retarray, (array_t *) array,
66 				"FINDLOC");
67     }
68 
69   dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
70   dest = retarray->base_addr;
71 
72   /* Set the return value.  */
73   for (n = 0; n < rank; n++)
74     dest[n * dstride] = 0;
75 
76   sz = 1;
77   for (n = 0; n < rank; n++)
78     {
79       sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
80       extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
81       sz *= extent[n];
82       if (extent[n] <= 0)
83 	return;
84     }
85 
86     for (n = 0; n < rank; n++)
87       count[n] = 0;
88 
89   if (back)
90     {
91       base = array->base_addr + (sz - 1) * 1;
92 
93       while (1)
94         {
95 	  do
96 	    {
97 	      if (unlikely(*base == value))
98 	        {
99 		  for (n = 0; n < rank; n++)
100 		    dest[n * dstride] = extent[n] - count[n];
101 
102 		  return;
103 		}
104 	      base -= sstride[0] * 1;
105 	    } while(++count[0] != extent[0]);
106 
107 	  n = 0;
108 	  do
109 	    {
110 	      /* When we get to the end of a dimension, reset it and increment
111 		 the next dimension.  */
112 	      count[n] = 0;
113 	      /* We could precalculate these products, but this is a less
114 		 frequently used path so probably not worth it.  */
115 	      base += sstride[n] * extent[n] * 1;
116 	      n++;
117 	      if (n >= rank)
118 	        return;
119 	      else
120 		{
121 		  count[n]++;
122 		  base -= sstride[n] * 1;
123 		}
124 	    } while (count[n] == extent[n]);
125 	}
126     }
127   else
128     {
129       base = array->base_addr;
130       while (1)
131         {
132 	  do
133 	    {
134 	      if (unlikely(*base == value))
135 	        {
136 		  for (n = 0; n < rank; n++)
137 		    dest[n * dstride] = count[n] + 1;
138 
139 		  return;
140 		}
141 	      base += sstride[0] * 1;
142 	    } while(++count[0] != extent[0]);
143 
144 	  n = 0;
145 	  do
146 	    {
147 	      /* When we get to the end of a dimension, reset it and increment
148 		 the next dimension.  */
149 	      count[n] = 0;
150 	      /* We could precalculate these products, but this is a less
151 		 frequently used path so probably not worth it.  */
152 	      base -= sstride[n] * extent[n] * 1;
153 	      n++;
154 	      if (n >= rank)
155 	        return;
156 	      else
157 		{
158 		  count[n]++;
159 		  base += sstride[n] * 1;
160 		}
161 	    } while (count[n] == extent[n]);
162 	}
163     }
164   return;
165 }
166 
167 extern void mfindloc0_i16 (gfc_array_index_type * const restrict retarray,
168        	    		gfc_array_i16 * const restrict array, GFC_INTEGER_16 value,
169 			 gfc_array_l1 *const restrict, GFC_LOGICAL_4);
170 export_proto(mfindloc0_i16);
171 
172 void
mfindloc0_i16(gfc_array_index_type * const restrict retarray,gfc_array_i16 * const restrict array,GFC_INTEGER_16 value,gfc_array_l1 * const restrict mask,GFC_LOGICAL_4 back)173 mfindloc0_i16 (gfc_array_index_type * const restrict retarray,
174     	    gfc_array_i16 * const restrict array, GFC_INTEGER_16 value,
175 	    gfc_array_l1 *const restrict mask, GFC_LOGICAL_4 back)
176 {
177   index_type count[GFC_MAX_DIMENSIONS];
178   index_type extent[GFC_MAX_DIMENSIONS];
179   index_type sstride[GFC_MAX_DIMENSIONS];
180   index_type mstride[GFC_MAX_DIMENSIONS];
181   index_type dstride;
182   const GFC_INTEGER_16 *base;
183   index_type * restrict dest;
184   GFC_LOGICAL_1 *mbase;
185   index_type rank;
186   index_type n;
187   int mask_kind;
188   index_type sz;
189 
190   rank = GFC_DESCRIPTOR_RANK (array);
191   if (rank <= 0)
192     runtime_error ("Rank of array needs to be > 0");
193 
194   if (retarray->base_addr == NULL)
195     {
196       GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1);
197       retarray->dtype.rank = 1;
198       retarray->offset = 0;
199       retarray->base_addr = xmallocarray (rank, sizeof (index_type));
200     }
201   else
202     {
203       if (unlikely (compile_options.bounds_check))
204 	{
205 	  bounds_iforeach_return ((array_t *) retarray, (array_t *) array,
206 				  "FINDLOC");
207 	  bounds_equal_extents ((array_t *) mask, (array_t *) array,
208 				"MASK argument", "FINDLOC");
209 	}
210     }
211 
212   mask_kind = GFC_DESCRIPTOR_SIZE (mask);
213 
214   mbase = mask->base_addr;
215 
216   if (mask_kind == 1 || mask_kind == 2 || mask_kind == 4 || mask_kind == 8
217 #ifdef HAVE_GFC_LOGICAL_16
218       || mask_kind == 16
219 #endif
220       )
221     mbase = GFOR_POINTER_TO_L1 (mbase, mask_kind);
222   else
223     internal_error (NULL, "Funny sized logical array");
224 
225   dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
226   dest = retarray->base_addr;
227 
228   /* Set the return value.  */
229   for (n = 0; n < rank; n++)
230     dest[n * dstride] = 0;
231 
232   sz = 1;
233   for (n = 0; n < rank; n++)
234     {
235       sstride[n] = GFC_DESCRIPTOR_STRIDE(array,n);
236       mstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(mask,n);
237       extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
238       sz *= extent[n];
239       if (extent[n] <= 0)
240 	return;
241     }
242 
243     for (n = 0; n < rank; n++)
244       count[n] = 0;
245 
246   if (back)
247     {
248       base = array->base_addr + (sz - 1) * 1;
249       mbase = mbase + (sz - 1) * mask_kind;
250       while (1)
251         {
252 	  do
253 	    {
254 	      if (unlikely(*mbase && *base == value))
255 	        {
256 		  for (n = 0; n < rank; n++)
257 		    dest[n * dstride] = extent[n] - count[n];
258 
259 		  return;
260 		}
261 	      base -= sstride[0] * 1;
262 	      mbase -= mstride[0];
263 	    } while(++count[0] != extent[0]);
264 
265 	  n = 0;
266 	  do
267 	    {
268 	      /* When we get to the end of a dimension, reset it and increment
269 		 the next dimension.  */
270 	      count[n] = 0;
271 	      /* We could precalculate these products, but this is a less
272 		 frequently used path so probably not worth it.  */
273 	      base += sstride[n] * extent[n] * 1;
274 	      mbase -= mstride[n] * extent[n];
275 	      n++;
276 	      if (n >= rank)
277 		return;
278 	      else
279 		{
280 		  count[n]++;
281 		  base -= sstride[n] * 1;
282 		  mbase += mstride[n];
283 		}
284 	    } while (count[n] == extent[n]);
285 	}
286     }
287   else
288     {
289       base = array->base_addr;
290       while (1)
291         {
292 	  do
293 	    {
294 	      if (unlikely(*mbase && *base == value))
295 	        {
296 		  for (n = 0; n < rank; n++)
297 		    dest[n * dstride] = count[n] + 1;
298 
299 		  return;
300 		}
301 	      base += sstride[0] * 1;
302 	      mbase += mstride[0];
303 	    } while(++count[0] != extent[0]);
304 
305 	  n = 0;
306 	  do
307 	    {
308 	      /* When we get to the end of a dimension, reset it and increment
309 		 the next dimension.  */
310 	      count[n] = 0;
311 	      /* We could precalculate these products, but this is a less
312 		 frequently used path so probably not worth it.  */
313 	      base -= sstride[n] * extent[n] * 1;
314 	      mbase -= mstride[n] * extent[n];
315 	      n++;
316 	      if (n >= rank)
317 		return;
318 	      else
319 		{
320 		  count[n]++;
321 		  base += sstride[n]* 1;
322 		  mbase += mstride[n];
323 		}
324 	    } while (count[n] == extent[n]);
325 	}
326     }
327   return;
328 }
329 
330 extern void sfindloc0_i16 (gfc_array_index_type * const restrict retarray,
331        	    		gfc_array_i16 * const restrict array, GFC_INTEGER_16 value,
332 			 GFC_LOGICAL_4 *, GFC_LOGICAL_4);
333 export_proto(sfindloc0_i16);
334 
335 void
sfindloc0_i16(gfc_array_index_type * const restrict retarray,gfc_array_i16 * const restrict array,GFC_INTEGER_16 value,GFC_LOGICAL_4 * mask,GFC_LOGICAL_4 back)336 sfindloc0_i16 (gfc_array_index_type * const restrict retarray,
337     	    gfc_array_i16 * const restrict array, GFC_INTEGER_16 value,
338 	    GFC_LOGICAL_4 * mask, GFC_LOGICAL_4 back)
339 {
340   index_type rank;
341   index_type dstride;
342   index_type * restrict dest;
343   index_type n;
344 
345   if (mask == NULL || *mask)
346     {
347       findloc0_i16 (retarray, array, value, back);
348       return;
349     }
350 
351   rank = GFC_DESCRIPTOR_RANK (array);
352 
353   if (rank <= 0)
354     internal_error (NULL, "Rank of array needs to be > 0");
355 
356   if (retarray->base_addr == NULL)
357     {
358       GFC_DIMENSION_SET(retarray->dim[0], 0, rank-1, 1);
359       retarray->dtype.rank = 1;
360       retarray->offset = 0;
361       retarray->base_addr = xmallocarray (rank, sizeof (index_type));
362     }
363   else if (unlikely (compile_options.bounds_check))
364     {
365        bounds_iforeach_return ((array_t *) retarray, (array_t *) array,
366 			       "FINDLOC");
367     }
368 
369   dstride = GFC_DESCRIPTOR_STRIDE(retarray,0);
370   dest = retarray->base_addr;
371   for (n = 0; n<rank; n++)
372     dest[n * dstride] = 0 ;
373 }
374 
375 #endif
376