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