1 /* Copyright (C) 2009-2023 Free Software Foundation, Inc.
2 Contributed by Thomas Koenig
3
4 This file is part of the GNU Fortran runtime library (libgfortran).
5
6 Libgfortran is free software; you can redistribute it and/or modify
7 it under the terms of the GNU General Public License as published by
8 the Free Software Foundation; either version 3, or (at your option)
9 any later version.
10
11 Libgfortran is distributed in the hope that it will be useful,
12 but WITHOUT ANY WARRANTY; without even the implied warranty of
13 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 GNU General Public License for more details.
15
16 Under Section 7 of GPL version 3, you are granted additional
17 permissions described in the GCC Runtime Library Exception, version
18 3.1, as published by the Free Software Foundation.
19
20 You should have received a copy of the GNU General Public License and
21 a copy of the GCC Runtime Library Exception along with this program;
22 see 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
34 void
35 bounds_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
60 void
61 bounds_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
109 void
110 bounds_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
152 void
153 bounds_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
202 index_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 }