]>
Commit | Line | Data |
---|---|---|
8e8f6434 | 1 | /* Copyright (C) 2009-2018 Free Software Foundation, Inc. |
5d04d450 | 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 | ||
222d4142 | 43 | /* ret_rank should always be 1, otherwise there is an internal error */ |
44 | GFC_ASSERT(ret_rank == 1); | |
5d04d450 | 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 n; | |
66 | int rank; | |
67 | index_type a_size; | |
68 | ||
69 | rank = GFC_DESCRIPTOR_RANK (a); | |
70 | a_size = size0 (a); | |
71 | ||
72 | empty = 0; | |
73 | for (n = 0; n < rank; n++) | |
74 | { | |
75 | if (extent[n] == 0) | |
76 | empty = 1; | |
77 | } | |
78 | if (empty) | |
79 | { | |
80 | if (a_size != 0) | |
81 | runtime_error ("Incorrect size in %s of %s" | |
82 | " intrinsic: should be zero-sized", | |
83 | a_name, intrinsic); | |
84 | } | |
85 | else | |
86 | { | |
87 | if (a_size == 0) | |
88 | runtime_error ("Incorrect size of %s in %s" | |
89 | " intrinsic: should not be zero-sized", | |
90 | a_name, intrinsic); | |
91 | ||
92 | for (n = 0; n < rank; n++) | |
93 | { | |
94 | index_type a_extent; | |
95 | a_extent = GFC_DESCRIPTOR_EXTENT(a, n); | |
96 | if (a_extent != extent[n]) | |
97 | runtime_error("Incorrect extent in %s of %s" | |
98 | " intrinsic in dimension %ld: is %ld," | |
99 | " should be %ld", a_name, intrinsic, (long int) n + 1, | |
100 | (long int) a_extent, (long int) extent[n]); | |
101 | ||
102 | } | |
103 | } | |
104 | } | |
105 | ||
106 | /* Check that two arrays have equal extents, or are both zero-sized. Abort | |
107 | with a runtime error if this is not the case. Complain that a has the | |
108 | wrong size. */ | |
109 | ||
110 | void | |
111 | bounds_equal_extents (array_t *a, array_t *b, const char *a_name, | |
112 | const char *intrinsic) | |
113 | { | |
114 | index_type a_size, b_size, n; | |
115 | ||
116 | assert (GFC_DESCRIPTOR_RANK(a) == GFC_DESCRIPTOR_RANK(b)); | |
117 | ||
118 | a_size = size0 (a); | |
119 | b_size = size0 (b); | |
120 | ||
121 | if (b_size == 0) | |
122 | { | |
123 | if (a_size != 0) | |
124 | runtime_error ("Incorrect size of %s in %s" | |
125 | " intrinsic: should be zero-sized", | |
126 | a_name, intrinsic); | |
127 | } | |
128 | else | |
129 | { | |
130 | if (a_size == 0) | |
131 | runtime_error ("Incorrect size of %s of %s" | |
132 | " intrinsic: Should not be zero-sized", | |
133 | a_name, intrinsic); | |
134 | ||
135 | for (n = 0; n < GFC_DESCRIPTOR_RANK (b); n++) | |
136 | { | |
137 | index_type a_extent, b_extent; | |
138 | ||
139 | a_extent = GFC_DESCRIPTOR_EXTENT(a, n); | |
140 | b_extent = GFC_DESCRIPTOR_EXTENT(b, n); | |
141 | if (a_extent != b_extent) | |
142 | runtime_error("Incorrect extent in %s of %s" | |
143 | " intrinsic in dimension %ld: is %ld," | |
144 | " should be %ld", a_name, intrinsic, (long int) n + 1, | |
145 | (long int) a_extent, (long int) b_extent); | |
146 | } | |
147 | } | |
148 | } | |
149 | ||
150 | /* Check that the extents of a and b agree, except that a has a missing | |
151 | dimension in argument which. Complain about a if anything is wrong. */ | |
152 | ||
153 | void | |
154 | bounds_reduced_extents (array_t *a, array_t *b, int which, const char *a_name, | |
155 | const char *intrinsic) | |
156 | { | |
157 | ||
158 | index_type i, n, a_size, b_size; | |
159 | ||
160 | assert (GFC_DESCRIPTOR_RANK(a) == GFC_DESCRIPTOR_RANK(b) - 1); | |
161 | ||
162 | a_size = size0 (a); | |
163 | b_size = size0 (b); | |
164 | ||
165 | if (b_size == 0) | |
166 | { | |
167 | if (a_size != 0) | |
168 | runtime_error ("Incorrect size in %s of %s" | |
169 | " intrinsic: should not be zero-sized", | |
170 | a_name, intrinsic); | |
171 | } | |
172 | else | |
173 | { | |
174 | if (a_size == 0) | |
175 | runtime_error ("Incorrect size of %s of %s" | |
176 | " intrinsic: should be zero-sized", | |
177 | a_name, intrinsic); | |
178 | ||
179 | i = 0; | |
180 | for (n = 0; n < GFC_DESCRIPTOR_RANK (b); n++) | |
181 | { | |
182 | index_type a_extent, b_extent; | |
183 | ||
184 | if (n != which) | |
185 | { | |
186 | a_extent = GFC_DESCRIPTOR_EXTENT(a, i); | |
187 | b_extent = GFC_DESCRIPTOR_EXTENT(b, n); | |
188 | if (a_extent != b_extent) | |
189 | runtime_error("Incorrect extent in %s of %s" | |
190 | " intrinsic in dimension %ld: is %ld," | |
191 | " should be %ld", a_name, intrinsic, (long int) i + 1, | |
192 | (long int) a_extent, (long int) b_extent); | |
193 | i++; | |
194 | } | |
195 | } | |
196 | } | |
197 | } | |
0d8ca6ab | 198 | |
199 | /* count_0 - count all the true elements in an array. The front | |
200 | end usually inlines this, we need this for bounds checking | |
201 | for unpack. */ | |
202 | ||
203 | index_type count_0 (const gfc_array_l1 * array) | |
204 | { | |
205 | const GFC_LOGICAL_1 * restrict base; | |
206 | index_type rank; | |
207 | int kind; | |
208 | int continue_loop; | |
209 | index_type count[GFC_MAX_DIMENSIONS]; | |
210 | index_type extent[GFC_MAX_DIMENSIONS]; | |
211 | index_type sstride[GFC_MAX_DIMENSIONS]; | |
212 | index_type result; | |
213 | index_type n; | |
214 | ||
215 | rank = GFC_DESCRIPTOR_RANK (array); | |
216 | kind = GFC_DESCRIPTOR_SIZE (array); | |
217 | ||
553877d9 | 218 | base = array->base_addr; |
0d8ca6ab | 219 | |
220 | if (kind == 1 || kind == 2 || kind == 4 || kind == 8 | |
221 | #ifdef HAVE_GFC_LOGICAL_16 | |
222 | || kind == 16 | |
223 | #endif | |
224 | ) | |
225 | { | |
226 | if (base) | |
227 | base = GFOR_POINTER_TO_L1 (base, kind); | |
228 | } | |
229 | else | |
230 | internal_error (NULL, "Funny sized logical array in count_0"); | |
231 | ||
232 | for (n = 0; n < rank; n++) | |
233 | { | |
234 | sstride[n] = GFC_DESCRIPTOR_STRIDE_BYTES(array,n); | |
235 | extent[n] = GFC_DESCRIPTOR_EXTENT(array,n); | |
236 | count[n] = 0; | |
237 | ||
4055b367 | 238 | if (extent[n] <= 0) |
0d8ca6ab | 239 | return 0; |
240 | } | |
241 | ||
242 | result = 0; | |
243 | continue_loop = 1; | |
244 | while (continue_loop) | |
245 | { | |
246 | if (*base) | |
247 | result ++; | |
248 | ||
249 | count[0]++; | |
250 | base += sstride[0]; | |
251 | n = 0; | |
252 | while (count[n] == extent[n]) | |
253 | { | |
254 | count[n] = 0; | |
255 | base -= sstride[n] * extent[n]; | |
256 | n++; | |
257 | if (n == rank) | |
258 | { | |
259 | continue_loop = 0; | |
260 | break; | |
261 | } | |
262 | else | |
263 | { | |
264 | count[n]++; | |
265 | base += sstride[n]; | |
266 | } | |
267 | } | |
268 | } | |
269 | return result; | |
270 | } |