1/* Copyright (C) 2009-2020 Free Software Foundation, Inc.
2   Contributed by Thomas Koenig
3
4This file is part of the GNU Fortran runtime library (libgfortran).
5
6Libgfortran is free software; you can redistribute it and/or modify
7it under the terms of the GNU General Public License as published by
8the Free Software Foundation; either version 3, or (at your option)
9any later version.
10
11Libgfortran is distributed in the hope that it will be useful,
12but WITHOUT ANY WARRANTY; without even the implied warranty of
13MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
14GNU General Public License for more details.
15
16Under Section 7 of GPL version 3, you are granted additional
17permissions described in the GCC Runtime Library Exception, version
183.1, as published by the Free Software Foundation.
19
20You should have received a copy of the GNU General Public License and
21a copy of the GCC Runtime Library Exception along with this program;
22see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
23<http://www.gnu.org/licenses/>.  */
24
25#include "libgfortran.h"
26#include <assert.h>
27
28/* Auxiliary functions for bounds checking, mostly to reduce library size.  */
29
30/* Bounds checking for the return values of the iforeach functions (such
31   as maxloc and minloc).  The extent of ret_array must
32   must match the rank of array.  */
33
34void
35bounds_iforeach_return (array_t *retarray, array_t *array, const char *name)
36{
37  index_type rank;
38  index_type ret_rank;
39  index_type ret_extent;
40
41  ret_rank = GFC_DESCRIPTOR_RANK (retarray);
42
43  /* ret_rank should always be 1, otherwise there is an internal error */
44  GFC_ASSERT(ret_rank == 1);
45
46  rank = GFC_DESCRIPTOR_RANK (array);
47  ret_extent = GFC_DESCRIPTOR_EXTENT(retarray,0);
48  if (ret_extent != rank)
49    runtime_error ("Incorrect extent in return value of"
50		   " %s intrinsic: is %ld, should be %ld",
51		   name, (long int) ret_extent, (long int) rank);
52
53}
54
55/* Check the return of functions generated from ifunction.m4.
56   We check the array descriptor "a" against the extents precomputed
57   from ifunction.m4, and complain about the argument a_name in the
58   intrinsic function. */
59
60void
61bounds_ifunction_return (array_t * a, const index_type * extent,
62			 const char * a_name, const char * intrinsic)
63{
64  int empty;
65  int rank;
66  index_type a_size;
67
68  rank = GFC_DESCRIPTOR_RANK (a);
69  a_size = size0 (a);
70
71  empty = 0;
72  for (index_type n = 0; n < rank; n++)
73    {
74      if (extent[n] == 0)
75	empty = 1;
76    }
77  if (empty)
78    {
79      if (a_size != 0)
80	runtime_error ("Incorrect size in %s of %s"
81		       " intrinsic: should be zero-sized",
82		       a_name, intrinsic);
83    }
84  else
85    {
86      if (a_size == 0)
87	runtime_error ("Incorrect size of %s in %s"
88		       " intrinsic: should not be zero-sized",
89		       a_name, intrinsic);
90
91      for (index_type n = 0; n < rank; n++)
92	{
93	  index_type a_extent;
94	  a_extent = GFC_DESCRIPTOR_EXTENT(a, n);
95	  if (a_extent != extent[n])
96	    runtime_error("Incorrect extent in %s of %s"
97			  " intrinsic in dimension %ld: is %ld,"
98			  " should be %ld", a_name, intrinsic, (long int) n + 1,
99			  (long int) a_extent, (long int) extent[n]);
100
101	}
102    }
103}
104
105/* Check that two arrays have equal extents, or are both zero-sized.  Abort
106   with a runtime error if this is not the case.  Complain that a has the
107   wrong size.  */
108
109void
110bounds_equal_extents (array_t *a, array_t *b, const char *a_name,
111		      const char *intrinsic)
112{
113  index_type a_size, b_size, n;
114
115  assert (GFC_DESCRIPTOR_RANK(a) == GFC_DESCRIPTOR_RANK(b));
116
117  a_size = size0 (a);
118  b_size = size0 (b);
119
120  if (b_size == 0)
121    {
122      if (a_size != 0)
123	runtime_error ("Incorrect size of %s in %s"
124		       " intrinsic: should be zero-sized",
125		       a_name, intrinsic);
126    }
127  else
128    {
129      if (a_size == 0)
130	runtime_error ("Incorrect size of %s of %s"
131		       " intrinsic: Should not be zero-sized",
132		       a_name, intrinsic);
133
134      for (n = 0; n < GFC_DESCRIPTOR_RANK (b); n++)
135	{
136	  index_type a_extent, b_extent;
137
138	  a_extent = GFC_DESCRIPTOR_EXTENT(a, n);
139	  b_extent = GFC_DESCRIPTOR_EXTENT(b, n);
140	  if (a_extent != b_extent)
141	    runtime_error("Incorrect extent in %s of %s"
142			  " intrinsic in dimension %ld: is %ld,"
143			  " should be %ld", a_name, intrinsic, (long int) n + 1,
144			  (long int) a_extent, (long int) b_extent);
145	}
146    }
147}
148
149/* Check that the extents of a and b agree, except that a has a missing
150   dimension in argument which.  Complain about a if anything is wrong.  */
151
152void
153bounds_reduced_extents (array_t *a, array_t *b, int which, const char *a_name,
154		      const char *intrinsic)
155{
156
157  index_type i, n, a_size, b_size;
158
159  assert (GFC_DESCRIPTOR_RANK(a) == GFC_DESCRIPTOR_RANK(b) - 1);
160
161  a_size = size0 (a);
162  b_size = size0 (b);
163
164  if (b_size == 0)
165    {
166      if (a_size != 0)
167	runtime_error ("Incorrect size in %s of %s"
168		       " intrinsic: should not be zero-sized",
169		       a_name, intrinsic);
170    }
171  else
172    {
173      if (a_size == 0)
174	runtime_error ("Incorrect size of %s of %s"
175		       " intrinsic: should be zero-sized",
176		       a_name, intrinsic);
177
178      i = 0;
179      for (n = 0; n < GFC_DESCRIPTOR_RANK (b); n++)
180	{
181	  index_type a_extent, b_extent;
182
183	  if (n != which)
184	    {
185	      a_extent = GFC_DESCRIPTOR_EXTENT(a, i);
186	      b_extent = GFC_DESCRIPTOR_EXTENT(b, n);
187	      if (a_extent != b_extent)
188		runtime_error("Incorrect extent in %s of %s"
189			      " intrinsic in dimension %ld: is %ld,"
190			      " should be %ld", a_name, intrinsic, (long int) i + 1,
191			      (long int) a_extent, (long int) b_extent);
192	      i++;
193	    }
194	}
195    }
196}
197
198/* count_0 - count all the true elements in an array.  The front
199   end usually inlines this, we need this for bounds checking
200   for unpack.  */
201
202index_type count_0 (const gfc_array_l1 * array)
203{
204  const GFC_LOGICAL_1 * restrict base;
205  index_type rank;
206  int kind;
207  int continue_loop;
208  index_type count[GFC_MAX_DIMENSIONS];
209  index_type extent[GFC_MAX_DIMENSIONS];
210  index_type sstride[GFC_MAX_DIMENSIONS];
211  index_type result;
212  index_type n;
213
214  rank = GFC_DESCRIPTOR_RANK (array);
215  kind = GFC_DESCRIPTOR_SIZE (array);
216
217  base = array->base_addr;
218
219  if (kind == 1 || kind == 2 || kind == 4 || kind == 8
220#ifdef HAVE_GFC_LOGICAL_16
221      || kind == 16
222#endif
223    )
224    {
225      if (base)
226	base = GFOR_POINTER_TO_L1 (base, kind);
227    }
228  else
229    internal_error (NULL, "Funny sized logical array in count_0");
230
231  for (n = 0; n < rank; n++)
232    {
233      sstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(array,n);
234      extent[n] = GFC_DESCRIPTOR_EXTENT(array,n);
235      count[n] = 0;
236
237      if (extent[n] <= 0)
238	return 0;
239    }
240
241  result = 0;
242  continue_loop = 1;
243  while (continue_loop)
244    {
245      if (*base)
246	result ++;
247
248      count[0]++;
249      base += sstride[0];
250      n = 0;
251      while (count[n] == extent[n])
252	{
253	  count[n] = 0;
254	  base -= sstride[n] * extent[n];
255	  n++;
256	  if (n == rank)
257	    {
258	      continue_loop = 0;
259	      break;
260	    }
261	  else
262	    {
263	      count[n]++;
264	      base += sstride[n];
265	    }
266	}
267    }
268  return result;
269}
270