1/* Implementation of the ANY intrinsic
2   Copyright (C) 2002-2022 Free Software Foundation, Inc.
3   Contributed by Paul Brook <paul@nowt.org>
4
5This file is part of the GNU Fortran 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
29#if defined (HAVE_GFC_LOGICAL_4)
30
31
32extern void any_l4 (gfc_array_l4 * const restrict,
33	gfc_array_l1 * const restrict, const index_type * const restrict);
34export_proto(any_l4);
35
36void
37any_l4 (gfc_array_l4 * const restrict retarray,
38	gfc_array_l1 * const restrict array,
39	const index_type * const restrict pdim)
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[GFC_MAX_DIMENSIONS];
45  const GFC_LOGICAL_1 * restrict base;
46  GFC_LOGICAL_4 * restrict dest;
47  index_type rank;
48  index_type n;
49  index_type len;
50  index_type delta;
51  index_type dim;
52  int src_kind;
53  int continue_loop;
54
55  /* Make dim zero based to avoid confusion.  */
56  dim = (*pdim) - 1;
57  rank = GFC_DESCRIPTOR_RANK (array) - 1;
58
59  src_kind = GFC_DESCRIPTOR_SIZE (array);
60
61  len = GFC_DESCRIPTOR_EXTENT(array,dim);
62  if (len < 0)
63    len = 0;
64
65  delta = GFC_DESCRIPTOR_STRIDE_BYTES(array,dim);
66
67  for (n = 0; n < dim; n++)
68    {
69      sstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(array,n);
70      extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
71
72      if (extent[n] < 0)
73	extent[n] = 0;
74    }
75  for (n = dim; n < rank; n++)
76    {
77      sstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(array,n + 1);
78      extent[n] = GFC_DESCRIPTOR_EXTENT(array,n + 1);
79
80      if (extent[n] < 0)
81	extent[n] = 0;
82    }
83
84  if (retarray->base_addr == NULL)
85    {
86      size_t alloc_size, str;
87
88      for (n = 0; n < rank; n++)
89        {
90          if (n == 0)
91            str = 1;
92          else
93            str = GFC_DESCRIPTOR_STRIDE(retarray,n-1) * extent[n-1];
94
95	  GFC_DIMENSION_SET(retarray->dim[n], 0, extent[n] - 1, str);
96
97        }
98
99      retarray->offset = 0;
100      retarray->dtype.rank = rank;
101
102      alloc_size = GFC_DESCRIPTOR_STRIDE(retarray,rank-1) * extent[rank-1];
103
104      if (alloc_size == 0)
105	{
106	  /* Make sure we have a zero-sized array.  */
107	  GFC_DIMENSION_SET(retarray->dim[0], 0, -1, 1);
108	  return;
109	}
110      else
111	retarray->base_addr = xmallocarray (alloc_size, sizeof (GFC_LOGICAL_4));
112    }
113  else
114    {
115      if (rank != GFC_DESCRIPTOR_RANK (retarray))
116	runtime_error ("rank of return array incorrect in"
117		       " ANY intrinsic: is %ld, should be %ld",
118		       (long int) GFC_DESCRIPTOR_RANK (retarray),
119		       (long int) rank);
120
121      if (unlikely (compile_options.bounds_check))
122	{
123	  for (n=0; n < rank; n++)
124	    {
125	      index_type ret_extent;
126
127	      ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,n);
128	      if (extent[n] != ret_extent)
129		runtime_error ("Incorrect extent in return value of"
130			       " ANY intrinsic in dimension %d:"
131			       " is %ld, should be %ld", (int) n + 1,
132			       (long int) ret_extent, (long int) extent[n]);
133	    }
134	}
135    }
136
137  for (n = 0; n < rank; n++)
138    {
139      count[n] = 0;
140      dstride[n] = GFC_DESCRIPTOR_STRIDE(retarray,n);
141      if (extent[n] <= 0)
142	return;
143    }
144
145  base = array->base_addr;
146
147  if (src_kind == 1 || src_kind == 2 || src_kind == 4 || src_kind == 8
148#ifdef HAVE_GFC_LOGICAL_16
149      || src_kind == 16
150#endif
151    )
152    {
153      if (base)
154	base = GFOR_POINTER_TO_L1 (base, src_kind);
155    }
156  else
157    internal_error (NULL, "Funny sized logical array in ANY intrinsic");
158
159  dest = retarray->base_addr;
160
161  continue_loop = 1;
162  while (continue_loop)
163    {
164      const GFC_LOGICAL_1 * restrict src;
165      GFC_LOGICAL_4 result;
166      src = base;
167      {
168
169  result = 0;
170        if (len <= 0)
171	  *dest = 0;
172	else
173	  {
174	    for (n = 0; n < len; n++, src += delta)
175	      {
176
177  /* Return true if any of the elements are set.  */
178  if (*src)
179    {
180      result = 1;
181      break;
182    }
183          }
184	    *dest = result;
185	  }
186      }
187      /* Advance to the next element.  */
188      count[0]++;
189      base += sstride[0];
190      dest += dstride[0];
191      n = 0;
192      while (count[n] == extent[n])
193        {
194          /* When we get to the end of a dimension, reset it and increment
195             the next dimension.  */
196          count[n] = 0;
197          /* We could precalculate these products, but this is a less
198             frequently used path so probably not worth it.  */
199          base -= sstride[n] * extent[n];
200          dest -= dstride[n] * extent[n];
201          n++;
202          if (n >= rank)
203            {
204              /* Break out of the loop.  */
205              continue_loop = 0;
206              break;
207            }
208          else
209            {
210              count[n]++;
211              base += sstride[n];
212              dest += dstride[n];
213            }
214        }
215    }
216}
217
218#endif
219