]>
Commit | Line | Data |
---|---|---|
6de9cd9a | 1 | /* Statement translation -- generate GCC trees from gfc_code. |
fa502cb2 | 2 | Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010 |
bfcabc6c | 3 | Free Software Foundation, Inc. |
6de9cd9a DN |
4 | Contributed by Paul Brook <paul@nowt.org> |
5 | and Steven Bosscher <s.bosscher@student.tudelft.nl> | |
6 | ||
9fc4d79b | 7 | This file is part of GCC. |
6de9cd9a | 8 | |
9fc4d79b TS |
9 | GCC is free software; you can redistribute it and/or modify it under |
10 | the terms of the GNU General Public License as published by the Free | |
d234d788 | 11 | Software Foundation; either version 3, or (at your option) any later |
9fc4d79b | 12 | version. |
6de9cd9a | 13 | |
9fc4d79b TS |
14 | GCC is distributed in the hope that it will be useful, but WITHOUT ANY |
15 | WARRANTY; without even the implied warranty of MERCHANTABILITY or | |
16 | FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License | |
17 | for more details. | |
6de9cd9a DN |
18 | |
19 | You should have received a copy of the GNU General Public License | |
d234d788 NC |
20 | along with GCC; see the file COPYING3. If not see |
21 | <http://www.gnu.org/licenses/>. */ | |
6de9cd9a DN |
22 | |
23 | ||
24 | #include "config.h" | |
25 | #include "system.h" | |
26 | #include "coretypes.h" | |
27 | #include "tree.h" | |
6de9cd9a | 28 | #include "gfortran.h" |
dd18a33b | 29 | #include "flags.h" |
6de9cd9a DN |
30 | #include "trans.h" |
31 | #include "trans-stmt.h" | |
32 | #include "trans-types.h" | |
33 | #include "trans-array.h" | |
34 | #include "trans-const.h" | |
35 | #include "arith.h" | |
3ded6210 | 36 | #include "dependency.h" |
d2886bc7 | 37 | #include "ggc.h" |
6de9cd9a | 38 | |
6de9cd9a DN |
39 | typedef struct iter_info |
40 | { | |
41 | tree var; | |
42 | tree start; | |
43 | tree end; | |
44 | tree step; | |
45 | struct iter_info *next; | |
46 | } | |
47 | iter_info; | |
48 | ||
6de9cd9a DN |
49 | typedef struct forall_info |
50 | { | |
51 | iter_info *this_loop; | |
52 | tree mask; | |
6de9cd9a DN |
53 | tree maskindex; |
54 | int nvar; | |
55 | tree size; | |
e8d366ec | 56 | struct forall_info *prev_nest; |
6de9cd9a DN |
57 | } |
58 | forall_info; | |
59 | ||
011daa76 RS |
60 | static void gfc_trans_where_2 (gfc_code *, tree, bool, |
61 | forall_info *, stmtblock_t *); | |
6de9cd9a DN |
62 | |
63 | /* Translate a F95 label number to a LABEL_EXPR. */ | |
64 | ||
65 | tree | |
66 | gfc_trans_label_here (gfc_code * code) | |
67 | { | |
68 | return build1_v (LABEL_EXPR, gfc_get_label_decl (code->here)); | |
69 | } | |
70 | ||
ce2df7c6 FW |
71 | |
72 | /* Given a variable expression which has been ASSIGNed to, find the decl | |
73 | containing the auxiliary variables. For variables in common blocks this | |
74 | is a field_decl. */ | |
75 | ||
76 | void | |
77 | gfc_conv_label_variable (gfc_se * se, gfc_expr * expr) | |
78 | { | |
79 | gcc_assert (expr->symtree->n.sym->attr.assign == 1); | |
80 | gfc_conv_expr (se, expr); | |
81 | /* Deals with variable in common block. Get the field declaration. */ | |
82 | if (TREE_CODE (se->expr) == COMPONENT_REF) | |
83 | se->expr = TREE_OPERAND (se->expr, 1); | |
910450c1 FW |
84 | /* Deals with dummy argument. Get the parameter declaration. */ |
85 | else if (TREE_CODE (se->expr) == INDIRECT_REF) | |
86 | se->expr = TREE_OPERAND (se->expr, 0); | |
ce2df7c6 FW |
87 | } |
88 | ||
6de9cd9a | 89 | /* Translate a label assignment statement. */ |
ce2df7c6 | 90 | |
6de9cd9a DN |
91 | tree |
92 | gfc_trans_label_assign (gfc_code * code) | |
93 | { | |
94 | tree label_tree; | |
95 | gfc_se se; | |
96 | tree len; | |
97 | tree addr; | |
98 | tree len_tree; | |
6de9cd9a DN |
99 | int label_len; |
100 | ||
101 | /* Start a new block. */ | |
102 | gfc_init_se (&se, NULL); | |
103 | gfc_start_block (&se.pre); | |
a513927a | 104 | gfc_conv_label_variable (&se, code->expr1); |
ce2df7c6 | 105 | |
6de9cd9a DN |
106 | len = GFC_DECL_STRING_LEN (se.expr); |
107 | addr = GFC_DECL_ASSIGN_ADDR (se.expr); | |
108 | ||
79bd1948 | 109 | label_tree = gfc_get_label_decl (code->label1); |
6de9cd9a | 110 | |
79bd1948 | 111 | if (code->label1->defined == ST_LABEL_TARGET) |
6de9cd9a DN |
112 | { |
113 | label_tree = gfc_build_addr_expr (pvoid_type_node, label_tree); | |
114 | len_tree = integer_minus_one_node; | |
115 | } | |
116 | else | |
117 | { | |
79bd1948 | 118 | gfc_expr *format = code->label1->format; |
d393bbd7 FXC |
119 | |
120 | label_len = format->value.character.length; | |
7d60be94 | 121 | len_tree = build_int_cst (NULL_TREE, label_len); |
d393bbd7 FXC |
122 | label_tree = gfc_build_wide_string_const (format->ts.kind, label_len + 1, |
123 | format->value.character.string); | |
b078dfbf | 124 | label_tree = gfc_build_addr_expr (pvoid_type_node, label_tree); |
6de9cd9a DN |
125 | } |
126 | ||
726a989a RB |
127 | gfc_add_modify (&se.pre, len, len_tree); |
128 | gfc_add_modify (&se.pre, addr, label_tree); | |
6de9cd9a DN |
129 | |
130 | return gfc_finish_block (&se.pre); | |
131 | } | |
132 | ||
133 | /* Translate a GOTO statement. */ | |
134 | ||
135 | tree | |
136 | gfc_trans_goto (gfc_code * code) | |
137 | { | |
dd18a33b | 138 | locus loc = code->loc; |
6de9cd9a DN |
139 | tree assigned_goto; |
140 | tree target; | |
141 | tree tmp; | |
6de9cd9a DN |
142 | gfc_se se; |
143 | ||
79bd1948 SK |
144 | if (code->label1 != NULL) |
145 | return build1_v (GOTO_EXPR, gfc_get_label_decl (code->label1)); | |
6de9cd9a DN |
146 | |
147 | /* ASSIGNED GOTO. */ | |
148 | gfc_init_se (&se, NULL); | |
149 | gfc_start_block (&se.pre); | |
a513927a | 150 | gfc_conv_label_variable (&se, code->expr1); |
6de9cd9a | 151 | tmp = GFC_DECL_STRING_LEN (se.expr); |
bc98ed60 TB |
152 | tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, tmp, |
153 | build_int_cst (TREE_TYPE (tmp), -1)); | |
0d52899f | 154 | gfc_trans_runtime_check (true, false, tmp, &se.pre, &loc, |
c8fe94c7 | 155 | "Assigned label is not a target label"); |
6de9cd9a DN |
156 | |
157 | assigned_goto = GFC_DECL_ASSIGN_ADDR (se.expr); | |
6de9cd9a | 158 | |
916bd5f0 DK |
159 | /* We're going to ignore a label list. It does not really change the |
160 | statement's semantics (because it is just a further restriction on | |
161 | what's legal code); before, we were comparing label addresses here, but | |
162 | that's a very fragile business and may break with optimization. So | |
163 | just ignore it. */ | |
164 | ||
bc98ed60 TB |
165 | target = fold_build1_loc (input_location, GOTO_EXPR, void_type_node, |
166 | assigned_goto); | |
916bd5f0 DK |
167 | gfc_add_expr_to_block (&se.pre, target); |
168 | return gfc_finish_block (&se.pre); | |
6de9cd9a DN |
169 | } |
170 | ||
171 | ||
3d79abbd PB |
172 | /* Translate an ENTRY statement. Just adds a label for this entry point. */ |
173 | tree | |
174 | gfc_trans_entry (gfc_code * code) | |
175 | { | |
176 | return build1_v (LABEL_EXPR, code->ext.entry->label); | |
177 | } | |
178 | ||
179 | ||
476220e7 PT |
180 | /* Check for dependencies between INTENT(IN) and INTENT(OUT) arguments of |
181 | elemental subroutines. Make temporaries for output arguments if any such | |
182 | dependencies are found. Output arguments are chosen because internal_unpack | |
183 | can be used, as is, to copy the result back to the variable. */ | |
184 | static void | |
185 | gfc_conv_elemental_dependencies (gfc_se * se, gfc_se * loopse, | |
2b0bd714 MM |
186 | gfc_symbol * sym, gfc_actual_arglist * arg, |
187 | gfc_dep_check check_variable) | |
476220e7 PT |
188 | { |
189 | gfc_actual_arglist *arg0; | |
190 | gfc_expr *e; | |
191 | gfc_formal_arglist *formal; | |
192 | gfc_loopinfo tmp_loop; | |
193 | gfc_se parmse; | |
194 | gfc_ss *ss; | |
195 | gfc_ss_info *info; | |
196 | gfc_symbol *fsym; | |
3c3b62d1 | 197 | gfc_ref *ref; |
476220e7 | 198 | int n; |
476220e7 PT |
199 | tree data; |
200 | tree offset; | |
201 | tree size; | |
202 | tree tmp; | |
203 | ||
204 | if (loopse->ss == NULL) | |
205 | return; | |
206 | ||
207 | ss = loopse->ss; | |
208 | arg0 = arg; | |
209 | formal = sym->formal; | |
210 | ||
211 | /* Loop over all the arguments testing for dependencies. */ | |
212 | for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL) | |
213 | { | |
214 | e = arg->expr; | |
215 | if (e == NULL) | |
216 | continue; | |
217 | ||
218 | /* Obtain the info structure for the current argument. */ | |
219 | info = NULL; | |
220 | for (ss = loopse->ss; ss && ss != gfc_ss_terminator; ss = ss->next) | |
221 | { | |
222 | if (ss->expr != e) | |
223 | continue; | |
224 | info = &ss->data.info; | |
225 | break; | |
226 | } | |
227 | ||
228 | /* If there is a dependency, create a temporary and use it | |
66e4ab31 | 229 | instead of the variable. */ |
476220e7 PT |
230 | fsym = formal ? formal->sym : NULL; |
231 | if (e->expr_type == EXPR_VARIABLE | |
232 | && e->rank && fsym | |
06bcd751 PT |
233 | && fsym->attr.intent != INTENT_IN |
234 | && gfc_check_fncall_dependency (e, fsym->attr.intent, | |
2b0bd714 | 235 | sym, arg0, check_variable)) |
476220e7 | 236 | { |
79e5286c | 237 | tree initial, temptype; |
12f681a0 DK |
238 | stmtblock_t temp_post; |
239 | ||
476220e7 PT |
240 | /* Make a local loopinfo for the temporary creation, so that |
241 | none of the other ss->info's have to be renormalized. */ | |
242 | gfc_init_loopinfo (&tmp_loop); | |
ea5e803f | 243 | tmp_loop.dimen = info->dimen; |
476220e7 PT |
244 | for (n = 0; n < info->dimen; n++) |
245 | { | |
246 | tmp_loop.to[n] = loopse->loop->to[n]; | |
247 | tmp_loop.from[n] = loopse->loop->from[n]; | |
248 | tmp_loop.order[n] = loopse->loop->order[n]; | |
249 | } | |
250 | ||
12f681a0 DK |
251 | /* Obtain the argument descriptor for unpacking. */ |
252 | gfc_init_se (&parmse, NULL); | |
253 | parmse.want_pointer = 1; | |
3c3b62d1 PT |
254 | |
255 | /* The scalarizer introduces some specific peculiarities when | |
256 | handling elemental subroutines; the stride can be needed up to | |
257 | the dim_array - 1, rather than dim_loop - 1 to calculate | |
258 | offsets outside the loop. For this reason, we make sure that | |
259 | the descriptor has the dimensionality of the array by converting | |
260 | trailing elements into ranges with end = start. */ | |
261 | for (ref = e->ref; ref; ref = ref->next) | |
262 | if (ref->type == REF_ARRAY && ref->u.ar.type == AR_SECTION) | |
263 | break; | |
264 | ||
265 | if (ref) | |
266 | { | |
267 | bool seen_range = false; | |
268 | for (n = 0; n < ref->u.ar.dimen; n++) | |
269 | { | |
270 | if (ref->u.ar.dimen_type[n] == DIMEN_RANGE) | |
271 | seen_range = true; | |
272 | ||
273 | if (!seen_range | |
274 | || ref->u.ar.dimen_type[n] != DIMEN_ELEMENT) | |
275 | continue; | |
276 | ||
277 | ref->u.ar.end[n] = gfc_copy_expr (ref->u.ar.start[n]); | |
278 | ref->u.ar.dimen_type[n] = DIMEN_RANGE; | |
279 | } | |
280 | } | |
281 | ||
12f681a0 DK |
282 | gfc_conv_expr_descriptor (&parmse, e, gfc_walk_expr (e)); |
283 | gfc_add_block_to_block (&se->pre, &parmse.pre); | |
284 | ||
eb74e79b PT |
285 | /* If we've got INTENT(INOUT) or a derived type with INTENT(OUT), |
286 | initialize the array temporary with a copy of the values. */ | |
287 | if (fsym->attr.intent == INTENT_INOUT | |
288 | || (fsym->ts.type ==BT_DERIVED | |
289 | && fsym->attr.intent == INTENT_OUT)) | |
12f681a0 DK |
290 | initial = parmse.expr; |
291 | else | |
292 | initial = NULL_TREE; | |
293 | ||
79e5286c DK |
294 | /* Find the type of the temporary to create; we don't use the type |
295 | of e itself as this breaks for subcomponent-references in e (where | |
296 | the type of e is that of the final reference, but parmse.expr's | |
297 | type corresponds to the full derived-type). */ | |
298 | /* TODO: Fix this somehow so we don't need a temporary of the whole | |
299 | array but instead only the components referenced. */ | |
300 | temptype = TREE_TYPE (parmse.expr); /* Pointer to descriptor. */ | |
301 | gcc_assert (TREE_CODE (temptype) == POINTER_TYPE); | |
302 | temptype = TREE_TYPE (temptype); | |
303 | temptype = gfc_get_element_type (temptype); | |
304 | ||
305 | /* Generate the temporary. Cleaning up the temporary should be the | |
306 | very last thing done, so we add the code to a new block and add it | |
307 | to se->post as last instructions. */ | |
476220e7 PT |
308 | size = gfc_create_var (gfc_array_index_type, NULL); |
309 | data = gfc_create_var (pvoid_type_node, NULL); | |
12f681a0 | 310 | gfc_init_block (&temp_post); |
12f681a0 | 311 | tmp = gfc_trans_create_temp_array (&se->pre, &temp_post, |
79e5286c | 312 | &tmp_loop, info, temptype, |
12f681a0 DK |
313 | initial, |
314 | false, true, false, | |
315 | &arg->expr->where); | |
726a989a | 316 | gfc_add_modify (&se->pre, size, tmp); |
476220e7 | 317 | tmp = fold_convert (pvoid_type_node, info->data); |
726a989a | 318 | gfc_add_modify (&se->pre, data, tmp); |
476220e7 | 319 | |
476220e7 PT |
320 | /* Calculate the offset for the temporary. */ |
321 | offset = gfc_index_zero_node; | |
322 | for (n = 0; n < info->dimen; n++) | |
323 | { | |
568e8e1e PT |
324 | tmp = gfc_conv_descriptor_stride_get (info->descriptor, |
325 | gfc_rank_cst[n]); | |
bc98ed60 TB |
326 | tmp = fold_build2_loc (input_location, MULT_EXPR, |
327 | gfc_array_index_type, | |
328 | loopse->loop->from[n], tmp); | |
329 | offset = fold_build2_loc (input_location, MINUS_EXPR, | |
330 | gfc_array_index_type, offset, tmp); | |
476220e7 PT |
331 | } |
332 | info->offset = gfc_create_var (gfc_array_index_type, NULL); | |
726a989a | 333 | gfc_add_modify (&se->pre, info->offset, offset); |
476220e7 PT |
334 | |
335 | /* Copy the result back using unpack. */ | |
db3927fb AH |
336 | tmp = build_call_expr_loc (input_location, |
337 | gfor_fndecl_in_unpack, 2, parmse.expr, data); | |
476220e7 PT |
338 | gfc_add_expr_to_block (&se->post, tmp); |
339 | ||
79e5286c | 340 | /* parmse.pre is already added above. */ |
476220e7 | 341 | gfc_add_block_to_block (&se->post, &parmse.post); |
12f681a0 | 342 | gfc_add_block_to_block (&se->post, &temp_post); |
476220e7 PT |
343 | } |
344 | } | |
345 | } | |
346 | ||
347 | ||
6de9cd9a DN |
348 | /* Translate the CALL statement. Builds a call to an F95 subroutine. */ |
349 | ||
350 | tree | |
eb74e79b PT |
351 | gfc_trans_call (gfc_code * code, bool dependency_check, |
352 | tree mask, tree count1, bool invert) | |
6de9cd9a DN |
353 | { |
354 | gfc_se se; | |
48474141 | 355 | gfc_ss * ss; |
dda895f9 | 356 | int has_alternate_specifier; |
2b0bd714 | 357 | gfc_dep_check check_variable; |
eb74e79b PT |
358 | tree index = NULL_TREE; |
359 | tree maskexpr = NULL_TREE; | |
360 | tree tmp; | |
6de9cd9a DN |
361 | |
362 | /* A CALL starts a new block because the actual arguments may have to | |
363 | be evaluated first. */ | |
364 | gfc_init_se (&se, NULL); | |
365 | gfc_start_block (&se.pre); | |
366 | ||
6e45f57b | 367 | gcc_assert (code->resolved_sym); |
6de9cd9a | 368 | |
48474141 PT |
369 | ss = gfc_ss_terminator; |
370 | if (code->resolved_sym->attr.elemental) | |
371 | ss = gfc_walk_elemental_function_args (ss, code->ext.actual, GFC_SS_REFERENCE); | |
6de9cd9a | 372 | |
48474141 PT |
373 | /* Is not an elemental subroutine call with array valued arguments. */ |
374 | if (ss == gfc_ss_terminator) | |
6de9cd9a | 375 | { |
48474141 PT |
376 | |
377 | /* Translate the call. */ | |
378 | has_alternate_specifier | |
713485cc | 379 | = gfc_conv_procedure_call (&se, code->resolved_sym, code->ext.actual, |
989ea525 | 380 | code->expr1, NULL); |
48474141 PT |
381 | |
382 | /* A subroutine without side-effect, by definition, does nothing! */ | |
383 | TREE_SIDE_EFFECTS (se.expr) = 1; | |
384 | ||
385 | /* Chain the pieces together and return the block. */ | |
386 | if (has_alternate_specifier) | |
387 | { | |
388 | gfc_code *select_code; | |
389 | gfc_symbol *sym; | |
390 | select_code = code->next; | |
391 | gcc_assert(select_code->op == EXEC_SELECT); | |
a513927a | 392 | sym = select_code->expr1->symtree->n.sym; |
48474141 | 393 | se.expr = convert (gfc_typenode_for_spec (&sym->ts), se.expr); |
9ebe2d22 PT |
394 | if (sym->backend_decl == NULL) |
395 | sym->backend_decl = gfc_get_symbol_decl (sym); | |
726a989a | 396 | gfc_add_modify (&se.pre, sym->backend_decl, se.expr); |
48474141 PT |
397 | } |
398 | else | |
399 | gfc_add_expr_to_block (&se.pre, se.expr); | |
400 | ||
401 | gfc_add_block_to_block (&se.pre, &se.post); | |
6de9cd9a | 402 | } |
48474141 | 403 | |
6de9cd9a | 404 | else |
48474141 PT |
405 | { |
406 | /* An elemental subroutine call with array valued arguments has | |
407 | to be scalarized. */ | |
408 | gfc_loopinfo loop; | |
409 | stmtblock_t body; | |
410 | stmtblock_t block; | |
411 | gfc_se loopse; | |
70e72065 | 412 | gfc_se depse; |
48474141 PT |
413 | |
414 | /* gfc_walk_elemental_function_args renders the ss chain in the | |
12f681a0 | 415 | reverse order to the actual argument order. */ |
48474141 PT |
416 | ss = gfc_reverse_ss (ss); |
417 | ||
418 | /* Initialize the loop. */ | |
419 | gfc_init_se (&loopse, NULL); | |
420 | gfc_init_loopinfo (&loop); | |
421 | gfc_add_ss_to_loop (&loop, ss); | |
422 | ||
423 | gfc_conv_ss_startstride (&loop); | |
2b0bd714 MM |
424 | /* TODO: gfc_conv_loop_setup generates a temporary for vector |
425 | subscripts. This could be prevented in the elemental case | |
426 | as temporaries are handled separatedly | |
427 | (below in gfc_conv_elemental_dependencies). */ | |
a513927a | 428 | gfc_conv_loop_setup (&loop, &code->expr1->where); |
48474141 PT |
429 | gfc_mark_ss_chain_used (ss, 1); |
430 | ||
476220e7 PT |
431 | /* Convert the arguments, checking for dependencies. */ |
432 | gfc_copy_loopinfo_to_se (&loopse, &loop); | |
433 | loopse.ss = ss; | |
434 | ||
06bcd751 | 435 | /* For operator assignment, do dependency checking. */ |
476220e7 | 436 | if (dependency_check) |
2b0bd714 MM |
437 | check_variable = ELEM_CHECK_VARIABLE; |
438 | else | |
439 | check_variable = ELEM_DONT_CHECK_VARIABLE; | |
70e72065 MM |
440 | |
441 | gfc_init_se (&depse, NULL); | |
442 | gfc_conv_elemental_dependencies (&depse, &loopse, code->resolved_sym, | |
2b0bd714 | 443 | code->ext.actual, check_variable); |
476220e7 | 444 | |
70e72065 MM |
445 | gfc_add_block_to_block (&loop.pre, &depse.pre); |
446 | gfc_add_block_to_block (&loop.post, &depse.post); | |
447 | ||
48474141 PT |
448 | /* Generate the loop body. */ |
449 | gfc_start_scalarized_body (&loop, &body); | |
450 | gfc_init_block (&block); | |
48474141 | 451 | |
eb74e79b PT |
452 | if (mask && count1) |
453 | { | |
454 | /* Form the mask expression according to the mask. */ | |
455 | index = count1; | |
456 | maskexpr = gfc_build_array_ref (mask, index, NULL); | |
457 | if (invert) | |
bc98ed60 TB |
458 | maskexpr = fold_build1_loc (input_location, TRUTH_NOT_EXPR, |
459 | TREE_TYPE (maskexpr), maskexpr); | |
eb74e79b PT |
460 | } |
461 | ||
48474141 | 462 | /* Add the subroutine call to the block. */ |
eb74e79b | 463 | gfc_conv_procedure_call (&loopse, code->resolved_sym, |
989ea525 | 464 | code->ext.actual, code->expr1, NULL); |
eb74e79b PT |
465 | |
466 | if (mask && count1) | |
467 | { | |
468 | tmp = build3_v (COND_EXPR, maskexpr, loopse.expr, | |
c2255bc4 | 469 | build_empty_stmt (input_location)); |
eb74e79b | 470 | gfc_add_expr_to_block (&loopse.pre, tmp); |
bc98ed60 TB |
471 | tmp = fold_build2_loc (input_location, PLUS_EXPR, |
472 | gfc_array_index_type, | |
473 | count1, gfc_index_one_node); | |
eb74e79b PT |
474 | gfc_add_modify (&loopse.pre, count1, tmp); |
475 | } | |
476 | else | |
477 | gfc_add_expr_to_block (&loopse.pre, loopse.expr); | |
48474141 PT |
478 | |
479 | gfc_add_block_to_block (&block, &loopse.pre); | |
480 | gfc_add_block_to_block (&block, &loopse.post); | |
481 | ||
482 | /* Finish up the loop block and the loop. */ | |
483 | gfc_add_expr_to_block (&body, gfc_finish_block (&block)); | |
484 | gfc_trans_scalarizing_loops (&loop, &body); | |
485 | gfc_add_block_to_block (&se.pre, &loop.pre); | |
486 | gfc_add_block_to_block (&se.pre, &loop.post); | |
476220e7 | 487 | gfc_add_block_to_block (&se.pre, &se.post); |
48474141 PT |
488 | gfc_cleanup_loop (&loop); |
489 | } | |
6de9cd9a | 490 | |
6de9cd9a DN |
491 | return gfc_finish_block (&se.pre); |
492 | } | |
493 | ||
494 | ||
495 | /* Translate the RETURN statement. */ | |
496 | ||
497 | tree | |
d74d8807 | 498 | gfc_trans_return (gfc_code * code) |
6de9cd9a | 499 | { |
a513927a | 500 | if (code->expr1) |
6de9cd9a DN |
501 | { |
502 | gfc_se se; | |
503 | tree tmp; | |
504 | tree result; | |
505 | ||
da4c6ed8 | 506 | /* If code->expr is not NULL, this return statement must appear |
d74d8807 | 507 | in a subroutine and current_fake_result_decl has already |
6de9cd9a DN |
508 | been generated. */ |
509 | ||
5f20c93a | 510 | result = gfc_get_fake_result_decl (NULL, 0); |
6de9cd9a | 511 | if (!result) |
d74d8807 DK |
512 | { |
513 | gfc_warning ("An alternate return at %L without a * dummy argument", | |
514 | &code->expr1->where); | |
515 | return gfc_generate_return (); | |
516 | } | |
6de9cd9a DN |
517 | |
518 | /* Start a new block for this statement. */ | |
519 | gfc_init_se (&se, NULL); | |
520 | gfc_start_block (&se.pre); | |
521 | ||
a513927a | 522 | gfc_conv_expr (&se, code->expr1); |
6de9cd9a | 523 | |
ba3ff5c2 DK |
524 | /* Note that the actually returned expression is a simple value and |
525 | does not depend on any pointers or such; thus we can clean-up with | |
526 | se.post before returning. */ | |
bc98ed60 TB |
527 | tmp = fold_build2_loc (input_location, MODIFY_EXPR, TREE_TYPE (result), |
528 | result, fold_convert (TREE_TYPE (result), | |
529 | se.expr)); | |
6de9cd9a | 530 | gfc_add_expr_to_block (&se.pre, tmp); |
ba3ff5c2 | 531 | gfc_add_block_to_block (&se.pre, &se.post); |
6de9cd9a | 532 | |
d74d8807 | 533 | tmp = gfc_generate_return (); |
6de9cd9a | 534 | gfc_add_expr_to_block (&se.pre, tmp); |
6de9cd9a DN |
535 | return gfc_finish_block (&se.pre); |
536 | } | |
d74d8807 DK |
537 | |
538 | return gfc_generate_return (); | |
6de9cd9a DN |
539 | } |
540 | ||
541 | ||
542 | /* Translate the PAUSE statement. We have to translate this statement | |
543 | to a runtime library call. */ | |
544 | ||
545 | tree | |
546 | gfc_trans_pause (gfc_code * code) | |
547 | { | |
e2cad04b | 548 | tree gfc_int4_type_node = gfc_get_int_type (4); |
6de9cd9a | 549 | gfc_se se; |
6de9cd9a | 550 | tree tmp; |
6de9cd9a DN |
551 | |
552 | /* Start a new block for this statement. */ | |
553 | gfc_init_se (&se, NULL); | |
554 | gfc_start_block (&se.pre); | |
555 | ||
556 | ||
a513927a | 557 | if (code->expr1 == NULL) |
6de9cd9a | 558 | { |
6d1b0f92 | 559 | tmp = build_int_cst (gfc_int4_type_node, 0); |
db3927fb | 560 | tmp = build_call_expr_loc (input_location, |
6d1b0f92 JD |
561 | gfor_fndecl_pause_string, 2, |
562 | build_int_cst (pchar_type_node, 0), tmp); | |
563 | } | |
564 | else if (code->expr1->ts.type == BT_INTEGER) | |
565 | { | |
566 | gfc_conv_expr (&se, code->expr1); | |
567 | tmp = build_call_expr_loc (input_location, | |
568 | gfor_fndecl_pause_numeric, 1, | |
569 | fold_convert (gfc_int4_type_node, se.expr)); | |
6de9cd9a DN |
570 | } |
571 | else | |
572 | { | |
a513927a | 573 | gfc_conv_expr_reference (&se, code->expr1); |
db3927fb AH |
574 | tmp = build_call_expr_loc (input_location, |
575 | gfor_fndecl_pause_string, 2, | |
5039610b | 576 | se.expr, se.string_length); |
6de9cd9a DN |
577 | } |
578 | ||
6de9cd9a DN |
579 | gfc_add_expr_to_block (&se.pre, tmp); |
580 | ||
581 | gfc_add_block_to_block (&se.pre, &se.post); | |
582 | ||
583 | return gfc_finish_block (&se.pre); | |
584 | } | |
585 | ||
586 | ||
587 | /* Translate the STOP statement. We have to translate this statement | |
588 | to a runtime library call. */ | |
589 | ||
590 | tree | |
d0a4a61c | 591 | gfc_trans_stop (gfc_code *code, bool error_stop) |
6de9cd9a | 592 | { |
e2cad04b | 593 | tree gfc_int4_type_node = gfc_get_int_type (4); |
6de9cd9a | 594 | gfc_se se; |
6de9cd9a | 595 | tree tmp; |
6de9cd9a DN |
596 | |
597 | /* Start a new block for this statement. */ | |
598 | gfc_init_se (&se, NULL); | |
599 | gfc_start_block (&se.pre); | |
600 | ||
a513927a | 601 | if (code->expr1 == NULL) |
6de9cd9a | 602 | { |
6d1b0f92 JD |
603 | tmp = build_int_cst (gfc_int4_type_node, 0); |
604 | tmp = build_call_expr_loc (input_location, | |
cea59ace | 605 | error_stop ? gfor_fndecl_error_stop_string |
6d1b0f92 | 606 | : gfor_fndecl_stop_string, |
cea59ace | 607 | 2, build_int_cst (pchar_type_node, 0), tmp); |
6d1b0f92 JD |
608 | } |
609 | else if (code->expr1->ts.type == BT_INTEGER) | |
610 | { | |
611 | gfc_conv_expr (&se, code->expr1); | |
db3927fb | 612 | tmp = build_call_expr_loc (input_location, |
cea59ace JD |
613 | error_stop ? gfor_fndecl_error_stop_numeric |
614 | : gfor_fndecl_stop_numeric_f08, 1, | |
6d1b0f92 | 615 | fold_convert (gfc_int4_type_node, se.expr)); |
6de9cd9a DN |
616 | } |
617 | else | |
618 | { | |
a513927a | 619 | gfc_conv_expr_reference (&se, code->expr1); |
db3927fb | 620 | tmp = build_call_expr_loc (input_location, |
cea59ace | 621 | error_stop ? gfor_fndecl_error_stop_string |
6d1b0f92 | 622 | : gfor_fndecl_stop_string, |
cea59ace | 623 | 2, se.expr, se.string_length); |
6de9cd9a DN |
624 | } |
625 | ||
6de9cd9a DN |
626 | gfc_add_expr_to_block (&se.pre, tmp); |
627 | ||
628 | gfc_add_block_to_block (&se.pre, &se.post); | |
629 | ||
630 | return gfc_finish_block (&se.pre); | |
631 | } | |
632 | ||
633 | ||
d0a4a61c TB |
634 | tree |
635 | gfc_trans_sync (gfc_code *code, gfc_exec_op type __attribute__ ((unused))) | |
636 | { | |
637 | gfc_se se; | |
638 | ||
639 | if ((code->expr1 && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)) || code->expr2) | |
640 | { | |
641 | gfc_init_se (&se, NULL); | |
642 | gfc_start_block (&se.pre); | |
643 | } | |
644 | ||
645 | /* Check SYNC IMAGES(imageset) for valid image index. | |
646 | FIXME: Add a check for image-set arrays. */ | |
647 | if (code->expr1 && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) | |
648 | && code->expr1->rank == 0) | |
649 | { | |
650 | tree cond; | |
651 | gfc_conv_expr (&se, code->expr1); | |
bc98ed60 TB |
652 | cond = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, |
653 | se.expr, build_int_cst (TREE_TYPE (se.expr), 1)); | |
d0a4a61c TB |
654 | gfc_trans_runtime_check (true, false, cond, &se.pre, |
655 | &code->expr1->where, "Invalid image number " | |
656 | "%d in SYNC IMAGES", | |
657 | fold_convert (integer_type_node, se.expr)); | |
658 | } | |
659 | ||
660 | /* If STAT is present, set it to zero. */ | |
661 | if (code->expr2) | |
662 | { | |
663 | gcc_assert (code->expr2->expr_type == EXPR_VARIABLE); | |
664 | gfc_conv_expr (&se, code->expr2); | |
665 | gfc_add_modify (&se.pre, se.expr, build_int_cst (TREE_TYPE (se.expr), 0)); | |
666 | } | |
667 | ||
668 | if ((code->expr1 && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS)) || code->expr2) | |
669 | return gfc_finish_block (&se.pre); | |
670 | ||
671 | return NULL_TREE; | |
672 | } | |
673 | ||
674 | ||
6de9cd9a DN |
675 | /* Generate GENERIC for the IF construct. This function also deals with |
676 | the simple IF statement, because the front end translates the IF | |
677 | statement into an IF construct. | |
678 | ||
679 | We translate: | |
680 | ||
681 | IF (cond) THEN | |
682 | then_clause | |
683 | ELSEIF (cond2) | |
684 | elseif_clause | |
685 | ELSE | |
686 | else_clause | |
687 | ENDIF | |
688 | ||
689 | into: | |
690 | ||
691 | pre_cond_s; | |
692 | if (cond_s) | |
693 | { | |
694 | then_clause; | |
695 | } | |
696 | else | |
697 | { | |
698 | pre_cond_s | |
699 | if (cond_s) | |
700 | { | |
701 | elseif_clause | |
702 | } | |
703 | else | |
704 | { | |
705 | else_clause; | |
706 | } | |
707 | } | |
708 | ||
709 | where COND_S is the simplified version of the predicate. PRE_COND_S | |
710 | are the pre side-effects produced by the translation of the | |
711 | conditional. | |
712 | We need to build the chain recursively otherwise we run into | |
713 | problems with folding incomplete statements. */ | |
714 | ||
715 | static tree | |
716 | gfc_trans_if_1 (gfc_code * code) | |
717 | { | |
718 | gfc_se if_se; | |
719 | tree stmt, elsestmt; | |
55bd9c35 | 720 | location_t loc; |
6de9cd9a DN |
721 | |
722 | /* Check for an unconditional ELSE clause. */ | |
a513927a | 723 | if (!code->expr1) |
6de9cd9a DN |
724 | return gfc_trans_code (code->next); |
725 | ||
726 | /* Initialize a statement builder for each block. Puts in NULL_TREEs. */ | |
727 | gfc_init_se (&if_se, NULL); | |
728 | gfc_start_block (&if_se.pre); | |
729 | ||
730 | /* Calculate the IF condition expression. */ | |
a513927a | 731 | gfc_conv_expr_val (&if_se, code->expr1); |
6de9cd9a DN |
732 | |
733 | /* Translate the THEN clause. */ | |
734 | stmt = gfc_trans_code (code->next); | |
735 | ||
736 | /* Translate the ELSE clause. */ | |
737 | if (code->block) | |
738 | elsestmt = gfc_trans_if_1 (code->block); | |
739 | else | |
c2255bc4 | 740 | elsestmt = build_empty_stmt (input_location); |
6de9cd9a DN |
741 | |
742 | /* Build the condition expression and add it to the condition block. */ | |
55bd9c35 TB |
743 | loc = code->expr1->where.lb ? code->expr1->where.lb->location : input_location; |
744 | stmt = fold_build3_loc (loc, COND_EXPR, void_type_node, if_se.expr, stmt, | |
745 | elsestmt); | |
6de9cd9a DN |
746 | |
747 | gfc_add_expr_to_block (&if_se.pre, stmt); | |
748 | ||
749 | /* Finish off this statement. */ | |
750 | return gfc_finish_block (&if_se.pre); | |
751 | } | |
752 | ||
753 | tree | |
754 | gfc_trans_if (gfc_code * code) | |
755 | { | |
e5ca9693 DK |
756 | stmtblock_t body; |
757 | tree exit_label; | |
758 | ||
759 | /* Create exit label so it is available for trans'ing the body code. */ | |
760 | exit_label = gfc_build_label_decl (NULL_TREE); | |
761 | code->exit_label = exit_label; | |
762 | ||
763 | /* Translate the actual code in code->block. */ | |
764 | gfc_init_block (&body); | |
765 | gfc_add_expr_to_block (&body, gfc_trans_if_1 (code->block)); | |
766 | ||
767 | /* Add exit label. */ | |
768 | gfc_add_expr_to_block (&body, build1_v (LABEL_EXPR, exit_label)); | |
6de9cd9a | 769 | |
e5ca9693 | 770 | return gfc_finish_block (&body); |
6de9cd9a DN |
771 | } |
772 | ||
773 | ||
fa951694 | 774 | /* Translate an arithmetic IF expression. |
6de9cd9a DN |
775 | |
776 | IF (cond) label1, label2, label3 translates to | |
777 | ||
778 | if (cond <= 0) | |
779 | { | |
780 | if (cond < 0) | |
781 | goto label1; | |
782 | else // cond == 0 | |
783 | goto label2; | |
784 | } | |
785 | else // cond > 0 | |
786 | goto label3; | |
442c1644 CY |
787 | |
788 | An optimized version can be generated in case of equal labels. | |
789 | E.g., if label1 is equal to label2, we can translate it to | |
790 | ||
791 | if (cond <= 0) | |
792 | goto label1; | |
793 | else | |
794 | goto label3; | |
6de9cd9a DN |
795 | */ |
796 | ||
797 | tree | |
798 | gfc_trans_arithmetic_if (gfc_code * code) | |
799 | { | |
800 | gfc_se se; | |
801 | tree tmp; | |
802 | tree branch1; | |
803 | tree branch2; | |
804 | tree zero; | |
805 | ||
806 | /* Start a new block. */ | |
807 | gfc_init_se (&se, NULL); | |
808 | gfc_start_block (&se.pre); | |
809 | ||
810 | /* Pre-evaluate COND. */ | |
a513927a | 811 | gfc_conv_expr_val (&se, code->expr1); |
5ec1334b | 812 | se.expr = gfc_evaluate_now (se.expr, &se.pre); |
6de9cd9a DN |
813 | |
814 | /* Build something to compare with. */ | |
815 | zero = gfc_build_const (TREE_TYPE (se.expr), integer_zero_node); | |
816 | ||
79bd1948 | 817 | if (code->label1->value != code->label2->value) |
442c1644 CY |
818 | { |
819 | /* If (cond < 0) take branch1 else take branch2. | |
820 | First build jumps to the COND .LT. 0 and the COND .EQ. 0 cases. */ | |
79bd1948 | 821 | branch1 = build1_v (GOTO_EXPR, gfc_get_label_decl (code->label1)); |
442c1644 CY |
822 | branch2 = build1_v (GOTO_EXPR, gfc_get_label_decl (code->label2)); |
823 | ||
79bd1948 | 824 | if (code->label1->value != code->label3->value) |
bc98ed60 TB |
825 | tmp = fold_build2_loc (input_location, LT_EXPR, boolean_type_node, |
826 | se.expr, zero); | |
442c1644 | 827 | else |
bc98ed60 TB |
828 | tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, |
829 | se.expr, zero); | |
6de9cd9a | 830 | |
bc98ed60 TB |
831 | branch1 = fold_build3_loc (input_location, COND_EXPR, void_type_node, |
832 | tmp, branch1, branch2); | |
442c1644 CY |
833 | } |
834 | else | |
79bd1948 | 835 | branch1 = build1_v (GOTO_EXPR, gfc_get_label_decl (code->label1)); |
6de9cd9a | 836 | |
79bd1948 | 837 | if (code->label1->value != code->label3->value |
442c1644 CY |
838 | && code->label2->value != code->label3->value) |
839 | { | |
840 | /* if (cond <= 0) take branch1 else take branch2. */ | |
841 | branch2 = build1_v (GOTO_EXPR, gfc_get_label_decl (code->label3)); | |
bc98ed60 TB |
842 | tmp = fold_build2_loc (input_location, LE_EXPR, boolean_type_node, |
843 | se.expr, zero); | |
844 | branch1 = fold_build3_loc (input_location, COND_EXPR, void_type_node, | |
845 | tmp, branch1, branch2); | |
442c1644 | 846 | } |
6de9cd9a DN |
847 | |
848 | /* Append the COND_EXPR to the evaluation of COND, and return. */ | |
849 | gfc_add_expr_to_block (&se.pre, branch1); | |
850 | return gfc_finish_block (&se.pre); | |
851 | } | |
852 | ||
853 | ||
d0a4a61c TB |
854 | /* Translate a CRITICAL block. */ |
855 | tree | |
856 | gfc_trans_critical (gfc_code *code) | |
857 | { | |
858 | stmtblock_t block; | |
859 | tree tmp; | |
860 | ||
861 | gfc_start_block (&block); | |
862 | tmp = gfc_trans_code (code->block->next); | |
863 | gfc_add_expr_to_block (&block, tmp); | |
864 | ||
865 | return gfc_finish_block (&block); | |
866 | } | |
867 | ||
868 | ||
6312ef45 JW |
869 | /* Do proper initialization for ASSOCIATE names. */ |
870 | ||
871 | static void | |
872 | trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block) | |
873 | { | |
874 | gfc_expr *e; | |
875 | tree tmp; | |
876 | ||
877 | gcc_assert (sym->assoc); | |
878 | e = sym->assoc->target; | |
879 | ||
880 | /* Do a `pointer assignment' with updated descriptor (or assign descriptor | |
881 | to array temporary) for arrays with either unknown shape or if associating | |
882 | to a variable. */ | |
883 | if (sym->attr.dimension | |
884 | && (sym->as->type == AS_DEFERRED || sym->assoc->variable)) | |
885 | { | |
886 | gfc_se se; | |
887 | gfc_ss *ss; | |
888 | tree desc; | |
889 | ||
890 | desc = sym->backend_decl; | |
891 | ||
892 | /* If association is to an expression, evaluate it and create temporary. | |
893 | Otherwise, get descriptor of target for pointer assignment. */ | |
894 | gfc_init_se (&se, NULL); | |
895 | ss = gfc_walk_expr (e); | |
896 | if (sym->assoc->variable) | |
897 | { | |
898 | se.direct_byref = 1; | |
899 | se.expr = desc; | |
900 | } | |
901 | gfc_conv_expr_descriptor (&se, e, ss); | |
902 | ||
903 | /* If we didn't already do the pointer assignment, set associate-name | |
904 | descriptor to the one generated for the temporary. */ | |
905 | if (!sym->assoc->variable) | |
906 | { | |
907 | int dim; | |
908 | ||
909 | gfc_add_modify (&se.pre, desc, se.expr); | |
910 | ||
911 | /* The generated descriptor has lower bound zero (as array | |
912 | temporary), shift bounds so we get lower bounds of 1. */ | |
913 | for (dim = 0; dim < e->rank; ++dim) | |
914 | gfc_conv_shift_descriptor_lbound (&se.pre, desc, | |
915 | dim, gfc_index_one_node); | |
916 | } | |
917 | ||
918 | /* Done, register stuff as init / cleanup code. */ | |
919 | gfc_add_init_cleanup (block, gfc_finish_block (&se.pre), | |
920 | gfc_finish_block (&se.post)); | |
921 | } | |
922 | ||
923 | /* Do a scalar pointer assignment; this is for scalar variable targets. */ | |
924 | else if (gfc_is_associate_pointer (sym)) | |
925 | { | |
926 | gfc_se se; | |
927 | ||
928 | gcc_assert (!sym->attr.dimension); | |
929 | ||
930 | gfc_init_se (&se, NULL); | |
931 | gfc_conv_expr (&se, e); | |
932 | ||
933 | tmp = TREE_TYPE (sym->backend_decl); | |
934 | tmp = gfc_build_addr_expr (tmp, se.expr); | |
935 | gfc_add_modify (&se.pre, sym->backend_decl, tmp); | |
936 | ||
937 | gfc_add_init_cleanup (block, gfc_finish_block( &se.pre), | |
938 | gfc_finish_block (&se.post)); | |
939 | } | |
940 | ||
941 | /* Do a simple assignment. This is for scalar expressions, where we | |
942 | can simply use expression assignment. */ | |
943 | else | |
944 | { | |
945 | gfc_expr *lhs; | |
946 | ||
947 | lhs = gfc_lval_expr_from_sym (sym); | |
948 | tmp = gfc_trans_assignment (lhs, e, false, true); | |
949 | gfc_add_init_cleanup (block, tmp, NULL_TREE); | |
950 | } | |
951 | } | |
952 | ||
953 | ||
9abe5e56 DK |
954 | /* Translate a BLOCK construct. This is basically what we would do for a |
955 | procedure body. */ | |
956 | ||
957 | tree | |
958 | gfc_trans_block_construct (gfc_code* code) | |
959 | { | |
960 | gfc_namespace* ns; | |
961 | gfc_symbol* sym; | |
e5ca9693 DK |
962 | gfc_wrapped_block block; |
963 | tree exit_label; | |
964 | stmtblock_t body; | |
6312ef45 | 965 | gfc_association_list *ass; |
9abe5e56 | 966 | |
03af1e4c | 967 | ns = code->ext.block.ns; |
9abe5e56 DK |
968 | gcc_assert (ns); |
969 | sym = ns->proc_name; | |
970 | gcc_assert (sym); | |
971 | ||
e5ca9693 | 972 | /* Process local variables. */ |
9abe5e56 DK |
973 | gcc_assert (!sym->tlink); |
974 | sym->tlink = sym; | |
6312ef45 | 975 | gfc_process_block_locals (ns); |
9abe5e56 | 976 | |
e5ca9693 DK |
977 | /* Generate code including exit-label. */ |
978 | gfc_init_block (&body); | |
979 | exit_label = gfc_build_label_decl (NULL_TREE); | |
980 | code->exit_label = exit_label; | |
981 | gfc_add_expr_to_block (&body, gfc_trans_code (ns->code)); | |
982 | gfc_add_expr_to_block (&body, build1_v (LABEL_EXPR, exit_label)); | |
983 | ||
984 | /* Finish everything. */ | |
985 | gfc_start_wrapped_block (&block, gfc_finish_block (&body)); | |
986 | gfc_trans_deferred_vars (sym, &block); | |
6312ef45 JW |
987 | for (ass = code->ext.block.assoc; ass; ass = ass->next) |
988 | trans_associate_var (ass->st->n.sym, &block); | |
989 | ||
e5ca9693 | 990 | return gfc_finish_wrapped_block (&block); |
9abe5e56 DK |
991 | } |
992 | ||
993 | ||
54c2d931 | 994 | /* Translate the simple DO construct. This is where the loop variable has |
fbdad37d PB |
995 | integer type and step +-1. We can't use this in the general case |
996 | because integer overflow and floating point errors could give incorrect | |
997 | results. | |
998 | We translate a do loop from: | |
999 | ||
1000 | DO dovar = from, to, step | |
1001 | body | |
1002 | END DO | |
1003 | ||
1004 | to: | |
1005 | ||
1006 | [Evaluate loop bounds and step] | |
1007 | dovar = from; | |
1008 | if ((step > 0) ? (dovar <= to) : (dovar => to)) | |
1009 | { | |
1010 | for (;;) | |
1011 | { | |
1012 | body; | |
1013 | cycle_label: | |
1014 | cond = (dovar == to); | |
1015 | dovar += step; | |
1016 | if (cond) goto end_label; | |
1017 | } | |
1018 | } | |
1019 | end_label: | |
1020 | ||
1021 | This helps the optimizers by avoiding the extra induction variable | |
1022 | used in the general case. */ | |
1023 | ||
1024 | static tree | |
1025 | gfc_trans_simple_do (gfc_code * code, stmtblock_t *pblock, tree dovar, | |
bc51e726 | 1026 | tree from, tree to, tree step, tree exit_cond) |
fbdad37d PB |
1027 | { |
1028 | stmtblock_t body; | |
1029 | tree type; | |
1030 | tree cond; | |
1031 | tree tmp; | |
33abc845 | 1032 | tree saved_dovar = NULL; |
fbdad37d PB |
1033 | tree cycle_label; |
1034 | tree exit_label; | |
55bd9c35 | 1035 | location_t loc; |
fbdad37d PB |
1036 | |
1037 | type = TREE_TYPE (dovar); | |
1038 | ||
55bd9c35 TB |
1039 | loc = code->ext.iterator->start->where.lb->location; |
1040 | ||
fbdad37d | 1041 | /* Initialize the DO variable: dovar = from. */ |
55bd9c35 | 1042 | gfc_add_modify_loc (loc, pblock, dovar, from); |
33abc845 TB |
1043 | |
1044 | /* Save value for do-tinkering checking. */ | |
1045 | if (gfc_option.rtcheck & GFC_RTCHECK_DO) | |
1046 | { | |
1047 | saved_dovar = gfc_create_var (type, ".saved_dovar"); | |
55bd9c35 | 1048 | gfc_add_modify_loc (loc, pblock, saved_dovar, dovar); |
33abc845 | 1049 | } |
fbdad37d PB |
1050 | |
1051 | /* Cycle and exit statements are implemented with gotos. */ | |
1052 | cycle_label = gfc_build_label_decl (NULL_TREE); | |
1053 | exit_label = gfc_build_label_decl (NULL_TREE); | |
1054 | ||
1055 | /* Put the labels where they can be found later. See gfc_trans_do(). */ | |
e5ca9693 DK |
1056 | code->cycle_label = cycle_label; |
1057 | code->exit_label = exit_label; | |
fbdad37d PB |
1058 | |
1059 | /* Loop body. */ | |
1060 | gfc_start_block (&body); | |
1061 | ||
1062 | /* Main loop body. */ | |
bc51e726 | 1063 | tmp = gfc_trans_code_cond (code->block->next, exit_cond); |
fbdad37d PB |
1064 | gfc_add_expr_to_block (&body, tmp); |
1065 | ||
1066 | /* Label for cycle statements (if needed). */ | |
1067 | if (TREE_USED (cycle_label)) | |
1068 | { | |
1069 | tmp = build1_v (LABEL_EXPR, cycle_label); | |
1070 | gfc_add_expr_to_block (&body, tmp); | |
1071 | } | |
1072 | ||
33abc845 TB |
1073 | /* Check whether someone has modified the loop variable. */ |
1074 | if (gfc_option.rtcheck & GFC_RTCHECK_DO) | |
1075 | { | |
55bd9c35 | 1076 | tmp = fold_build2_loc (loc, NE_EXPR, boolean_type_node, |
bc98ed60 | 1077 | dovar, saved_dovar); |
33abc845 TB |
1078 | gfc_trans_runtime_check (true, false, tmp, &body, &code->loc, |
1079 | "Loop variable has been modified"); | |
1080 | } | |
1081 | ||
bc51e726 JD |
1082 | /* Exit the loop if there is an I/O result condition or error. */ |
1083 | if (exit_cond) | |
1084 | { | |
1085 | tmp = build1_v (GOTO_EXPR, exit_label); | |
55bd9c35 | 1086 | tmp = fold_build3_loc (loc, COND_EXPR, void_type_node, |
bc98ed60 | 1087 | exit_cond, tmp, |
55bd9c35 | 1088 | build_empty_stmt (loc)); |
bc51e726 JD |
1089 | gfc_add_expr_to_block (&body, tmp); |
1090 | } | |
1091 | ||
fbdad37d | 1092 | /* Evaluate the loop condition. */ |
55bd9c35 | 1093 | cond = fold_build2_loc (loc, EQ_EXPR, boolean_type_node, dovar, |
bc98ed60 | 1094 | to); |
55bd9c35 | 1095 | cond = gfc_evaluate_now_loc (loc, cond, &body); |
fbdad37d PB |
1096 | |
1097 | /* Increment the loop variable. */ | |
55bd9c35 TB |
1098 | tmp = fold_build2_loc (loc, PLUS_EXPR, type, dovar, step); |
1099 | gfc_add_modify_loc (loc, &body, dovar, tmp); | |
fbdad37d | 1100 | |
33abc845 | 1101 | if (gfc_option.rtcheck & GFC_RTCHECK_DO) |
55bd9c35 | 1102 | gfc_add_modify_loc (loc, &body, saved_dovar, dovar); |
33abc845 | 1103 | |
fbdad37d | 1104 | /* The loop exit. */ |
55bd9c35 | 1105 | tmp = fold_build1_loc (loc, GOTO_EXPR, void_type_node, exit_label); |
fbdad37d | 1106 | TREE_USED (exit_label) = 1; |
55bd9c35 TB |
1107 | tmp = fold_build3_loc (loc, COND_EXPR, void_type_node, |
1108 | cond, tmp, build_empty_stmt (loc)); | |
fbdad37d PB |
1109 | gfc_add_expr_to_block (&body, tmp); |
1110 | ||
1111 | /* Finish the loop body. */ | |
1112 | tmp = gfc_finish_block (&body); | |
55bd9c35 | 1113 | tmp = fold_build1_loc (loc, LOOP_EXPR, void_type_node, tmp); |
fbdad37d PB |
1114 | |
1115 | /* Only execute the loop if the number of iterations is positive. */ | |
1116 | if (tree_int_cst_sgn (step) > 0) | |
55bd9c35 | 1117 | cond = fold_build2_loc (loc, LE_EXPR, boolean_type_node, dovar, |
bc98ed60 | 1118 | to); |
fbdad37d | 1119 | else |
55bd9c35 | 1120 | cond = fold_build2_loc (loc, GE_EXPR, boolean_type_node, dovar, |
bc98ed60 | 1121 | to); |
55bd9c35 TB |
1122 | tmp = fold_build3_loc (loc, COND_EXPR, void_type_node, cond, tmp, |
1123 | build_empty_stmt (loc)); | |
fbdad37d PB |
1124 | gfc_add_expr_to_block (pblock, tmp); |
1125 | ||
1126 | /* Add the exit label. */ | |
1127 | tmp = build1_v (LABEL_EXPR, exit_label); | |
1128 | gfc_add_expr_to_block (pblock, tmp); | |
1129 | ||
1130 | return gfc_finish_block (pblock); | |
1131 | } | |
1132 | ||
6de9cd9a DN |
1133 | /* Translate the DO construct. This obviously is one of the most |
1134 | important ones to get right with any compiler, but especially | |
1135 | so for Fortran. | |
1136 | ||
fbdad37d PB |
1137 | We special case some loop forms as described in gfc_trans_simple_do. |
1138 | For other cases we implement them with a separate loop count, | |
1139 | as described in the standard. | |
6de9cd9a DN |
1140 | |
1141 | We translate a do loop from: | |
1142 | ||
1143 | DO dovar = from, to, step | |
1144 | body | |
1145 | END DO | |
1146 | ||
1147 | to: | |
1148 | ||
fbdad37d | 1149 | [evaluate loop bounds and step] |
5d148c08 FXC |
1150 | empty = (step > 0 ? to < from : to > from); |
1151 | countm1 = (to - from) / step; | |
fbdad37d | 1152 | dovar = from; |
5d148c08 | 1153 | if (empty) goto exit_label; |
fbdad37d | 1154 | for (;;) |
6de9cd9a DN |
1155 | { |
1156 | body; | |
1157 | cycle_label: | |
fbdad37d | 1158 | dovar += step |
5d148c08 | 1159 | if (countm1 ==0) goto exit_label; |
76dac339 | 1160 | countm1--; |
6de9cd9a DN |
1161 | } |
1162 | exit_label: | |
1163 | ||
5d148c08 FXC |
1164 | countm1 is an unsigned integer. It is equal to the loop count minus one, |
1165 | because the loop count itself can overflow. */ | |
6de9cd9a DN |
1166 | |
1167 | tree | |
bc51e726 | 1168 | gfc_trans_do (gfc_code * code, tree exit_cond) |
6de9cd9a DN |
1169 | { |
1170 | gfc_se se; | |
1171 | tree dovar; | |
33abc845 | 1172 | tree saved_dovar = NULL; |
6de9cd9a DN |
1173 | tree from; |
1174 | tree to; | |
1175 | tree step; | |
5d148c08 | 1176 | tree countm1; |
6de9cd9a | 1177 | tree type; |
5d148c08 | 1178 | tree utype; |
6de9cd9a DN |
1179 | tree cond; |
1180 | tree cycle_label; | |
1181 | tree exit_label; | |
1182 | tree tmp; | |
5d148c08 | 1183 | tree pos_step; |
6de9cd9a DN |
1184 | stmtblock_t block; |
1185 | stmtblock_t body; | |
55bd9c35 | 1186 | location_t loc; |
6de9cd9a DN |
1187 | |
1188 | gfc_start_block (&block); | |
1189 | ||
55bd9c35 TB |
1190 | loc = code->ext.iterator->start->where.lb->location; |
1191 | ||
fbdad37d | 1192 | /* Evaluate all the expressions in the iterator. */ |
6de9cd9a DN |
1193 | gfc_init_se (&se, NULL); |
1194 | gfc_conv_expr_lhs (&se, code->ext.iterator->var); | |
1195 | gfc_add_block_to_block (&block, &se.pre); | |
1196 | dovar = se.expr; | |
1197 | type = TREE_TYPE (dovar); | |
1198 | ||
1199 | gfc_init_se (&se, NULL); | |
8d5cfa27 | 1200 | gfc_conv_expr_val (&se, code->ext.iterator->start); |
6de9cd9a | 1201 | gfc_add_block_to_block (&block, &se.pre); |
fbdad37d | 1202 | from = gfc_evaluate_now (se.expr, &block); |
6de9cd9a DN |
1203 | |
1204 | gfc_init_se (&se, NULL); | |
8d5cfa27 | 1205 | gfc_conv_expr_val (&se, code->ext.iterator->end); |
6de9cd9a | 1206 | gfc_add_block_to_block (&block, &se.pre); |
fbdad37d | 1207 | to = gfc_evaluate_now (se.expr, &block); |
6de9cd9a DN |
1208 | |
1209 | gfc_init_se (&se, NULL); | |
8d5cfa27 | 1210 | gfc_conv_expr_val (&se, code->ext.iterator->step); |
6de9cd9a | 1211 | gfc_add_block_to_block (&block, &se.pre); |
fbdad37d PB |
1212 | step = gfc_evaluate_now (se.expr, &block); |
1213 | ||
33abc845 TB |
1214 | if (gfc_option.rtcheck & GFC_RTCHECK_DO) |
1215 | { | |
bc98ed60 | 1216 | tmp = fold_build2_loc (input_location, EQ_EXPR, boolean_type_node, step, |
e8160c9a | 1217 | build_zero_cst (type)); |
33abc845 TB |
1218 | gfc_trans_runtime_check (true, false, tmp, &block, &code->loc, |
1219 | "DO step value is zero"); | |
1220 | } | |
1221 | ||
fbdad37d PB |
1222 | /* Special case simple loops. */ |
1223 | if (TREE_CODE (type) == INTEGER_TYPE | |
1224 | && (integer_onep (step) | |
1225 | || tree_int_cst_equal (step, integer_minus_one_node))) | |
bc51e726 | 1226 | return gfc_trans_simple_do (code, &block, dovar, from, to, step, exit_cond); |
c0b29099 | 1227 | |
55bd9c35 | 1228 | pos_step = fold_build2_loc (loc, GT_EXPR, boolean_type_node, step, |
e8160c9a | 1229 | build_zero_cst (type)); |
6de9cd9a | 1230 | |
8d5cfa27 | 1231 | if (TREE_CODE (type) == INTEGER_TYPE) |
c0b29099 JJ |
1232 | utype = unsigned_type_for (type); |
1233 | else | |
1234 | utype = unsigned_type_for (gfc_array_index_type); | |
1235 | countm1 = gfc_create_var (utype, "countm1"); | |
5d148c08 | 1236 | |
c0b29099 JJ |
1237 | /* Cycle and exit statements are implemented with gotos. */ |
1238 | cycle_label = gfc_build_label_decl (NULL_TREE); | |
1239 | exit_label = gfc_build_label_decl (NULL_TREE); | |
1240 | TREE_USED (exit_label) = 1; | |
1241 | ||
e5ca9693 DK |
1242 | /* Put these labels where they can be found later. */ |
1243 | code->cycle_label = cycle_label; | |
1244 | code->exit_label = exit_label; | |
1245 | ||
c0b29099 JJ |
1246 | /* Initialize the DO variable: dovar = from. */ |
1247 | gfc_add_modify (&block, dovar, from); | |
1248 | ||
33abc845 TB |
1249 | /* Save value for do-tinkering checking. */ |
1250 | if (gfc_option.rtcheck & GFC_RTCHECK_DO) | |
1251 | { | |
1252 | saved_dovar = gfc_create_var (type, ".saved_dovar"); | |
55bd9c35 | 1253 | gfc_add_modify_loc (loc, &block, saved_dovar, dovar); |
33abc845 TB |
1254 | } |
1255 | ||
c0b29099 JJ |
1256 | /* Initialize loop count and jump to exit label if the loop is empty. |
1257 | This code is executed before we enter the loop body. We generate: | |
8146bb58 | 1258 | step_sign = sign(1,step); |
c0b29099 JJ |
1259 | if (step > 0) |
1260 | { | |
8146bb58 TK |
1261 | if (to < from) |
1262 | goto exit_label; | |
c0b29099 JJ |
1263 | } |
1264 | else | |
1265 | { | |
8146bb58 TK |
1266 | if (to > from) |
1267 | goto exit_label; | |
1268 | } | |
1269 | countm1 = (to*step_sign - from*step_sign) / (step*step_sign); | |
1270 | ||
1271 | */ | |
1272 | ||
c0b29099 JJ |
1273 | if (TREE_CODE (type) == INTEGER_TYPE) |
1274 | { | |
8146bb58 TK |
1275 | tree pos, neg, step_sign, to2, from2, step2; |
1276 | ||
d0d565e1 | 1277 | /* Calculate SIGN (1,step), as (step < 0 ? -1 : 1) */ |
8146bb58 | 1278 | |
55bd9c35 | 1279 | tmp = fold_build2_loc (loc, LT_EXPR, boolean_type_node, step, |
bc98ed60 | 1280 | build_int_cst (TREE_TYPE (step), 0)); |
55bd9c35 | 1281 | step_sign = fold_build3_loc (loc, COND_EXPR, type, tmp, |
bc98ed60 TB |
1282 | build_int_cst (type, -1), |
1283 | build_int_cst (type, 1)); | |
5d148c08 | 1284 | |
55bd9c35 TB |
1285 | tmp = fold_build2_loc (loc, LT_EXPR, boolean_type_node, to, from); |
1286 | pos = fold_build3_loc (loc, COND_EXPR, void_type_node, tmp, | |
1287 | fold_build1_loc (loc, GOTO_EXPR, void_type_node, | |
1288 | exit_label), | |
1289 | build_empty_stmt (loc)); | |
c0b29099 | 1290 | |
55bd9c35 | 1291 | tmp = fold_build2_loc (loc, GT_EXPR, boolean_type_node, to, |
bc98ed60 | 1292 | from); |
55bd9c35 TB |
1293 | neg = fold_build3_loc (loc, COND_EXPR, void_type_node, tmp, |
1294 | fold_build1_loc (loc, GOTO_EXPR, void_type_node, | |
1295 | exit_label), | |
1296 | build_empty_stmt (loc)); | |
1297 | tmp = fold_build3_loc (loc, COND_EXPR, void_type_node, | |
bc98ed60 | 1298 | pos_step, pos, neg); |
8146bb58 TK |
1299 | |
1300 | gfc_add_expr_to_block (&block, tmp); | |
1301 | ||
1302 | /* Calculate the loop count. to-from can overflow, so | |
1303 | we cast to unsigned. */ | |
1304 | ||
55bd9c35 TB |
1305 | to2 = fold_build2_loc (loc, MULT_EXPR, type, step_sign, to); |
1306 | from2 = fold_build2_loc (loc, MULT_EXPR, type, step_sign, from); | |
1307 | step2 = fold_build2_loc (loc, MULT_EXPR, type, step_sign, step); | |
8146bb58 | 1308 | step2 = fold_convert (utype, step2); |
55bd9c35 | 1309 | tmp = fold_build2_loc (loc, MINUS_EXPR, type, to2, from2); |
c0b29099 | 1310 | tmp = fold_convert (utype, tmp); |
55bd9c35 TB |
1311 | tmp = fold_build2_loc (loc, TRUNC_DIV_EXPR, utype, tmp, step2); |
1312 | tmp = fold_build2_loc (loc, MODIFY_EXPR, void_type_node, countm1, tmp); | |
c0b29099 | 1313 | gfc_add_expr_to_block (&block, tmp); |
8d5cfa27 SK |
1314 | } |
1315 | else | |
1316 | { | |
1317 | /* TODO: We could use the same width as the real type. | |
1318 | This would probably cause more problems that it solves | |
1319 | when we implement "long double" types. */ | |
c0b29099 | 1320 | |
55bd9c35 TB |
1321 | tmp = fold_build2_loc (loc, MINUS_EXPR, type, to, from); |
1322 | tmp = fold_build2_loc (loc, RDIV_EXPR, type, tmp, step); | |
1323 | tmp = fold_build1_loc (loc, FIX_TRUNC_EXPR, utype, tmp); | |
c0b29099 JJ |
1324 | gfc_add_modify (&block, countm1, tmp); |
1325 | ||
1326 | /* We need a special check for empty loops: | |
1327 | empty = (step > 0 ? to < from : to > from); */ | |
55bd9c35 TB |
1328 | tmp = fold_build3_loc (loc, COND_EXPR, boolean_type_node, pos_step, |
1329 | fold_build2_loc (loc, LT_EXPR, | |
bc98ed60 | 1330 | boolean_type_node, to, from), |
55bd9c35 | 1331 | fold_build2_loc (loc, GT_EXPR, |
bc98ed60 | 1332 | boolean_type_node, to, from)); |
c0b29099 | 1333 | /* If the loop is empty, go directly to the exit label. */ |
55bd9c35 | 1334 | tmp = fold_build3_loc (loc, COND_EXPR, void_type_node, tmp, |
c0b29099 | 1335 | build1_v (GOTO_EXPR, exit_label), |
c2255bc4 | 1336 | build_empty_stmt (input_location)); |
c0b29099 | 1337 | gfc_add_expr_to_block (&block, tmp); |
8d5cfa27 | 1338 | } |
5d148c08 | 1339 | |
6de9cd9a DN |
1340 | /* Loop body. */ |
1341 | gfc_start_block (&body); | |
1342 | ||
6de9cd9a | 1343 | /* Main loop body. */ |
bc51e726 | 1344 | tmp = gfc_trans_code_cond (code->block->next, exit_cond); |
6de9cd9a DN |
1345 | gfc_add_expr_to_block (&body, tmp); |
1346 | ||
1347 | /* Label for cycle statements (if needed). */ | |
1348 | if (TREE_USED (cycle_label)) | |
1349 | { | |
1350 | tmp = build1_v (LABEL_EXPR, cycle_label); | |
1351 | gfc_add_expr_to_block (&body, tmp); | |
1352 | } | |
1353 | ||
33abc845 TB |
1354 | /* Check whether someone has modified the loop variable. */ |
1355 | if (gfc_option.rtcheck & GFC_RTCHECK_DO) | |
1356 | { | |
55bd9c35 | 1357 | tmp = fold_build2_loc (loc, NE_EXPR, boolean_type_node, dovar, |
bc98ed60 | 1358 | saved_dovar); |
33abc845 TB |
1359 | gfc_trans_runtime_check (true, false, tmp, &body, &code->loc, |
1360 | "Loop variable has been modified"); | |
1361 | } | |
1362 | ||
bc51e726 JD |
1363 | /* Exit the loop if there is an I/O result condition or error. */ |
1364 | if (exit_cond) | |
1365 | { | |
1366 | tmp = build1_v (GOTO_EXPR, exit_label); | |
55bd9c35 | 1367 | tmp = fold_build3_loc (loc, COND_EXPR, void_type_node, |
bc98ed60 TB |
1368 | exit_cond, tmp, |
1369 | build_empty_stmt (input_location)); | |
bc51e726 JD |
1370 | gfc_add_expr_to_block (&body, tmp); |
1371 | } | |
1372 | ||
244974bd | 1373 | /* Increment the loop variable. */ |
55bd9c35 TB |
1374 | tmp = fold_build2_loc (loc, PLUS_EXPR, type, dovar, step); |
1375 | gfc_add_modify_loc (loc, &body, dovar, tmp); | |
244974bd | 1376 | |
33abc845 | 1377 | if (gfc_option.rtcheck & GFC_RTCHECK_DO) |
55bd9c35 | 1378 | gfc_add_modify_loc (loc, &body, saved_dovar, dovar); |
33abc845 | 1379 | |
5d148c08 | 1380 | /* End with the loop condition. Loop until countm1 == 0. */ |
55bd9c35 | 1381 | cond = fold_build2_loc (loc, EQ_EXPR, boolean_type_node, countm1, |
bc98ed60 | 1382 | build_int_cst (utype, 0)); |
55bd9c35 TB |
1383 | tmp = fold_build1_loc (loc, GOTO_EXPR, void_type_node, exit_label); |
1384 | tmp = fold_build3_loc (loc, COND_EXPR, void_type_node, | |
1385 | cond, tmp, build_empty_stmt (loc)); | |
5d148c08 FXC |
1386 | gfc_add_expr_to_block (&body, tmp); |
1387 | ||
6de9cd9a | 1388 | /* Decrement the loop count. */ |
55bd9c35 | 1389 | tmp = fold_build2_loc (loc, MINUS_EXPR, utype, countm1, |
bc98ed60 | 1390 | build_int_cst (utype, 1)); |
55bd9c35 | 1391 | gfc_add_modify_loc (loc, &body, countm1, tmp); |
6de9cd9a DN |
1392 | |
1393 | /* End of loop body. */ | |
1394 | tmp = gfc_finish_block (&body); | |
1395 | ||
1396 | /* The for loop itself. */ | |
55bd9c35 | 1397 | tmp = fold_build1_loc (loc, LOOP_EXPR, void_type_node, tmp); |
6de9cd9a DN |
1398 | gfc_add_expr_to_block (&block, tmp); |
1399 | ||
1400 | /* Add the exit label. */ | |
1401 | tmp = build1_v (LABEL_EXPR, exit_label); | |
1402 | gfc_add_expr_to_block (&block, tmp); | |
1403 | ||
1404 | return gfc_finish_block (&block); | |
1405 | } | |
1406 | ||
1407 | ||
1408 | /* Translate the DO WHILE construct. | |
1409 | ||
1410 | We translate | |
1411 | ||
1412 | DO WHILE (cond) | |
1413 | body | |
1414 | END DO | |
1415 | ||
1416 | to: | |
1417 | ||
1418 | for ( ; ; ) | |
1419 | { | |
1420 | pre_cond; | |
1421 | if (! cond) goto exit_label; | |
1422 | body; | |
1423 | cycle_label: | |
1424 | } | |
1425 | exit_label: | |
1426 | ||
1427 | Because the evaluation of the exit condition `cond' may have side | |
1428 | effects, we can't do much for empty loop bodies. The backend optimizers | |
1429 | should be smart enough to eliminate any dead loops. */ | |
1430 | ||
1431 | tree | |
1432 | gfc_trans_do_while (gfc_code * code) | |
1433 | { | |
1434 | gfc_se cond; | |
1435 | tree tmp; | |
1436 | tree cycle_label; | |
1437 | tree exit_label; | |
1438 | stmtblock_t block; | |
1439 | ||
1440 | /* Everything we build here is part of the loop body. */ | |
1441 | gfc_start_block (&block); | |
1442 | ||
1443 | /* Cycle and exit statements are implemented with gotos. */ | |
1444 | cycle_label = gfc_build_label_decl (NULL_TREE); | |
1445 | exit_label = gfc_build_label_decl (NULL_TREE); | |
1446 | ||
1447 | /* Put the labels where they can be found later. See gfc_trans_do(). */ | |
e5ca9693 DK |
1448 | code->cycle_label = cycle_label; |
1449 | code->exit_label = exit_label; | |
6de9cd9a DN |
1450 | |
1451 | /* Create a GIMPLE version of the exit condition. */ | |
1452 | gfc_init_se (&cond, NULL); | |
a513927a | 1453 | gfc_conv_expr_val (&cond, code->expr1); |
6de9cd9a | 1454 | gfc_add_block_to_block (&block, &cond.pre); |
55bd9c35 TB |
1455 | cond.expr = fold_build1_loc (code->expr1->where.lb->location, |
1456 | TRUTH_NOT_EXPR, boolean_type_node, cond.expr); | |
6de9cd9a DN |
1457 | |
1458 | /* Build "IF (! cond) GOTO exit_label". */ | |
1459 | tmp = build1_v (GOTO_EXPR, exit_label); | |
1460 | TREE_USED (exit_label) = 1; | |
55bd9c35 TB |
1461 | tmp = fold_build3_loc (code->expr1->where.lb->location, COND_EXPR, |
1462 | void_type_node, cond.expr, tmp, | |
1463 | build_empty_stmt (code->expr1->where.lb->location)); | |
6de9cd9a DN |
1464 | gfc_add_expr_to_block (&block, tmp); |
1465 | ||
1466 | /* The main body of the loop. */ | |
1467 | tmp = gfc_trans_code (code->block->next); | |
1468 | gfc_add_expr_to_block (&block, tmp); | |
1469 | ||
1470 | /* Label for cycle statements (if needed). */ | |
1471 | if (TREE_USED (cycle_label)) | |
1472 | { | |
1473 | tmp = build1_v (LABEL_EXPR, cycle_label); | |
1474 | gfc_add_expr_to_block (&block, tmp); | |
1475 | } | |
1476 | ||
1477 | /* End of loop body. */ | |
1478 | tmp = gfc_finish_block (&block); | |
1479 | ||
1480 | gfc_init_block (&block); | |
1481 | /* Build the loop. */ | |
55bd9c35 TB |
1482 | tmp = fold_build1_loc (code->expr1->where.lb->location, LOOP_EXPR, |
1483 | void_type_node, tmp); | |
6de9cd9a DN |
1484 | gfc_add_expr_to_block (&block, tmp); |
1485 | ||
1486 | /* Add the exit label. */ | |
1487 | tmp = build1_v (LABEL_EXPR, exit_label); | |
1488 | gfc_add_expr_to_block (&block, tmp); | |
1489 | ||
1490 | return gfc_finish_block (&block); | |
1491 | } | |
1492 | ||
1493 | ||
1494 | /* Translate the SELECT CASE construct for INTEGER case expressions, | |
1495 | without killing all potential optimizations. The problem is that | |
1496 | Fortran allows unbounded cases, but the back-end does not, so we | |
1497 | need to intercept those before we enter the equivalent SWITCH_EXPR | |
1498 | we can build. | |
1499 | ||
1500 | For example, we translate this, | |
1501 | ||
1502 | SELECT CASE (expr) | |
1503 | CASE (:100,101,105:115) | |
1504 | block_1 | |
1505 | CASE (190:199,200:) | |
1506 | block_2 | |
1507 | CASE (300) | |
1508 | block_3 | |
1509 | CASE DEFAULT | |
1510 | block_4 | |
1511 | END SELECT | |
1512 | ||
1513 | to the GENERIC equivalent, | |
1514 | ||
1515 | switch (expr) | |
1516 | { | |
1517 | case (minimum value for typeof(expr) ... 100: | |
1518 | case 101: | |
1519 | case 105 ... 114: | |
1520 | block1: | |
1521 | goto end_label; | |
1522 | ||
1523 | case 200 ... (maximum value for typeof(expr): | |
1524 | case 190 ... 199: | |
1525 | block2; | |
1526 | goto end_label; | |
1527 | ||
1528 | case 300: | |
1529 | block_3; | |
1530 | goto end_label; | |
1531 | ||
1532 | default: | |
1533 | block_4; | |
1534 | goto end_label; | |
1535 | } | |
1536 | ||
1537 | end_label: */ | |
1538 | ||
1539 | static tree | |
1540 | gfc_trans_integer_select (gfc_code * code) | |
1541 | { | |
1542 | gfc_code *c; | |
1543 | gfc_case *cp; | |
1544 | tree end_label; | |
1545 | tree tmp; | |
1546 | gfc_se se; | |
1547 | stmtblock_t block; | |
1548 | stmtblock_t body; | |
1549 | ||
1550 | gfc_start_block (&block); | |
1551 | ||
1552 | /* Calculate the switch expression. */ | |
1553 | gfc_init_se (&se, NULL); | |
a513927a | 1554 | gfc_conv_expr_val (&se, code->expr1); |
6de9cd9a DN |
1555 | gfc_add_block_to_block (&block, &se.pre); |
1556 | ||
1557 | end_label = gfc_build_label_decl (NULL_TREE); | |
1558 | ||
1559 | gfc_init_block (&body); | |
1560 | ||
1561 | for (c = code->block; c; c = c->block) | |
1562 | { | |
1563 | for (cp = c->ext.case_list; cp; cp = cp->next) | |
1564 | { | |
1565 | tree low, high; | |
1566 | tree label; | |
1567 | ||
1568 | /* Assume it's the default case. */ | |
1569 | low = high = NULL_TREE; | |
1570 | ||
1571 | if (cp->low) | |
1572 | { | |
20585ad6 BM |
1573 | low = gfc_conv_mpz_to_tree (cp->low->value.integer, |
1574 | cp->low->ts.kind); | |
6de9cd9a DN |
1575 | |
1576 | /* If there's only a lower bound, set the high bound to the | |
1577 | maximum value of the case expression. */ | |
1578 | if (!cp->high) | |
1579 | high = TYPE_MAX_VALUE (TREE_TYPE (se.expr)); | |
1580 | } | |
1581 | ||
1582 | if (cp->high) | |
1583 | { | |
1584 | /* Three cases are possible here: | |
1585 | ||
1586 | 1) There is no lower bound, e.g. CASE (:N). | |
1587 | 2) There is a lower bound .NE. high bound, that is | |
1588 | a case range, e.g. CASE (N:M) where M>N (we make | |
1589 | sure that M>N during type resolution). | |
1590 | 3) There is a lower bound, and it has the same value | |
1591 | as the high bound, e.g. CASE (N:N). This is our | |
1592 | internal representation of CASE(N). | |
1593 | ||
1594 | In the first and second case, we need to set a value for | |
e2ae1407 | 1595 | high. In the third case, we don't because the GCC middle |
6de9cd9a DN |
1596 | end represents a single case value by just letting high be |
1597 | a NULL_TREE. We can't do that because we need to be able | |
1598 | to represent unbounded cases. */ | |
1599 | ||
1600 | if (!cp->low | |
1601 | || (cp->low | |
1602 | && mpz_cmp (cp->low->value.integer, | |
1603 | cp->high->value.integer) != 0)) | |
20585ad6 BM |
1604 | high = gfc_conv_mpz_to_tree (cp->high->value.integer, |
1605 | cp->high->ts.kind); | |
6de9cd9a DN |
1606 | |
1607 | /* Unbounded case. */ | |
1608 | if (!cp->low) | |
1609 | low = TYPE_MIN_VALUE (TREE_TYPE (se.expr)); | |
1610 | } | |
1611 | ||
1612 | /* Build a label. */ | |
c006df4e | 1613 | label = gfc_build_label_decl (NULL_TREE); |
6de9cd9a DN |
1614 | |
1615 | /* Add this case label. | |
1616 | Add parameter 'label', make it match GCC backend. */ | |
bc98ed60 TB |
1617 | tmp = fold_build3_loc (input_location, CASE_LABEL_EXPR, |
1618 | void_type_node, low, high, label); | |
6de9cd9a DN |
1619 | gfc_add_expr_to_block (&body, tmp); |
1620 | } | |
1621 | ||
1622 | /* Add the statements for this case. */ | |
1623 | tmp = gfc_trans_code (c->next); | |
1624 | gfc_add_expr_to_block (&body, tmp); | |
1625 | ||
1626 | /* Break to the end of the construct. */ | |
1627 | tmp = build1_v (GOTO_EXPR, end_label); | |
1628 | gfc_add_expr_to_block (&body, tmp); | |
1629 | } | |
1630 | ||
1631 | tmp = gfc_finish_block (&body); | |
923ab88c | 1632 | tmp = build3_v (SWITCH_EXPR, se.expr, tmp, NULL_TREE); |
6de9cd9a DN |
1633 | gfc_add_expr_to_block (&block, tmp); |
1634 | ||
1635 | tmp = build1_v (LABEL_EXPR, end_label); | |
1636 | gfc_add_expr_to_block (&block, tmp); | |
1637 | ||
1638 | return gfc_finish_block (&block); | |
1639 | } | |
1640 | ||
1641 | ||
1642 | /* Translate the SELECT CASE construct for LOGICAL case expressions. | |
1643 | ||
1644 | There are only two cases possible here, even though the standard | |
1645 | does allow three cases in a LOGICAL SELECT CASE construct: .TRUE., | |
1646 | .FALSE., and DEFAULT. | |
1647 | ||
1648 | We never generate more than two blocks here. Instead, we always | |
1649 | try to eliminate the DEFAULT case. This way, we can translate this | |
1650 | kind of SELECT construct to a simple | |
1651 | ||
1652 | if {} else {}; | |
1653 | ||
1654 | expression in GENERIC. */ | |
1655 | ||
1656 | static tree | |
1657 | gfc_trans_logical_select (gfc_code * code) | |
1658 | { | |
1659 | gfc_code *c; | |
1660 | gfc_code *t, *f, *d; | |
1661 | gfc_case *cp; | |
1662 | gfc_se se; | |
1663 | stmtblock_t block; | |
1664 | ||
1665 | /* Assume we don't have any cases at all. */ | |
1666 | t = f = d = NULL; | |
1667 | ||
1668 | /* Now see which ones we actually do have. We can have at most two | |
1669 | cases in a single case list: one for .TRUE. and one for .FALSE. | |
1670 | The default case is always separate. If the cases for .TRUE. and | |
1671 | .FALSE. are in the same case list, the block for that case list | |
1672 | always executed, and we don't generate code a COND_EXPR. */ | |
1673 | for (c = code->block; c; c = c->block) | |
1674 | { | |
1675 | for (cp = c->ext.case_list; cp; cp = cp->next) | |
1676 | { | |
1677 | if (cp->low) | |
1678 | { | |
1679 | if (cp->low->value.logical == 0) /* .FALSE. */ | |
1680 | f = c; | |
1681 | else /* if (cp->value.logical != 0), thus .TRUE. */ | |
1682 | t = c; | |
1683 | } | |
1684 | else | |
1685 | d = c; | |
1686 | } | |
1687 | } | |
1688 | ||
1689 | /* Start a new block. */ | |
1690 | gfc_start_block (&block); | |
1691 | ||
1692 | /* Calculate the switch expression. We always need to do this | |
1693 | because it may have side effects. */ | |
1694 | gfc_init_se (&se, NULL); | |
a513927a | 1695 | gfc_conv_expr_val (&se, code->expr1); |
6de9cd9a DN |
1696 | gfc_add_block_to_block (&block, &se.pre); |
1697 | ||
1698 | if (t == f && t != NULL) | |
1699 | { | |
1700 | /* Cases for .TRUE. and .FALSE. are in the same block. Just | |
1701 | translate the code for these cases, append it to the current | |
1702 | block. */ | |
1703 | gfc_add_expr_to_block (&block, gfc_trans_code (t->next)); | |
1704 | } | |
1705 | else | |
1706 | { | |
61ead135 | 1707 | tree true_tree, false_tree, stmt; |
6de9cd9a | 1708 | |
c2255bc4 AH |
1709 | true_tree = build_empty_stmt (input_location); |
1710 | false_tree = build_empty_stmt (input_location); | |
6de9cd9a DN |
1711 | |
1712 | /* If we have a case for .TRUE. and for .FALSE., discard the default case. | |
1713 | Otherwise, if .TRUE. or .FALSE. is missing and there is a default case, | |
1714 | make the missing case the default case. */ | |
1715 | if (t != NULL && f != NULL) | |
1716 | d = NULL; | |
1717 | else if (d != NULL) | |
1718 | { | |
1719 | if (t == NULL) | |
1720 | t = d; | |
1721 | else | |
1722 | f = d; | |
1723 | } | |
1724 | ||
1725 | /* Translate the code for each of these blocks, and append it to | |
1726 | the current block. */ | |
1727 | if (t != NULL) | |
1728 | true_tree = gfc_trans_code (t->next); | |
1729 | ||
1730 | if (f != NULL) | |
1731 | false_tree = gfc_trans_code (f->next); | |
1732 | ||
bc98ed60 TB |
1733 | stmt = fold_build3_loc (input_location, COND_EXPR, void_type_node, |
1734 | se.expr, true_tree, false_tree); | |
61ead135 | 1735 | gfc_add_expr_to_block (&block, stmt); |
6de9cd9a DN |
1736 | } |
1737 | ||
1738 | return gfc_finish_block (&block); | |
1739 | } | |
1740 | ||
1741 | ||
d2886bc7 JJ |
1742 | /* The jump table types are stored in static variables to avoid |
1743 | constructing them from scratch every single time. */ | |
1744 | static GTY(()) tree select_struct[2]; | |
1745 | ||
6de9cd9a DN |
1746 | /* Translate the SELECT CASE construct for CHARACTER case expressions. |
1747 | Instead of generating compares and jumps, it is far simpler to | |
1748 | generate a data structure describing the cases in order and call a | |
1749 | library subroutine that locates the right case. | |
1750 | This is particularly true because this is the only case where we | |
1751 | might have to dispose of a temporary. | |
1752 | The library subroutine returns a pointer to jump to or NULL if no | |
1753 | branches are to be taken. */ | |
1754 | ||
1755 | static tree | |
1756 | gfc_trans_character_select (gfc_code *code) | |
1757 | { | |
8748ad99 | 1758 | tree init, end_label, tmp, type, case_num, label, fndecl; |
6de9cd9a DN |
1759 | stmtblock_t block, body; |
1760 | gfc_case *cp, *d; | |
1761 | gfc_code *c; | |
d2886bc7 | 1762 | gfc_se se, expr1se; |
d393bbd7 | 1763 | int n, k; |
8748ad99 | 1764 | VEC(constructor_elt,gc) *inits = NULL; |
d393bbd7 | 1765 | |
d2886bc7 JJ |
1766 | tree pchartype = gfc_get_pchar_type (code->expr1->ts.kind); |
1767 | ||
d393bbd7 FXC |
1768 | /* The jump table types are stored in static variables to avoid |
1769 | constructing them from scratch every single time. */ | |
d393bbd7 FXC |
1770 | static tree ss_string1[2], ss_string1_len[2]; |
1771 | static tree ss_string2[2], ss_string2_len[2]; | |
1772 | static tree ss_target[2]; | |
1773 | ||
d2886bc7 JJ |
1774 | cp = code->block->ext.case_list; |
1775 | while (cp->left != NULL) | |
1776 | cp = cp->left; | |
1777 | ||
1778 | /* Generate the body */ | |
1779 | gfc_start_block (&block); | |
1780 | gfc_init_se (&expr1se, NULL); | |
1781 | gfc_conv_expr_reference (&expr1se, code->expr1); | |
1782 | ||
1783 | gfc_add_block_to_block (&block, &expr1se.pre); | |
1784 | ||
1785 | end_label = gfc_build_label_decl (NULL_TREE); | |
1786 | ||
1787 | gfc_init_block (&body); | |
1788 | ||
1789 | /* Attempt to optimize length 1 selects. */ | |
86e033e2 | 1790 | if (integer_onep (expr1se.string_length)) |
d2886bc7 JJ |
1791 | { |
1792 | for (d = cp; d; d = d->right) | |
1793 | { | |
1794 | int i; | |
1795 | if (d->low) | |
1796 | { | |
1797 | gcc_assert (d->low->expr_type == EXPR_CONSTANT | |
1798 | && d->low->ts.type == BT_CHARACTER); | |
1799 | if (d->low->value.character.length > 1) | |
1800 | { | |
1801 | for (i = 1; i < d->low->value.character.length; i++) | |
1802 | if (d->low->value.character.string[i] != ' ') | |
1803 | break; | |
1804 | if (i != d->low->value.character.length) | |
1805 | { | |
1806 | if (optimize && d->high && i == 1) | |
1807 | { | |
1808 | gcc_assert (d->high->expr_type == EXPR_CONSTANT | |
1809 | && d->high->ts.type == BT_CHARACTER); | |
1810 | if (d->high->value.character.length > 1 | |
1811 | && (d->low->value.character.string[0] | |
1812 | == d->high->value.character.string[0]) | |
1813 | && d->high->value.character.string[1] != ' ' | |
1814 | && ((d->low->value.character.string[1] < ' ') | |
1815 | == (d->high->value.character.string[1] | |
1816 | < ' '))) | |
1817 | continue; | |
1818 | } | |
1819 | break; | |
1820 | } | |
1821 | } | |
1822 | } | |
1823 | if (d->high) | |
1824 | { | |
1825 | gcc_assert (d->high->expr_type == EXPR_CONSTANT | |
1826 | && d->high->ts.type == BT_CHARACTER); | |
1827 | if (d->high->value.character.length > 1) | |
1828 | { | |
1829 | for (i = 1; i < d->high->value.character.length; i++) | |
1830 | if (d->high->value.character.string[i] != ' ') | |
1831 | break; | |
1832 | if (i != d->high->value.character.length) | |
1833 | break; | |
1834 | } | |
1835 | } | |
1836 | } | |
1837 | if (d == NULL) | |
1838 | { | |
1839 | tree ctype = gfc_get_char_type (code->expr1->ts.kind); | |
1840 | ||
1841 | for (c = code->block; c; c = c->block) | |
1842 | { | |
1843 | for (cp = c->ext.case_list; cp; cp = cp->next) | |
1844 | { | |
1845 | tree low, high; | |
1846 | tree label; | |
1847 | gfc_char_t r; | |
1848 | ||
1849 | /* Assume it's the default case. */ | |
1850 | low = high = NULL_TREE; | |
1851 | ||
1852 | if (cp->low) | |
1853 | { | |
1854 | /* CASE ('ab') or CASE ('ab':'az') will never match | |
1855 | any length 1 character. */ | |
1856 | if (cp->low->value.character.length > 1 | |
1857 | && cp->low->value.character.string[1] != ' ') | |
1858 | continue; | |
1859 | ||
1860 | if (cp->low->value.character.length > 0) | |
1861 | r = cp->low->value.character.string[0]; | |
1862 | else | |
1863 | r = ' '; | |
1864 | low = build_int_cst (ctype, r); | |
1865 | ||
1866 | /* If there's only a lower bound, set the high bound | |
1867 | to the maximum value of the case expression. */ | |
1868 | if (!cp->high) | |
1869 | high = TYPE_MAX_VALUE (ctype); | |
1870 | } | |
1871 | ||
1872 | if (cp->high) | |
1873 | { | |
1874 | if (!cp->low | |
1875 | || (cp->low->value.character.string[0] | |
1876 | != cp->high->value.character.string[0])) | |
1877 | { | |
1878 | if (cp->high->value.character.length > 0) | |
1879 | r = cp->high->value.character.string[0]; | |
1880 | else | |
1881 | r = ' '; | |
1882 | high = build_int_cst (ctype, r); | |
1883 | } | |
1884 | ||
1885 | /* Unbounded case. */ | |
1886 | if (!cp->low) | |
1887 | low = TYPE_MIN_VALUE (ctype); | |
1888 | } | |
1889 | ||
1890 | /* Build a label. */ | |
1891 | label = gfc_build_label_decl (NULL_TREE); | |
1892 | ||
1893 | /* Add this case label. | |
1894 | Add parameter 'label', make it match GCC backend. */ | |
bc98ed60 TB |
1895 | tmp = fold_build3_loc (input_location, CASE_LABEL_EXPR, |
1896 | void_type_node, low, high, label); | |
d2886bc7 JJ |
1897 | gfc_add_expr_to_block (&body, tmp); |
1898 | } | |
1899 | ||
1900 | /* Add the statements for this case. */ | |
1901 | tmp = gfc_trans_code (c->next); | |
1902 | gfc_add_expr_to_block (&body, tmp); | |
1903 | ||
1904 | /* Break to the end of the construct. */ | |
1905 | tmp = build1_v (GOTO_EXPR, end_label); | |
1906 | gfc_add_expr_to_block (&body, tmp); | |
1907 | } | |
1908 | ||
1909 | tmp = gfc_string_to_single_character (expr1se.string_length, | |
1910 | expr1se.expr, | |
1911 | code->expr1->ts.kind); | |
1912 | case_num = gfc_create_var (ctype, "case_num"); | |
1913 | gfc_add_modify (&block, case_num, tmp); | |
1914 | ||
1915 | gfc_add_block_to_block (&block, &expr1se.post); | |
1916 | ||
1917 | tmp = gfc_finish_block (&body); | |
1918 | tmp = build3_v (SWITCH_EXPR, case_num, tmp, NULL_TREE); | |
1919 | gfc_add_expr_to_block (&block, tmp); | |
1920 | ||
1921 | tmp = build1_v (LABEL_EXPR, end_label); | |
1922 | gfc_add_expr_to_block (&block, tmp); | |
1923 | ||
1924 | return gfc_finish_block (&block); | |
1925 | } | |
1926 | } | |
6de9cd9a | 1927 | |
a513927a | 1928 | if (code->expr1->ts.kind == 1) |
d393bbd7 | 1929 | k = 0; |
a513927a | 1930 | else if (code->expr1->ts.kind == 4) |
d393bbd7 FXC |
1931 | k = 1; |
1932 | else | |
1933 | gcc_unreachable (); | |
6de9cd9a | 1934 | |
d393bbd7 | 1935 | if (select_struct[k] == NULL) |
6de9cd9a | 1936 | { |
dfd6ece2 | 1937 | tree *chain = NULL; |
d393bbd7 | 1938 | select_struct[k] = make_node (RECORD_TYPE); |
e2cad04b | 1939 | |
a513927a | 1940 | if (code->expr1->ts.kind == 1) |
d393bbd7 | 1941 | TYPE_NAME (select_struct[k]) = get_identifier ("_jump_struct_char1"); |
a513927a | 1942 | else if (code->expr1->ts.kind == 4) |
d393bbd7 FXC |
1943 | TYPE_NAME (select_struct[k]) = get_identifier ("_jump_struct_char4"); |
1944 | else | |
1945 | gcc_unreachable (); | |
6de9cd9a DN |
1946 | |
1947 | #undef ADD_FIELD | |
35151cd5 MM |
1948 | #define ADD_FIELD(NAME, TYPE) \ |
1949 | ss_##NAME[k] = gfc_add_field_to_struct (select_struct[k], \ | |
1950 | get_identifier (stringize(NAME)), \ | |
1951 | TYPE, \ | |
1952 | &chain) | |
6de9cd9a | 1953 | |
d393bbd7 FXC |
1954 | ADD_FIELD (string1, pchartype); |
1955 | ADD_FIELD (string1_len, gfc_charlen_type_node); | |
6de9cd9a | 1956 | |
d393bbd7 FXC |
1957 | ADD_FIELD (string2, pchartype); |
1958 | ADD_FIELD (string2_len, gfc_charlen_type_node); | |
6de9cd9a | 1959 | |
dd52ecb0 | 1960 | ADD_FIELD (target, integer_type_node); |
6de9cd9a DN |
1961 | #undef ADD_FIELD |
1962 | ||
d393bbd7 | 1963 | gfc_finish_type (select_struct[k]); |
6de9cd9a DN |
1964 | } |
1965 | ||
6de9cd9a DN |
1966 | n = 0; |
1967 | for (d = cp; d; d = d->right) | |
1968 | d->n = n++; | |
1969 | ||
6de9cd9a DN |
1970 | for (c = code->block; c; c = c->block) |
1971 | { | |
1972 | for (d = c->ext.case_list; d; d = d->next) | |
1973 | { | |
2b8327ce | 1974 | label = gfc_build_label_decl (NULL_TREE); |
bc98ed60 TB |
1975 | tmp = fold_build3_loc (input_location, CASE_LABEL_EXPR, |
1976 | void_type_node, | |
1977 | (d->low == NULL && d->high == NULL) | |
1978 | ? NULL : build_int_cst (NULL_TREE, d->n), | |
1979 | NULL, label); | |
6de9cd9a DN |
1980 | gfc_add_expr_to_block (&body, tmp); |
1981 | } | |
1982 | ||
1983 | tmp = gfc_trans_code (c->next); | |
1984 | gfc_add_expr_to_block (&body, tmp); | |
1985 | ||
923ab88c | 1986 | tmp = build1_v (GOTO_EXPR, end_label); |
6de9cd9a DN |
1987 | gfc_add_expr_to_block (&body, tmp); |
1988 | } | |
1989 | ||
1990 | /* Generate the structure describing the branches */ | |
d2886bc7 | 1991 | for (d = cp; d; d = d->right) |
6de9cd9a | 1992 | { |
8748ad99 | 1993 | VEC(constructor_elt,gc) *node = NULL; |
6de9cd9a DN |
1994 | |
1995 | gfc_init_se (&se, NULL); | |
1996 | ||
1997 | if (d->low == NULL) | |
1998 | { | |
8748ad99 NF |
1999 | CONSTRUCTOR_APPEND_ELT (node, ss_string1[k], null_pointer_node); |
2000 | CONSTRUCTOR_APPEND_ELT (node, ss_string1_len[k], integer_zero_node); | |
6de9cd9a DN |
2001 | } |
2002 | else | |
2003 | { | |
2004 | gfc_conv_expr_reference (&se, d->low); | |
2005 | ||
8748ad99 NF |
2006 | CONSTRUCTOR_APPEND_ELT (node, ss_string1[k], se.expr); |
2007 | CONSTRUCTOR_APPEND_ELT (node, ss_string1_len[k], se.string_length); | |
6de9cd9a DN |
2008 | } |
2009 | ||
2010 | if (d->high == NULL) | |
2011 | { | |
8748ad99 NF |
2012 | CONSTRUCTOR_APPEND_ELT (node, ss_string2[k], null_pointer_node); |
2013 | CONSTRUCTOR_APPEND_ELT (node, ss_string2_len[k], integer_zero_node); | |
6de9cd9a DN |
2014 | } |
2015 | else | |
2016 | { | |
2017 | gfc_init_se (&se, NULL); | |
2018 | gfc_conv_expr_reference (&se, d->high); | |
2019 | ||
8748ad99 NF |
2020 | CONSTRUCTOR_APPEND_ELT (node, ss_string2[k], se.expr); |
2021 | CONSTRUCTOR_APPEND_ELT (node, ss_string2_len[k], se.string_length); | |
6de9cd9a DN |
2022 | } |
2023 | ||
8748ad99 NF |
2024 | CONSTRUCTOR_APPEND_ELT (node, ss_target[k], |
2025 | build_int_cst (integer_type_node, d->n)); | |
6de9cd9a | 2026 | |
8748ad99 NF |
2027 | tmp = build_constructor (select_struct[k], node); |
2028 | CONSTRUCTOR_APPEND_ELT (inits, NULL_TREE, tmp); | |
6de9cd9a DN |
2029 | } |
2030 | ||
d393bbd7 FXC |
2031 | type = build_array_type (select_struct[k], |
2032 | build_index_type (build_int_cst (NULL_TREE, n-1))); | |
6de9cd9a | 2033 | |
8748ad99 | 2034 | init = build_constructor (type, inits); |
6de9cd9a | 2035 | TREE_CONSTANT (init) = 1; |
6de9cd9a DN |
2036 | TREE_STATIC (init) = 1; |
2037 | /* Create a static variable to hold the jump table. */ | |
2038 | tmp = gfc_create_var (type, "jumptable"); | |
2039 | TREE_CONSTANT (tmp) = 1; | |
6de9cd9a | 2040 | TREE_STATIC (tmp) = 1; |
0f0707d1 | 2041 | TREE_READONLY (tmp) = 1; |
6de9cd9a DN |
2042 | DECL_INITIAL (tmp) = init; |
2043 | init = tmp; | |
2044 | ||
5039610b | 2045 | /* Build the library call */ |
6de9cd9a | 2046 | init = gfc_build_addr_expr (pvoid_type_node, init); |
6de9cd9a | 2047 | |
a513927a | 2048 | if (code->expr1->ts.kind == 1) |
d393bbd7 | 2049 | fndecl = gfor_fndecl_select_string; |
a513927a | 2050 | else if (code->expr1->ts.kind == 4) |
d393bbd7 FXC |
2051 | fndecl = gfor_fndecl_select_string_char4; |
2052 | else | |
2053 | gcc_unreachable (); | |
2054 | ||
db3927fb AH |
2055 | tmp = build_call_expr_loc (input_location, |
2056 | fndecl, 4, init, build_int_cst (NULL_TREE, n), | |
d2886bc7 | 2057 | expr1se.expr, expr1se.string_length); |
dd52ecb0 | 2058 | case_num = gfc_create_var (integer_type_node, "case_num"); |
726a989a | 2059 | gfc_add_modify (&block, case_num, tmp); |
dc6c7714 | 2060 | |
d2886bc7 | 2061 | gfc_add_block_to_block (&block, &expr1se.post); |
dc6c7714 | 2062 | |
6de9cd9a | 2063 | tmp = gfc_finish_block (&body); |
2b8327ce | 2064 | tmp = build3_v (SWITCH_EXPR, case_num, tmp, NULL_TREE); |
6de9cd9a | 2065 | gfc_add_expr_to_block (&block, tmp); |
2b8327ce | 2066 | |
923ab88c | 2067 | tmp = build1_v (LABEL_EXPR, end_label); |
6de9cd9a DN |
2068 | gfc_add_expr_to_block (&block, tmp); |
2069 | ||
6de9cd9a DN |
2070 | return gfc_finish_block (&block); |
2071 | } | |
2072 | ||
2073 | ||
2074 | /* Translate the three variants of the SELECT CASE construct. | |
2075 | ||
2076 | SELECT CASEs with INTEGER case expressions can be translated to an | |
2077 | equivalent GENERIC switch statement, and for LOGICAL case | |
2078 | expressions we build one or two if-else compares. | |
2079 | ||
2080 | SELECT CASEs with CHARACTER case expressions are a whole different | |
2081 | story, because they don't exist in GENERIC. So we sort them and | |
2082 | do a binary search at runtime. | |
2083 | ||
2084 | Fortran has no BREAK statement, and it does not allow jumps from | |
2085 | one case block to another. That makes things a lot easier for | |
2086 | the optimizers. */ | |
2087 | ||
2088 | tree | |
2089 | gfc_trans_select (gfc_code * code) | |
2090 | { | |
e5ca9693 DK |
2091 | stmtblock_t block; |
2092 | tree body; | |
2093 | tree exit_label; | |
2094 | ||
a513927a | 2095 | gcc_assert (code && code->expr1); |
e5ca9693 DK |
2096 | gfc_init_block (&block); |
2097 | ||
2098 | /* Build the exit label and hang it in. */ | |
2099 | exit_label = gfc_build_label_decl (NULL_TREE); | |
2100 | code->exit_label = exit_label; | |
6de9cd9a DN |
2101 | |
2102 | /* Empty SELECT constructs are legal. */ | |
2103 | if (code->block == NULL) | |
e5ca9693 | 2104 | body = build_empty_stmt (input_location); |
6de9cd9a DN |
2105 | |
2106 | /* Select the correct translation function. */ | |
e5ca9693 DK |
2107 | else |
2108 | switch (code->expr1->ts.type) | |
2109 | { | |
2110 | case BT_LOGICAL: | |
2111 | body = gfc_trans_logical_select (code); | |
2112 | break; | |
2113 | ||
2114 | case BT_INTEGER: | |
2115 | body = gfc_trans_integer_select (code); | |
2116 | break; | |
2117 | ||
2118 | case BT_CHARACTER: | |
2119 | body = gfc_trans_character_select (code); | |
2120 | break; | |
2121 | ||
2122 | default: | |
2123 | gfc_internal_error ("gfc_trans_select(): Bad type for case expr."); | |
2124 | /* Not reached */ | |
2125 | } | |
2126 | ||
2127 | /* Build everything together. */ | |
2128 | gfc_add_expr_to_block (&block, body); | |
2129 | gfc_add_expr_to_block (&block, build1_v (LABEL_EXPR, exit_label)); | |
2130 | ||
2131 | return gfc_finish_block (&block); | |
6de9cd9a DN |
2132 | } |
2133 | ||
2134 | ||
640670c7 PT |
2135 | /* Traversal function to substitute a replacement symtree if the symbol |
2136 | in the expression is the same as that passed. f == 2 signals that | |
2137 | that variable itself is not to be checked - only the references. | |
2138 | This group of functions is used when the variable expression in a | |
2139 | FORALL assignment has internal references. For example: | |
2140 | FORALL (i = 1:4) p(p(i)) = i | |
2141 | The only recourse here is to store a copy of 'p' for the index | |
2142 | expression. */ | |
2143 | ||
2144 | static gfc_symtree *new_symtree; | |
2145 | static gfc_symtree *old_symtree; | |
2146 | ||
2147 | static bool | |
2148 | forall_replace (gfc_expr *expr, gfc_symbol *sym, int *f) | |
2149 | { | |
908a2235 PT |
2150 | if (expr->expr_type != EXPR_VARIABLE) |
2151 | return false; | |
640670c7 PT |
2152 | |
2153 | if (*f == 2) | |
2154 | *f = 1; | |
2155 | else if (expr->symtree->n.sym == sym) | |
2156 | expr->symtree = new_symtree; | |
2157 | ||
2158 | return false; | |
2159 | } | |
2160 | ||
2161 | static void | |
2162 | forall_replace_symtree (gfc_expr *e, gfc_symbol *sym, int f) | |
2163 | { | |
2164 | gfc_traverse_expr (e, sym, forall_replace, f); | |
2165 | } | |
2166 | ||
2167 | static bool | |
2168 | forall_restore (gfc_expr *expr, | |
2169 | gfc_symbol *sym ATTRIBUTE_UNUSED, | |
2170 | int *f ATTRIBUTE_UNUSED) | |
2171 | { | |
908a2235 PT |
2172 | if (expr->expr_type != EXPR_VARIABLE) |
2173 | return false; | |
640670c7 PT |
2174 | |
2175 | if (expr->symtree == new_symtree) | |
2176 | expr->symtree = old_symtree; | |
2177 | ||
2178 | return false; | |
2179 | } | |
2180 | ||
2181 | static void | |
2182 | forall_restore_symtree (gfc_expr *e) | |
2183 | { | |
2184 | gfc_traverse_expr (e, NULL, forall_restore, 0); | |
2185 | } | |
2186 | ||
2187 | static void | |
2188 | forall_make_variable_temp (gfc_code *c, stmtblock_t *pre, stmtblock_t *post) | |
2189 | { | |
2190 | gfc_se tse; | |
2191 | gfc_se rse; | |
2192 | gfc_expr *e; | |
2193 | gfc_symbol *new_sym; | |
2194 | gfc_symbol *old_sym; | |
2195 | gfc_symtree *root; | |
2196 | tree tmp; | |
2197 | ||
2198 | /* Build a copy of the lvalue. */ | |
a513927a | 2199 | old_symtree = c->expr1->symtree; |
640670c7 PT |
2200 | old_sym = old_symtree->n.sym; |
2201 | e = gfc_lval_expr_from_sym (old_sym); | |
2202 | if (old_sym->attr.dimension) | |
2203 | { | |
2204 | gfc_init_se (&tse, NULL); | |
430f2d1f | 2205 | gfc_conv_subref_array_arg (&tse, e, 0, INTENT_IN, false); |
640670c7 PT |
2206 | gfc_add_block_to_block (pre, &tse.pre); |
2207 | gfc_add_block_to_block (post, &tse.post); | |
db3927fb | 2208 | tse.expr = build_fold_indirect_ref_loc (input_location, tse.expr); |
640670c7 PT |
2209 | |
2210 | if (e->ts.type != BT_CHARACTER) | |
2211 | { | |
2212 | /* Use the variable offset for the temporary. */ | |
568e8e1e PT |
2213 | tmp = gfc_conv_array_offset (old_sym->backend_decl); |
2214 | gfc_conv_descriptor_offset_set (pre, tse.expr, tmp); | |
640670c7 PT |
2215 | } |
2216 | } | |
2217 | else | |
2218 | { | |
2219 | gfc_init_se (&tse, NULL); | |
2220 | gfc_init_se (&rse, NULL); | |
2221 | gfc_conv_expr (&rse, e); | |
2222 | if (e->ts.type == BT_CHARACTER) | |
2223 | { | |
2224 | tse.string_length = rse.string_length; | |
2225 | tmp = gfc_get_character_type_len (gfc_default_character_kind, | |
2226 | tse.string_length); | |
2227 | tse.expr = gfc_conv_string_tmp (&tse, build_pointer_type (tmp), | |
2228 | rse.string_length); | |
2229 | gfc_add_block_to_block (pre, &tse.pre); | |
2230 | gfc_add_block_to_block (post, &tse.post); | |
2231 | } | |
2232 | else | |
2233 | { | |
2234 | tmp = gfc_typenode_for_spec (&e->ts); | |
2235 | tse.expr = gfc_create_var (tmp, "temp"); | |
2236 | } | |
2237 | ||
2238 | tmp = gfc_trans_scalar_assign (&tse, &rse, e->ts, true, | |
2b56d6a4 | 2239 | e->expr_type == EXPR_VARIABLE, true); |
640670c7 PT |
2240 | gfc_add_expr_to_block (pre, tmp); |
2241 | } | |
2242 | gfc_free_expr (e); | |
2243 | ||
2244 | /* Create a new symbol to represent the lvalue. */ | |
2245 | new_sym = gfc_new_symbol (old_sym->name, NULL); | |
2246 | new_sym->ts = old_sym->ts; | |
2247 | new_sym->attr.referenced = 1; | |
59e36b72 | 2248 | new_sym->attr.temporary = 1; |
640670c7 PT |
2249 | new_sym->attr.dimension = old_sym->attr.dimension; |
2250 | new_sym->attr.flavor = old_sym->attr.flavor; | |
2251 | ||
2252 | /* Use the temporary as the backend_decl. */ | |
2253 | new_sym->backend_decl = tse.expr; | |
2254 | ||
2255 | /* Create a fake symtree for it. */ | |
2256 | root = NULL; | |
2257 | new_symtree = gfc_new_symtree (&root, old_sym->name); | |
2258 | new_symtree->n.sym = new_sym; | |
2259 | gcc_assert (new_symtree == root); | |
2260 | ||
2261 | /* Go through the expression reference replacing the old_symtree | |
2262 | with the new. */ | |
a513927a | 2263 | forall_replace_symtree (c->expr1, old_sym, 2); |
640670c7 PT |
2264 | |
2265 | /* Now we have made this temporary, we might as well use it for | |
2266 | the right hand side. */ | |
2267 | forall_replace_symtree (c->expr2, old_sym, 1); | |
2268 | } | |
2269 | ||
2270 | ||
2271 | /* Handles dependencies in forall assignments. */ | |
2272 | static int | |
2273 | check_forall_dependencies (gfc_code *c, stmtblock_t *pre, stmtblock_t *post) | |
2274 | { | |
2275 | gfc_ref *lref; | |
2276 | gfc_ref *rref; | |
2277 | int need_temp; | |
2278 | gfc_symbol *lsym; | |
2279 | ||
a513927a SK |
2280 | lsym = c->expr1->symtree->n.sym; |
2281 | need_temp = gfc_check_dependency (c->expr1, c->expr2, 0); | |
640670c7 PT |
2282 | |
2283 | /* Now check for dependencies within the 'variable' | |
2284 | expression itself. These are treated by making a complete | |
2285 | copy of variable and changing all the references to it | |
2286 | point to the copy instead. Note that the shallow copy of | |
2287 | the variable will not suffice for derived types with | |
2288 | pointer components. We therefore leave these to their | |
2289 | own devices. */ | |
2290 | if (lsym->ts.type == BT_DERIVED | |
bc21d315 | 2291 | && lsym->ts.u.derived->attr.pointer_comp) |
640670c7 PT |
2292 | return need_temp; |
2293 | ||
2294 | new_symtree = NULL; | |
a513927a | 2295 | if (find_forall_index (c->expr1, lsym, 2) == SUCCESS) |
640670c7 PT |
2296 | { |
2297 | forall_make_variable_temp (c, pre, post); | |
2298 | need_temp = 0; | |
2299 | } | |
2300 | ||
2301 | /* Substrings with dependencies are treated in the same | |
2302 | way. */ | |
a513927a SK |
2303 | if (c->expr1->ts.type == BT_CHARACTER |
2304 | && c->expr1->ref | |
640670c7 PT |
2305 | && c->expr2->expr_type == EXPR_VARIABLE |
2306 | && lsym == c->expr2->symtree->n.sym) | |
2307 | { | |
a513927a | 2308 | for (lref = c->expr1->ref; lref; lref = lref->next) |
640670c7 PT |
2309 | if (lref->type == REF_SUBSTRING) |
2310 | break; | |
2311 | for (rref = c->expr2->ref; rref; rref = rref->next) | |
2312 | if (rref->type == REF_SUBSTRING) | |
2313 | break; | |
2314 | ||
2315 | if (rref && lref | |
2316 | && gfc_dep_compare_expr (rref->u.ss.start, lref->u.ss.start) < 0) | |
2317 | { | |
2318 | forall_make_variable_temp (c, pre, post); | |
2319 | need_temp = 0; | |
2320 | } | |
2321 | } | |
2322 | return need_temp; | |
2323 | } | |
2324 | ||
2325 | ||
2326 | static void | |
2327 | cleanup_forall_symtrees (gfc_code *c) | |
2328 | { | |
a513927a | 2329 | forall_restore_symtree (c->expr1); |
640670c7 PT |
2330 | forall_restore_symtree (c->expr2); |
2331 | gfc_free (new_symtree->n.sym); | |
2332 | gfc_free (new_symtree); | |
2333 | } | |
2334 | ||
2335 | ||
bfcabc6c RS |
2336 | /* Generate the loops for a FORALL block, specified by FORALL_TMP. BODY |
2337 | is the contents of the FORALL block/stmt to be iterated. MASK_FLAG | |
2338 | indicates whether we should generate code to test the FORALLs mask | |
2339 | array. OUTER is the loop header to be used for initializing mask | |
2340 | indices. | |
2341 | ||
2342 | The generated loop format is: | |
6de9cd9a DN |
2343 | count = (end - start + step) / step |
2344 | loopvar = start | |
2345 | while (1) | |
2346 | { | |
2347 | if (count <=0 ) | |
2348 | goto end_of_loop | |
2349 | <body> | |
2350 | loopvar += step | |
2351 | count -- | |
2352 | } | |
2353 | end_of_loop: */ | |
2354 | ||
2355 | static tree | |
bfcabc6c RS |
2356 | gfc_trans_forall_loop (forall_info *forall_tmp, tree body, |
2357 | int mask_flag, stmtblock_t *outer) | |
6de9cd9a | 2358 | { |
bfcabc6c | 2359 | int n, nvar; |
6de9cd9a DN |
2360 | tree tmp; |
2361 | tree cond; | |
2362 | stmtblock_t block; | |
2363 | tree exit_label; | |
2364 | tree count; | |
fcf3be37 | 2365 | tree var, start, end, step; |
6de9cd9a DN |
2366 | iter_info *iter; |
2367 | ||
bfcabc6c RS |
2368 | /* Initialize the mask index outside the FORALL nest. */ |
2369 | if (mask_flag && forall_tmp->mask) | |
726a989a | 2370 | gfc_add_modify (outer, forall_tmp->maskindex, gfc_index_zero_node); |
bfcabc6c | 2371 | |
6de9cd9a | 2372 | iter = forall_tmp->this_loop; |
bfcabc6c | 2373 | nvar = forall_tmp->nvar; |
6de9cd9a DN |
2374 | for (n = 0; n < nvar; n++) |
2375 | { | |
2376 | var = iter->var; | |
2377 | start = iter->start; | |
2378 | end = iter->end; | |
2379 | step = iter->step; | |
2380 | ||
2381 | exit_label = gfc_build_label_decl (NULL_TREE); | |
2382 | TREE_USED (exit_label) = 1; | |
2383 | ||
2384 | /* The loop counter. */ | |
2385 | count = gfc_create_var (TREE_TYPE (var), "count"); | |
2386 | ||
2387 | /* The body of the loop. */ | |
2388 | gfc_init_block (&block); | |
2389 | ||
2390 | /* The exit condition. */ | |
bc98ed60 TB |
2391 | cond = fold_build2_loc (input_location, LE_EXPR, boolean_type_node, |
2392 | count, build_int_cst (TREE_TYPE (count), 0)); | |
6de9cd9a | 2393 | tmp = build1_v (GOTO_EXPR, exit_label); |
bc98ed60 TB |
2394 | tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, |
2395 | cond, tmp, build_empty_stmt (input_location)); | |
6de9cd9a DN |
2396 | gfc_add_expr_to_block (&block, tmp); |
2397 | ||
2398 | /* The main loop body. */ | |
2399 | gfc_add_expr_to_block (&block, body); | |
2400 | ||
2401 | /* Increment the loop variable. */ | |
bc98ed60 TB |
2402 | tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (var), var, |
2403 | step); | |
726a989a | 2404 | gfc_add_modify (&block, var, tmp); |
6de9cd9a | 2405 | |
a8e12e4d TS |
2406 | /* Advance to the next mask element. Only do this for the |
2407 | innermost loop. */ | |
fcf3be37 JJ |
2408 | if (n == 0 && mask_flag && forall_tmp->mask) |
2409 | { | |
2410 | tree maskindex = forall_tmp->maskindex; | |
bc98ed60 TB |
2411 | tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, |
2412 | maskindex, gfc_index_one_node); | |
726a989a | 2413 | gfc_add_modify (&block, maskindex, tmp); |
fcf3be37 JJ |
2414 | } |
2415 | ||
6de9cd9a | 2416 | /* Decrement the loop counter. */ |
bc98ed60 TB |
2417 | tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (var), count, |
2418 | build_int_cst (TREE_TYPE (var), 1)); | |
726a989a | 2419 | gfc_add_modify (&block, count, tmp); |
6de9cd9a DN |
2420 | |
2421 | body = gfc_finish_block (&block); | |
2422 | ||
2423 | /* Loop var initialization. */ | |
2424 | gfc_init_block (&block); | |
726a989a | 2425 | gfc_add_modify (&block, var, start); |
6de9cd9a | 2426 | |
fcf3be37 | 2427 | |
6de9cd9a | 2428 | /* Initialize the loop counter. */ |
bc98ed60 TB |
2429 | tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (var), step, |
2430 | start); | |
2431 | tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (var), end, | |
2432 | tmp); | |
2433 | tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR, TREE_TYPE (var), | |
2434 | tmp, step); | |
726a989a | 2435 | gfc_add_modify (&block, count, tmp); |
6de9cd9a DN |
2436 | |
2437 | /* The loop expression. */ | |
923ab88c | 2438 | tmp = build1_v (LOOP_EXPR, body); |
6de9cd9a DN |
2439 | gfc_add_expr_to_block (&block, tmp); |
2440 | ||
2441 | /* The exit label. */ | |
2442 | tmp = build1_v (LABEL_EXPR, exit_label); | |
2443 | gfc_add_expr_to_block (&block, tmp); | |
2444 | ||
2445 | body = gfc_finish_block (&block); | |
2446 | iter = iter->next; | |
2447 | } | |
2448 | return body; | |
2449 | } | |
2450 | ||
2451 | ||
bfcabc6c RS |
2452 | /* Generate the body and loops according to MASK_FLAG. If MASK_FLAG |
2453 | is nonzero, the body is controlled by all masks in the forall nest. | |
2454 | Otherwise, the innermost loop is not controlled by it's mask. This | |
2455 | is used for initializing that mask. */ | |
6de9cd9a DN |
2456 | |
2457 | static tree | |
2458 | gfc_trans_nested_forall_loop (forall_info * nested_forall_info, tree body, | |
bfcabc6c | 2459 | int mask_flag) |
6de9cd9a DN |
2460 | { |
2461 | tree tmp; | |
bfcabc6c | 2462 | stmtblock_t header; |
6de9cd9a | 2463 | forall_info *forall_tmp; |
bfcabc6c RS |
2464 | tree mask, maskindex; |
2465 | ||
2466 | gfc_start_block (&header); | |
6de9cd9a DN |
2467 | |
2468 | forall_tmp = nested_forall_info; | |
bfcabc6c | 2469 | while (forall_tmp != NULL) |
6de9cd9a | 2470 | { |
bfcabc6c RS |
2471 | /* Generate body with masks' control. */ |
2472 | if (mask_flag) | |
6de9cd9a | 2473 | { |
bfcabc6c RS |
2474 | mask = forall_tmp->mask; |
2475 | maskindex = forall_tmp->maskindex; | |
6de9cd9a | 2476 | |
bfcabc6c RS |
2477 | /* If a mask was specified make the assignment conditional. */ |
2478 | if (mask) | |
2479 | { | |
1d6b7f39 | 2480 | tmp = gfc_build_array_ref (mask, maskindex, NULL); |
c2255bc4 AH |
2481 | body = build3_v (COND_EXPR, tmp, body, |
2482 | build_empty_stmt (input_location)); | |
6de9cd9a | 2483 | } |
6de9cd9a | 2484 | } |
bfcabc6c | 2485 | body = gfc_trans_forall_loop (forall_tmp, body, mask_flag, &header); |
e8d366ec | 2486 | forall_tmp = forall_tmp->prev_nest; |
bfcabc6c | 2487 | mask_flag = 1; |
6de9cd9a DN |
2488 | } |
2489 | ||
bfcabc6c RS |
2490 | gfc_add_expr_to_block (&header, body); |
2491 | return gfc_finish_block (&header); | |
6de9cd9a DN |
2492 | } |
2493 | ||
2494 | ||
2495 | /* Allocate data for holding a temporary array. Returns either a local | |
2496 | temporary array or a pointer variable. */ | |
2497 | ||
2498 | static tree | |
2499 | gfc_do_allocate (tree bytesize, tree size, tree * pdata, stmtblock_t * pblock, | |
2500 | tree elem_type) | |
2501 | { | |
2502 | tree tmpvar; | |
2503 | tree type; | |
2504 | tree tmp; | |
6de9cd9a DN |
2505 | |
2506 | if (INTEGER_CST_P (size)) | |
bc98ed60 TB |
2507 | tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, |
2508 | size, gfc_index_one_node); | |
6de9cd9a DN |
2509 | else |
2510 | tmp = NULL_TREE; | |
2511 | ||
7ab92584 | 2512 | type = build_range_type (gfc_array_index_type, gfc_index_zero_node, tmp); |
6de9cd9a DN |
2513 | type = build_array_type (elem_type, type); |
2514 | if (gfc_can_put_var_on_stack (bytesize)) | |
2515 | { | |
6e45f57b | 2516 | gcc_assert (INTEGER_CST_P (size)); |
6de9cd9a DN |
2517 | tmpvar = gfc_create_var (type, "temp"); |
2518 | *pdata = NULL_TREE; | |
2519 | } | |
2520 | else | |
2521 | { | |
2522 | tmpvar = gfc_create_var (build_pointer_type (type), "temp"); | |
2523 | *pdata = convert (pvoid_type_node, tmpvar); | |
2524 | ||
1529b8d9 | 2525 | tmp = gfc_call_malloc (pblock, TREE_TYPE (tmpvar), bytesize); |
726a989a | 2526 | gfc_add_modify (pblock, tmpvar, tmp); |
6de9cd9a DN |
2527 | } |
2528 | return tmpvar; | |
2529 | } | |
2530 | ||
2531 | ||
2532 | /* Generate codes to copy the temporary to the actual lhs. */ | |
2533 | ||
2534 | static tree | |
8de1f441 | 2535 | generate_loop_for_temp_to_lhs (gfc_expr *expr, tree tmp1, tree count3, |
011daa76 | 2536 | tree count1, tree wheremask, bool invert) |
6de9cd9a DN |
2537 | { |
2538 | gfc_ss *lss; | |
2539 | gfc_se lse, rse; | |
2540 | stmtblock_t block, body; | |
2541 | gfc_loopinfo loop1; | |
011daa76 | 2542 | tree tmp; |
6de9cd9a DN |
2543 | tree wheremaskexpr; |
2544 | ||
2545 | /* Walk the lhs. */ | |
2546 | lss = gfc_walk_expr (expr); | |
2547 | ||
2548 | if (lss == gfc_ss_terminator) | |
2549 | { | |
2550 | gfc_start_block (&block); | |
2551 | ||
2552 | gfc_init_se (&lse, NULL); | |
2553 | ||
2554 | /* Translate the expression. */ | |
2555 | gfc_conv_expr (&lse, expr); | |
2556 | ||
2557 | /* Form the expression for the temporary. */ | |
1d6b7f39 | 2558 | tmp = gfc_build_array_ref (tmp1, count1, NULL); |
6de9cd9a DN |
2559 | |
2560 | /* Use the scalar assignment as is. */ | |
2561 | gfc_add_block_to_block (&block, &lse.pre); | |
726a989a | 2562 | gfc_add_modify (&block, lse.expr, tmp); |
6de9cd9a DN |
2563 | gfc_add_block_to_block (&block, &lse.post); |
2564 | ||
2565 | /* Increment the count1. */ | |
bc98ed60 TB |
2566 | tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (count1), |
2567 | count1, gfc_index_one_node); | |
726a989a | 2568 | gfc_add_modify (&block, count1, tmp); |
8de1f441 | 2569 | |
6de9cd9a DN |
2570 | tmp = gfc_finish_block (&block); |
2571 | } | |
2572 | else | |
2573 | { | |
2574 | gfc_start_block (&block); | |
2575 | ||
2576 | gfc_init_loopinfo (&loop1); | |
2577 | gfc_init_se (&rse, NULL); | |
2578 | gfc_init_se (&lse, NULL); | |
2579 | ||
2580 | /* Associate the lss with the loop. */ | |
2581 | gfc_add_ss_to_loop (&loop1, lss); | |
2582 | ||
2583 | /* Calculate the bounds of the scalarization. */ | |
2584 | gfc_conv_ss_startstride (&loop1); | |
2585 | /* Setup the scalarizing loops. */ | |
bdfd2ff0 | 2586 | gfc_conv_loop_setup (&loop1, &expr->where); |
6de9cd9a DN |
2587 | |
2588 | gfc_mark_ss_chain_used (lss, 1); | |
6de9cd9a DN |
2589 | |
2590 | /* Start the scalarized loop body. */ | |
2591 | gfc_start_scalarized_body (&loop1, &body); | |
2592 | ||
2593 | /* Setup the gfc_se structures. */ | |
2594 | gfc_copy_loopinfo_to_se (&lse, &loop1); | |
2595 | lse.ss = lss; | |
2596 | ||
2597 | /* Form the expression of the temporary. */ | |
2598 | if (lss != gfc_ss_terminator) | |
1d6b7f39 | 2599 | rse.expr = gfc_build_array_ref (tmp1, count1, NULL); |
6de9cd9a DN |
2600 | /* Translate expr. */ |
2601 | gfc_conv_expr (&lse, expr); | |
2602 | ||
2603 | /* Use the scalar assignment. */ | |
5046aff5 | 2604 | rse.string_length = lse.string_length; |
2b56d6a4 | 2605 | tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, true, true); |
6de9cd9a | 2606 | |
011daa76 RS |
2607 | /* Form the mask expression according to the mask tree list. */ |
2608 | if (wheremask) | |
2609 | { | |
1d6b7f39 | 2610 | wheremaskexpr = gfc_build_array_ref (wheremask, count3, NULL); |
011daa76 | 2611 | if (invert) |
bc98ed60 TB |
2612 | wheremaskexpr = fold_build1_loc (input_location, TRUTH_NOT_EXPR, |
2613 | TREE_TYPE (wheremaskexpr), | |
2614 | wheremaskexpr); | |
2615 | tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, | |
2616 | wheremaskexpr, tmp, | |
2617 | build_empty_stmt (input_location)); | |
6de9cd9a DN |
2618 | } |
2619 | ||
2620 | gfc_add_expr_to_block (&body, tmp); | |
2621 | ||
8de1f441 | 2622 | /* Increment count1. */ |
bc98ed60 TB |
2623 | tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, |
2624 | count1, gfc_index_one_node); | |
726a989a | 2625 | gfc_add_modify (&body, count1, tmp); |
6de9cd9a DN |
2626 | |
2627 | /* Increment count3. */ | |
2628 | if (count3) | |
8de1f441 | 2629 | { |
bc98ed60 TB |
2630 | tmp = fold_build2_loc (input_location, PLUS_EXPR, |
2631 | gfc_array_index_type, count3, | |
2632 | gfc_index_one_node); | |
726a989a | 2633 | gfc_add_modify (&body, count3, tmp); |
8de1f441 | 2634 | } |
6de9cd9a DN |
2635 | |
2636 | /* Generate the copying loops. */ | |
2637 | gfc_trans_scalarizing_loops (&loop1, &body); | |
2638 | gfc_add_block_to_block (&block, &loop1.pre); | |
2639 | gfc_add_block_to_block (&block, &loop1.post); | |
2640 | gfc_cleanup_loop (&loop1); | |
2641 | ||
6de9cd9a DN |
2642 | tmp = gfc_finish_block (&block); |
2643 | } | |
2644 | return tmp; | |
2645 | } | |
2646 | ||
2647 | ||
011daa76 RS |
2648 | /* Generate codes to copy rhs to the temporary. TMP1 is the address of |
2649 | temporary, LSS and RSS are formed in function compute_inner_temp_size(), | |
2650 | and should not be freed. WHEREMASK is the conditional execution mask | |
2651 | whose sense may be inverted by INVERT. */ | |
6de9cd9a DN |
2652 | |
2653 | static tree | |
8de1f441 JJ |
2654 | generate_loop_for_rhs_to_temp (gfc_expr *expr2, tree tmp1, tree count3, |
2655 | tree count1, gfc_ss *lss, gfc_ss *rss, | |
011daa76 | 2656 | tree wheremask, bool invert) |
6de9cd9a DN |
2657 | { |
2658 | stmtblock_t block, body1; | |
2659 | gfc_loopinfo loop; | |
2660 | gfc_se lse; | |
2661 | gfc_se rse; | |
011daa76 | 2662 | tree tmp; |
6de9cd9a DN |
2663 | tree wheremaskexpr; |
2664 | ||
2665 | gfc_start_block (&block); | |
2666 | ||
2667 | gfc_init_se (&rse, NULL); | |
2668 | gfc_init_se (&lse, NULL); | |
2669 | ||
2670 | if (lss == gfc_ss_terminator) | |
2671 | { | |
2672 | gfc_init_block (&body1); | |
2673 | gfc_conv_expr (&rse, expr2); | |
1d6b7f39 | 2674 | lse.expr = gfc_build_array_ref (tmp1, count1, NULL); |
6de9cd9a DN |
2675 | } |
2676 | else | |
2677 | { | |
1f2959f0 | 2678 | /* Initialize the loop. */ |
6de9cd9a DN |
2679 | gfc_init_loopinfo (&loop); |
2680 | ||
2681 | /* We may need LSS to determine the shape of the expression. */ | |
2682 | gfc_add_ss_to_loop (&loop, lss); | |
2683 | gfc_add_ss_to_loop (&loop, rss); | |
2684 | ||
2685 | gfc_conv_ss_startstride (&loop); | |
bdfd2ff0 | 2686 | gfc_conv_loop_setup (&loop, &expr2->where); |
6de9cd9a DN |
2687 | |
2688 | gfc_mark_ss_chain_used (rss, 1); | |
2689 | /* Start the loop body. */ | |
2690 | gfc_start_scalarized_body (&loop, &body1); | |
2691 | ||
2692 | /* Translate the expression. */ | |
2693 | gfc_copy_loopinfo_to_se (&rse, &loop); | |
2694 | rse.ss = rss; | |
2695 | gfc_conv_expr (&rse, expr2); | |
2696 | ||
2697 | /* Form the expression of the temporary. */ | |
1d6b7f39 | 2698 | lse.expr = gfc_build_array_ref (tmp1, count1, NULL); |
6de9cd9a DN |
2699 | } |
2700 | ||
2701 | /* Use the scalar assignment. */ | |
5046aff5 PT |
2702 | lse.string_length = rse.string_length; |
2703 | tmp = gfc_trans_scalar_assign (&lse, &rse, expr2->ts, true, | |
2b56d6a4 | 2704 | expr2->expr_type == EXPR_VARIABLE, true); |
6de9cd9a DN |
2705 | |
2706 | /* Form the mask expression according to the mask tree list. */ | |
2707 | if (wheremask) | |
2708 | { | |
1d6b7f39 | 2709 | wheremaskexpr = gfc_build_array_ref (wheremask, count3, NULL); |
011daa76 | 2710 | if (invert) |
bc98ed60 TB |
2711 | wheremaskexpr = fold_build1_loc (input_location, TRUTH_NOT_EXPR, |
2712 | TREE_TYPE (wheremaskexpr), | |
2713 | wheremaskexpr); | |
2714 | tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, | |
2715 | wheremaskexpr, tmp, | |
2716 | build_empty_stmt (input_location)); | |
6de9cd9a DN |
2717 | } |
2718 | ||
2719 | gfc_add_expr_to_block (&body1, tmp); | |
2720 | ||
2721 | if (lss == gfc_ss_terminator) | |
2722 | { | |
2723 | gfc_add_block_to_block (&block, &body1); | |
8de1f441 JJ |
2724 | |
2725 | /* Increment count1. */ | |
bc98ed60 TB |
2726 | tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (count1), |
2727 | count1, gfc_index_one_node); | |
726a989a | 2728 | gfc_add_modify (&block, count1, tmp); |
6de9cd9a DN |
2729 | } |
2730 | else | |
2731 | { | |
8de1f441 | 2732 | /* Increment count1. */ |
bc98ed60 TB |
2733 | tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, |
2734 | count1, gfc_index_one_node); | |
726a989a | 2735 | gfc_add_modify (&body1, count1, tmp); |
6de9cd9a DN |
2736 | |
2737 | /* Increment count3. */ | |
2738 | if (count3) | |
8de1f441 | 2739 | { |
bc98ed60 TB |
2740 | tmp = fold_build2_loc (input_location, PLUS_EXPR, |
2741 | gfc_array_index_type, | |
2742 | count3, gfc_index_one_node); | |
726a989a | 2743 | gfc_add_modify (&body1, count3, tmp); |
8de1f441 | 2744 | } |
6de9cd9a DN |
2745 | |
2746 | /* Generate the copying loops. */ | |
2747 | gfc_trans_scalarizing_loops (&loop, &body1); | |
2748 | ||
2749 | gfc_add_block_to_block (&block, &loop.pre); | |
2750 | gfc_add_block_to_block (&block, &loop.post); | |
2751 | ||
2752 | gfc_cleanup_loop (&loop); | |
2753 | /* TODO: Reuse lss and rss when copying temp->lhs. Need to be careful | |
8de1f441 | 2754 | as tree nodes in SS may not be valid in different scope. */ |
6de9cd9a | 2755 | } |
6de9cd9a DN |
2756 | |
2757 | tmp = gfc_finish_block (&block); | |
2758 | return tmp; | |
2759 | } | |
2760 | ||
2761 | ||
2762 | /* Calculate the size of temporary needed in the assignment inside forall. | |
2763 | LSS and RSS are filled in this function. */ | |
2764 | ||
2765 | static tree | |
2766 | compute_inner_temp_size (gfc_expr *expr1, gfc_expr *expr2, | |
2767 | stmtblock_t * pblock, | |
2768 | gfc_ss **lss, gfc_ss **rss) | |
2769 | { | |
2770 | gfc_loopinfo loop; | |
2771 | tree size; | |
2772 | int i; | |
ca86ddcc | 2773 | int save_flag; |
6de9cd9a DN |
2774 | tree tmp; |
2775 | ||
2776 | *lss = gfc_walk_expr (expr1); | |
2777 | *rss = NULL; | |
2778 | ||
7ab92584 | 2779 | size = gfc_index_one_node; |
6de9cd9a DN |
2780 | if (*lss != gfc_ss_terminator) |
2781 | { | |
2782 | gfc_init_loopinfo (&loop); | |
2783 | ||
2784 | /* Walk the RHS of the expression. */ | |
2785 | *rss = gfc_walk_expr (expr2); | |
2786 | if (*rss == gfc_ss_terminator) | |
2787 | { | |
2788 | /* The rhs is scalar. Add a ss for the expression. */ | |
2789 | *rss = gfc_get_ss (); | |
2790 | (*rss)->next = gfc_ss_terminator; | |
2791 | (*rss)->type = GFC_SS_SCALAR; | |
2792 | (*rss)->expr = expr2; | |
2793 | } | |
2794 | ||
2795 | /* Associate the SS with the loop. */ | |
2796 | gfc_add_ss_to_loop (&loop, *lss); | |
2797 | /* We don't actually need to add the rhs at this point, but it might | |
2798 | make guessing the loop bounds a bit easier. */ | |
2799 | gfc_add_ss_to_loop (&loop, *rss); | |
2800 | ||
2801 | /* We only want the shape of the expression, not rest of the junk | |
2802 | generated by the scalarizer. */ | |
2803 | loop.array_parameter = 1; | |
2804 | ||
2805 | /* Calculate the bounds of the scalarization. */ | |
d3d3011f FXC |
2806 | save_flag = gfc_option.rtcheck; |
2807 | gfc_option.rtcheck &= !GFC_RTCHECK_BOUNDS; | |
6de9cd9a | 2808 | gfc_conv_ss_startstride (&loop); |
d3d3011f | 2809 | gfc_option.rtcheck = save_flag; |
bdfd2ff0 | 2810 | gfc_conv_loop_setup (&loop, &expr2->where); |
6de9cd9a DN |
2811 | |
2812 | /* Figure out how many elements we need. */ | |
2813 | for (i = 0; i < loop.dimen; i++) | |
2814 | { | |
bc98ed60 TB |
2815 | tmp = fold_build2_loc (input_location, MINUS_EXPR, |
2816 | gfc_array_index_type, | |
2817 | gfc_index_one_node, loop.from[i]); | |
2818 | tmp = fold_build2_loc (input_location, PLUS_EXPR, | |
2819 | gfc_array_index_type, tmp, loop.to[i]); | |
2820 | size = fold_build2_loc (input_location, MULT_EXPR, | |
2821 | gfc_array_index_type, size, tmp); | |
6de9cd9a DN |
2822 | } |
2823 | gfc_add_block_to_block (pblock, &loop.pre); | |
2824 | size = gfc_evaluate_now (size, pblock); | |
2825 | gfc_add_block_to_block (pblock, &loop.post); | |
2826 | ||
2827 | /* TODO: write a function that cleans up a loopinfo without freeing | |
2828 | the SS chains. Currently a NOP. */ | |
2829 | } | |
2830 | ||
2831 | return size; | |
2832 | } | |
2833 | ||
2834 | ||
2ad62c9b RS |
2835 | /* Calculate the overall iterator number of the nested forall construct. |
2836 | This routine actually calculates the number of times the body of the | |
2837 | nested forall specified by NESTED_FORALL_INFO is executed and multiplies | |
2838 | that by the expression INNER_SIZE. The BLOCK argument specifies the | |
2839 | block in which to calculate the result, and the optional INNER_SIZE_BODY | |
2840 | argument contains any statements that need to executed (inside the loop) | |
2841 | to initialize or calculate INNER_SIZE. */ | |
6de9cd9a DN |
2842 | |
2843 | static tree | |
2844 | compute_overall_iter_number (forall_info *nested_forall_info, tree inner_size, | |
8de1f441 | 2845 | stmtblock_t *inner_size_body, stmtblock_t *block) |
6de9cd9a | 2846 | { |
2ad62c9b | 2847 | forall_info *forall_tmp = nested_forall_info; |
6de9cd9a DN |
2848 | tree tmp, number; |
2849 | stmtblock_t body; | |
2850 | ||
2ad62c9b RS |
2851 | /* We can eliminate the innermost unconditional loops with constant |
2852 | array bounds. */ | |
3bf783b7 RS |
2853 | if (INTEGER_CST_P (inner_size)) |
2854 | { | |
2ad62c9b RS |
2855 | while (forall_tmp |
2856 | && !forall_tmp->mask | |
2857 | && INTEGER_CST_P (forall_tmp->size)) | |
3bf783b7 | 2858 | { |
bc98ed60 TB |
2859 | inner_size = fold_build2_loc (input_location, MULT_EXPR, |
2860 | gfc_array_index_type, | |
2861 | inner_size, forall_tmp->size); | |
2ad62c9b | 2862 | forall_tmp = forall_tmp->prev_nest; |
3bf783b7 | 2863 | } |
2ad62c9b RS |
2864 | |
2865 | /* If there are no loops left, we have our constant result. */ | |
2866 | if (!forall_tmp) | |
2867 | return inner_size; | |
3bf783b7 | 2868 | } |
2ad62c9b RS |
2869 | |
2870 | /* Otherwise, create a temporary variable to compute the result. */ | |
6de9cd9a | 2871 | number = gfc_create_var (gfc_array_index_type, "num"); |
726a989a | 2872 | gfc_add_modify (block, number, gfc_index_zero_node); |
6de9cd9a DN |
2873 | |
2874 | gfc_start_block (&body); | |
8de1f441 JJ |
2875 | if (inner_size_body) |
2876 | gfc_add_block_to_block (&body, inner_size_body); | |
2ad62c9b | 2877 | if (forall_tmp) |
bc98ed60 TB |
2878 | tmp = fold_build2_loc (input_location, PLUS_EXPR, |
2879 | gfc_array_index_type, number, inner_size); | |
6de9cd9a DN |
2880 | else |
2881 | tmp = inner_size; | |
726a989a | 2882 | gfc_add_modify (&body, number, tmp); |
6de9cd9a DN |
2883 | tmp = gfc_finish_block (&body); |
2884 | ||
2885 | /* Generate loops. */ | |
2ad62c9b RS |
2886 | if (forall_tmp != NULL) |
2887 | tmp = gfc_trans_nested_forall_loop (forall_tmp, tmp, 1); | |
6de9cd9a DN |
2888 | |
2889 | gfc_add_expr_to_block (block, tmp); | |
2890 | ||
2891 | return number; | |
2892 | } | |
2893 | ||
2894 | ||
8de1f441 JJ |
2895 | /* Allocate temporary for forall construct. SIZE is the size of temporary |
2896 | needed. PTEMP1 is returned for space free. */ | |
6de9cd9a DN |
2897 | |
2898 | static tree | |
8de1f441 JJ |
2899 | allocate_temp_for_forall_nest_1 (tree type, tree size, stmtblock_t * block, |
2900 | tree * ptemp1) | |
6de9cd9a | 2901 | { |
bfcabc6c | 2902 | tree bytesize; |
6de9cd9a | 2903 | tree unit; |
6de9cd9a | 2904 | tree tmp; |
6de9cd9a | 2905 | |
7c57b2f1 | 2906 | unit = fold_convert (gfc_array_index_type, TYPE_SIZE_UNIT (type)); |
bfcabc6c | 2907 | if (!integer_onep (unit)) |
bc98ed60 TB |
2908 | bytesize = fold_build2_loc (input_location, MULT_EXPR, |
2909 | gfc_array_index_type, size, unit); | |
bfcabc6c RS |
2910 | else |
2911 | bytesize = size; | |
6de9cd9a DN |
2912 | |
2913 | *ptemp1 = NULL; | |
bfcabc6c | 2914 | tmp = gfc_do_allocate (bytesize, size, ptemp1, block, type); |
6de9cd9a DN |
2915 | |
2916 | if (*ptemp1) | |
db3927fb | 2917 | tmp = build_fold_indirect_ref_loc (input_location, tmp); |
6de9cd9a DN |
2918 | return tmp; |
2919 | } | |
2920 | ||
2921 | ||
8de1f441 JJ |
2922 | /* Allocate temporary for forall construct according to the information in |
2923 | nested_forall_info. INNER_SIZE is the size of temporary needed in the | |
2924 | assignment inside forall. PTEMP1 is returned for space free. */ | |
2925 | ||
2926 | static tree | |
2927 | allocate_temp_for_forall_nest (forall_info * nested_forall_info, tree type, | |
2928 | tree inner_size, stmtblock_t * inner_size_body, | |
2929 | stmtblock_t * block, tree * ptemp1) | |
2930 | { | |
2931 | tree size; | |
2932 | ||
2933 | /* Calculate the total size of temporary needed in forall construct. */ | |
2934 | size = compute_overall_iter_number (nested_forall_info, inner_size, | |
2935 | inner_size_body, block); | |
2936 | ||
2937 | return allocate_temp_for_forall_nest_1 (type, size, block, ptemp1); | |
2938 | } | |
2939 | ||
2940 | ||
2941 | /* Handle assignments inside forall which need temporary. | |
2942 | ||
2943 | forall (i=start:end:stride; maskexpr) | |
2944 | e<i> = f<i> | |
2945 | end forall | |
2946 | (where e,f<i> are arbitrary expressions possibly involving i | |
2947 | and there is a dependency between e<i> and f<i>) | |
2948 | Translates to: | |
2949 | masktmp(:) = maskexpr(:) | |
2950 | ||
2951 | maskindex = 0; | |
2952 | count1 = 0; | |
2953 | num = 0; | |
2954 | for (i = start; i <= end; i += stride) | |
2955 | num += SIZE (f<i>) | |
2956 | count1 = 0; | |
2957 | ALLOCATE (tmp(num)) | |
2958 | for (i = start; i <= end; i += stride) | |
2959 | { | |
2960 | if (masktmp[maskindex++]) | |
2961 | tmp[count1++] = f<i> | |
2962 | } | |
2963 | maskindex = 0; | |
2964 | count1 = 0; | |
2965 | for (i = start; i <= end; i += stride) | |
2966 | { | |
2967 | if (masktmp[maskindex++]) | |
2968 | e<i> = tmp[count1++] | |
2969 | } | |
2970 | DEALLOCATE (tmp) | |
2971 | */ | |
6de9cd9a | 2972 | static void |
011daa76 RS |
2973 | gfc_trans_assign_need_temp (gfc_expr * expr1, gfc_expr * expr2, |
2974 | tree wheremask, bool invert, | |
6de9cd9a DN |
2975 | forall_info * nested_forall_info, |
2976 | stmtblock_t * block) | |
2977 | { | |
2978 | tree type; | |
2979 | tree inner_size; | |
2980 | gfc_ss *lss, *rss; | |
8de1f441 | 2981 | tree count, count1; |
6de9cd9a DN |
2982 | tree tmp, tmp1; |
2983 | tree ptemp1; | |
8de1f441 | 2984 | stmtblock_t inner_size_body; |
6de9cd9a | 2985 | |
8de1f441 JJ |
2986 | /* Create vars. count1 is the current iterator number of the nested |
2987 | forall. */ | |
6de9cd9a | 2988 | count1 = gfc_create_var (gfc_array_index_type, "count1"); |
6de9cd9a DN |
2989 | |
2990 | /* Count is the wheremask index. */ | |
2991 | if (wheremask) | |
2992 | { | |
2993 | count = gfc_create_var (gfc_array_index_type, "count"); | |
726a989a | 2994 | gfc_add_modify (block, count, gfc_index_zero_node); |
6de9cd9a DN |
2995 | } |
2996 | else | |
2997 | count = NULL; | |
2998 | ||
2999 | /* Initialize count1. */ | |
726a989a | 3000 | gfc_add_modify (block, count1, gfc_index_zero_node); |
6de9cd9a DN |
3001 | |
3002 | /* Calculate the size of temporary needed in the assignment. Return loop, lss | |
3003 | and rss which are used in function generate_loop_for_rhs_to_temp(). */ | |
8de1f441 JJ |
3004 | gfc_init_block (&inner_size_body); |
3005 | inner_size = compute_inner_temp_size (expr1, expr2, &inner_size_body, | |
3006 | &lss, &rss); | |
6de9cd9a DN |
3007 | |
3008 | /* The type of LHS. Used in function allocate_temp_for_forall_nest */ | |
bc21d315 | 3009 | if (expr1->ts.type == BT_CHARACTER && expr1->ts.u.cl->length) |
640670c7 | 3010 | { |
bc21d315 | 3011 | if (!expr1->ts.u.cl->backend_decl) |
640670c7 PT |
3012 | { |
3013 | gfc_se tse; | |
3014 | gfc_init_se (&tse, NULL); | |
bc21d315 JW |
3015 | gfc_conv_expr (&tse, expr1->ts.u.cl->length); |
3016 | expr1->ts.u.cl->backend_decl = tse.expr; | |
640670c7 PT |
3017 | } |
3018 | type = gfc_get_character_type_len (gfc_default_character_kind, | |
bc21d315 | 3019 | expr1->ts.u.cl->backend_decl); |
640670c7 PT |
3020 | } |
3021 | else | |
3022 | type = gfc_typenode_for_spec (&expr1->ts); | |
6de9cd9a DN |
3023 | |
3024 | /* Allocate temporary for nested forall construct according to the | |
f7b529fa | 3025 | information in nested_forall_info and inner_size. */ |
8de1f441 JJ |
3026 | tmp1 = allocate_temp_for_forall_nest (nested_forall_info, type, inner_size, |
3027 | &inner_size_body, block, &ptemp1); | |
6de9cd9a | 3028 | |
6de9cd9a | 3029 | /* Generate codes to copy rhs to the temporary . */ |
8de1f441 | 3030 | tmp = generate_loop_for_rhs_to_temp (expr2, tmp1, count, count1, lss, rss, |
011daa76 | 3031 | wheremask, invert); |
6de9cd9a | 3032 | |
1f2959f0 | 3033 | /* Generate body and loops according to the information in |
6de9cd9a | 3034 | nested_forall_info. */ |
bfcabc6c | 3035 | tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1); |
6de9cd9a DN |
3036 | gfc_add_expr_to_block (block, tmp); |
3037 | ||
3038 | /* Reset count1. */ | |
726a989a | 3039 | gfc_add_modify (block, count1, gfc_index_zero_node); |
6de9cd9a | 3040 | |
6de9cd9a DN |
3041 | /* Reset count. */ |
3042 | if (wheremask) | |
726a989a | 3043 | gfc_add_modify (block, count, gfc_index_zero_node); |
6de9cd9a DN |
3044 | |
3045 | /* Generate codes to copy the temporary to lhs. */ | |
011daa76 RS |
3046 | tmp = generate_loop_for_temp_to_lhs (expr1, tmp1, count, count1, |
3047 | wheremask, invert); | |
6de9cd9a | 3048 | |
1f2959f0 | 3049 | /* Generate body and loops according to the information in |
6de9cd9a | 3050 | nested_forall_info. */ |
bfcabc6c | 3051 | tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1); |
6de9cd9a DN |
3052 | gfc_add_expr_to_block (block, tmp); |
3053 | ||
3054 | if (ptemp1) | |
3055 | { | |
3056 | /* Free the temporary. */ | |
1529b8d9 | 3057 | tmp = gfc_call_free (ptemp1); |
6de9cd9a DN |
3058 | gfc_add_expr_to_block (block, tmp); |
3059 | } | |
3060 | } | |
3061 | ||
3062 | ||
3063 | /* Translate pointer assignment inside FORALL which need temporary. */ | |
3064 | ||
3065 | static void | |
3066 | gfc_trans_pointer_assign_need_temp (gfc_expr * expr1, gfc_expr * expr2, | |
3067 | forall_info * nested_forall_info, | |
3068 | stmtblock_t * block) | |
3069 | { | |
3070 | tree type; | |
3071 | tree inner_size; | |
3072 | gfc_ss *lss, *rss; | |
3073 | gfc_se lse; | |
3074 | gfc_se rse; | |
3075 | gfc_ss_info *info; | |
3076 | gfc_loopinfo loop; | |
3077 | tree desc; | |
3078 | tree parm; | |
3079 | tree parmtype; | |
3080 | stmtblock_t body; | |
3081 | tree count; | |
3082 | tree tmp, tmp1, ptemp1; | |
6de9cd9a DN |
3083 | |
3084 | count = gfc_create_var (gfc_array_index_type, "count"); | |
726a989a | 3085 | gfc_add_modify (block, count, gfc_index_zero_node); |
6de9cd9a DN |
3086 | |
3087 | inner_size = integer_one_node; | |
3088 | lss = gfc_walk_expr (expr1); | |
3089 | rss = gfc_walk_expr (expr2); | |
3090 | if (lss == gfc_ss_terminator) | |
3091 | { | |
3092 | type = gfc_typenode_for_spec (&expr1->ts); | |
3093 | type = build_pointer_type (type); | |
3094 | ||
3095 | /* Allocate temporary for nested forall construct according to the | |
3096 | information in nested_forall_info and inner_size. */ | |
8de1f441 JJ |
3097 | tmp1 = allocate_temp_for_forall_nest (nested_forall_info, type, |
3098 | inner_size, NULL, block, &ptemp1); | |
6de9cd9a DN |
3099 | gfc_start_block (&body); |
3100 | gfc_init_se (&lse, NULL); | |
1d6b7f39 | 3101 | lse.expr = gfc_build_array_ref (tmp1, count, NULL); |
6de9cd9a DN |
3102 | gfc_init_se (&rse, NULL); |
3103 | rse.want_pointer = 1; | |
3104 | gfc_conv_expr (&rse, expr2); | |
3105 | gfc_add_block_to_block (&body, &rse.pre); | |
726a989a | 3106 | gfc_add_modify (&body, lse.expr, |
cc2804f1 | 3107 | fold_convert (TREE_TYPE (lse.expr), rse.expr)); |
6de9cd9a DN |
3108 | gfc_add_block_to_block (&body, &rse.post); |
3109 | ||
3110 | /* Increment count. */ | |
bc98ed60 TB |
3111 | tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, |
3112 | count, gfc_index_one_node); | |
726a989a | 3113 | gfc_add_modify (&body, count, tmp); |
6de9cd9a DN |
3114 | |
3115 | tmp = gfc_finish_block (&body); | |
3116 | ||
1f2959f0 | 3117 | /* Generate body and loops according to the information in |
6de9cd9a | 3118 | nested_forall_info. */ |
bfcabc6c | 3119 | tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1); |
6de9cd9a DN |
3120 | gfc_add_expr_to_block (block, tmp); |
3121 | ||
3122 | /* Reset count. */ | |
726a989a | 3123 | gfc_add_modify (block, count, gfc_index_zero_node); |
6de9cd9a | 3124 | |
6de9cd9a DN |
3125 | gfc_start_block (&body); |
3126 | gfc_init_se (&lse, NULL); | |
3127 | gfc_init_se (&rse, NULL); | |
1d6b7f39 | 3128 | rse.expr = gfc_build_array_ref (tmp1, count, NULL); |
6de9cd9a DN |
3129 | lse.want_pointer = 1; |
3130 | gfc_conv_expr (&lse, expr1); | |
3131 | gfc_add_block_to_block (&body, &lse.pre); | |
726a989a | 3132 | gfc_add_modify (&body, lse.expr, rse.expr); |
6de9cd9a DN |
3133 | gfc_add_block_to_block (&body, &lse.post); |
3134 | /* Increment count. */ | |
bc98ed60 TB |
3135 | tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, |
3136 | count, gfc_index_one_node); | |
726a989a | 3137 | gfc_add_modify (&body, count, tmp); |
6de9cd9a DN |
3138 | tmp = gfc_finish_block (&body); |
3139 | ||
1f2959f0 | 3140 | /* Generate body and loops according to the information in |
6de9cd9a | 3141 | nested_forall_info. */ |
bfcabc6c | 3142 | tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1); |
6de9cd9a DN |
3143 | gfc_add_expr_to_block (block, tmp); |
3144 | } | |
3145 | else | |
3146 | { | |
3147 | gfc_init_loopinfo (&loop); | |
3148 | ||
3149 | /* Associate the SS with the loop. */ | |
3150 | gfc_add_ss_to_loop (&loop, rss); | |
3151 | ||
3152 | /* Setup the scalarizing loops and bounds. */ | |
3153 | gfc_conv_ss_startstride (&loop); | |
3154 | ||
bdfd2ff0 | 3155 | gfc_conv_loop_setup (&loop, &expr2->where); |
6de9cd9a DN |
3156 | |
3157 | info = &rss->data.info; | |
3158 | desc = info->descriptor; | |
3159 | ||
3160 | /* Make a new descriptor. */ | |
3161 | parmtype = gfc_get_element_type (TREE_TYPE (desc)); | |
f33beee9 | 3162 | parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen, 0, |
fad0afd7 | 3163 | loop.from, loop.to, 1, |
10174ddf | 3164 | GFC_ARRAY_UNKNOWN, true); |
6de9cd9a DN |
3165 | |
3166 | /* Allocate temporary for nested forall construct. */ | |
3167 | tmp1 = allocate_temp_for_forall_nest (nested_forall_info, parmtype, | |
8de1f441 | 3168 | inner_size, NULL, block, &ptemp1); |
6de9cd9a DN |
3169 | gfc_start_block (&body); |
3170 | gfc_init_se (&lse, NULL); | |
1d6b7f39 | 3171 | lse.expr = gfc_build_array_ref (tmp1, count, NULL); |
6de9cd9a DN |
3172 | lse.direct_byref = 1; |
3173 | rss = gfc_walk_expr (expr2); | |
3174 | gfc_conv_expr_descriptor (&lse, expr2, rss); | |
3175 | ||
3176 | gfc_add_block_to_block (&body, &lse.pre); | |
3177 | gfc_add_block_to_block (&body, &lse.post); | |
3178 | ||
3179 | /* Increment count. */ | |
bc98ed60 TB |
3180 | tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, |
3181 | count, gfc_index_one_node); | |
726a989a | 3182 | gfc_add_modify (&body, count, tmp); |
6de9cd9a DN |
3183 | |
3184 | tmp = gfc_finish_block (&body); | |
3185 | ||
1f2959f0 | 3186 | /* Generate body and loops according to the information in |
6de9cd9a | 3187 | nested_forall_info. */ |
bfcabc6c | 3188 | tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1); |
6de9cd9a DN |
3189 | gfc_add_expr_to_block (block, tmp); |
3190 | ||
3191 | /* Reset count. */ | |
726a989a | 3192 | gfc_add_modify (block, count, gfc_index_zero_node); |
6de9cd9a | 3193 | |
1d6b7f39 | 3194 | parm = gfc_build_array_ref (tmp1, count, NULL); |
6de9cd9a DN |
3195 | lss = gfc_walk_expr (expr1); |
3196 | gfc_init_se (&lse, NULL); | |
3197 | gfc_conv_expr_descriptor (&lse, expr1, lss); | |
726a989a | 3198 | gfc_add_modify (&lse.pre, lse.expr, parm); |
6de9cd9a DN |
3199 | gfc_start_block (&body); |
3200 | gfc_add_block_to_block (&body, &lse.pre); | |
3201 | gfc_add_block_to_block (&body, &lse.post); | |
3202 | ||
3203 | /* Increment count. */ | |
bc98ed60 TB |
3204 | tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, |
3205 | count, gfc_index_one_node); | |
726a989a | 3206 | gfc_add_modify (&body, count, tmp); |
6de9cd9a DN |
3207 | |
3208 | tmp = gfc_finish_block (&body); | |
3209 | ||
bfcabc6c | 3210 | tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1); |
6de9cd9a DN |
3211 | gfc_add_expr_to_block (block, tmp); |
3212 | } | |
3213 | /* Free the temporary. */ | |
3214 | if (ptemp1) | |
3215 | { | |
1529b8d9 | 3216 | tmp = gfc_call_free (ptemp1); |
6de9cd9a DN |
3217 | gfc_add_expr_to_block (block, tmp); |
3218 | } | |
3219 | } | |
3220 | ||
3221 | ||
3222 | /* FORALL and WHERE statements are really nasty, especially when you nest | |
3223 | them. All the rhs of a forall assignment must be evaluated before the | |
3224 | actual assignments are performed. Presumably this also applies to all the | |
3225 | assignments in an inner where statement. */ | |
3226 | ||
3227 | /* Generate code for a FORALL statement. Any temporaries are allocated as a | |
3228 | linear array, relying on the fact that we process in the same order in all | |
3229 | loops. | |
3230 | ||
3231 | forall (i=start:end:stride; maskexpr) | |
3232 | e<i> = f<i> | |
3233 | g<i> = h<i> | |
3234 | end forall | |
e7dc5b4f | 3235 | (where e,f,g,h<i> are arbitrary expressions possibly involving i) |
6de9cd9a | 3236 | Translates to: |
8de1f441 | 3237 | count = ((end + 1 - start) / stride) |
6de9cd9a DN |
3238 | masktmp(:) = maskexpr(:) |
3239 | ||
3240 | maskindex = 0; | |
3241 | for (i = start; i <= end; i += stride) | |
3242 | { | |
3243 | if (masktmp[maskindex++]) | |
3244 | e<i> = f<i> | |
3245 | } | |
3246 | maskindex = 0; | |
3247 | for (i = start; i <= end; i += stride) | |
3248 | { | |
3249 | if (masktmp[maskindex++]) | |
cafa34aa | 3250 | g<i> = h<i> |
6de9cd9a DN |
3251 | } |
3252 | ||
3253 | Note that this code only works when there are no dependencies. | |
3254 | Forall loop with array assignments and data dependencies are a real pain, | |
3255 | because the size of the temporary cannot always be determined before the | |
1f2959f0 | 3256 | loop is executed. This problem is compounded by the presence of nested |
6de9cd9a DN |
3257 | FORALL constructs. |
3258 | */ | |
3259 | ||
3260 | static tree | |
3261 | gfc_trans_forall_1 (gfc_code * code, forall_info * nested_forall_info) | |
3262 | { | |
640670c7 PT |
3263 | stmtblock_t pre; |
3264 | stmtblock_t post; | |
6de9cd9a DN |
3265 | stmtblock_t block; |
3266 | stmtblock_t body; | |
3267 | tree *var; | |
3268 | tree *start; | |
3269 | tree *end; | |
3270 | tree *step; | |
3271 | gfc_expr **varexpr; | |
3272 | tree tmp; | |
3273 | tree assign; | |
3274 | tree size; | |
6de9cd9a DN |
3275 | tree maskindex; |
3276 | tree mask; | |
3277 | tree pmask; | |
3278 | int n; | |
3279 | int nvar; | |
3280 | int need_temp; | |
3281 | gfc_forall_iterator *fa; | |
3282 | gfc_se se; | |
3283 | gfc_code *c; | |
7b5b57b7 | 3284 | gfc_saved_var *saved_vars; |
bfcabc6c RS |
3285 | iter_info *this_forall; |
3286 | forall_info *info; | |
e35a0e64 RS |
3287 | bool need_mask; |
3288 | ||
3289 | /* Do nothing if the mask is false. */ | |
a513927a SK |
3290 | if (code->expr1 |
3291 | && code->expr1->expr_type == EXPR_CONSTANT | |
3292 | && !code->expr1->value.logical) | |
c2255bc4 | 3293 | return build_empty_stmt (input_location); |
6de9cd9a DN |
3294 | |
3295 | n = 0; | |
3296 | /* Count the FORALL index number. */ | |
3297 | for (fa = code->ext.forall_iterator; fa; fa = fa->next) | |
3298 | n++; | |
3299 | nvar = n; | |
3300 | ||
3301 | /* Allocate the space for var, start, end, step, varexpr. */ | |
3302 | var = (tree *) gfc_getmem (nvar * sizeof (tree)); | |
3303 | start = (tree *) gfc_getmem (nvar * sizeof (tree)); | |
3304 | end = (tree *) gfc_getmem (nvar * sizeof (tree)); | |
3305 | step = (tree *) gfc_getmem (nvar * sizeof (tree)); | |
3306 | varexpr = (gfc_expr **) gfc_getmem (nvar * sizeof (gfc_expr *)); | |
7b5b57b7 | 3307 | saved_vars = (gfc_saved_var *) gfc_getmem (nvar * sizeof (gfc_saved_var)); |
6de9cd9a DN |
3308 | |
3309 | /* Allocate the space for info. */ | |
3310 | info = (forall_info *) gfc_getmem (sizeof (forall_info)); | |
bfcabc6c | 3311 | |
640670c7 PT |
3312 | gfc_start_block (&pre); |
3313 | gfc_init_block (&post); | |
3314 | gfc_init_block (&block); | |
bfcabc6c | 3315 | |
6de9cd9a DN |
3316 | n = 0; |
3317 | for (fa = code->ext.forall_iterator; fa; fa = fa->next) | |
3318 | { | |
3319 | gfc_symbol *sym = fa->var->symtree->n.sym; | |
3320 | ||
bfcabc6c | 3321 | /* Allocate space for this_forall. */ |
6de9cd9a DN |
3322 | this_forall = (iter_info *) gfc_getmem (sizeof (iter_info)); |
3323 | ||
6de9cd9a DN |
3324 | /* Create a temporary variable for the FORALL index. */ |
3325 | tmp = gfc_typenode_for_spec (&sym->ts); | |
3326 | var[n] = gfc_create_var (tmp, sym->name); | |
7b5b57b7 PB |
3327 | gfc_shadow_sym (sym, var[n], &saved_vars[n]); |
3328 | ||
6de9cd9a DN |
3329 | /* Record it in this_forall. */ |
3330 | this_forall->var = var[n]; | |
3331 | ||
3332 | /* Replace the index symbol's backend_decl with the temporary decl. */ | |
3333 | sym->backend_decl = var[n]; | |
3334 | ||
3335 | /* Work out the start, end and stride for the loop. */ | |
3336 | gfc_init_se (&se, NULL); | |
3337 | gfc_conv_expr_val (&se, fa->start); | |
3338 | /* Record it in this_forall. */ | |
3339 | this_forall->start = se.expr; | |
3340 | gfc_add_block_to_block (&block, &se.pre); | |
3341 | start[n] = se.expr; | |
3342 | ||
3343 | gfc_init_se (&se, NULL); | |
3344 | gfc_conv_expr_val (&se, fa->end); | |
3345 | /* Record it in this_forall. */ | |
3346 | this_forall->end = se.expr; | |
3347 | gfc_make_safe_expr (&se); | |
3348 | gfc_add_block_to_block (&block, &se.pre); | |
3349 | end[n] = se.expr; | |
3350 | ||
3351 | gfc_init_se (&se, NULL); | |
3352 | gfc_conv_expr_val (&se, fa->stride); | |
3353 | /* Record it in this_forall. */ | |
3354 | this_forall->step = se.expr; | |
3355 | gfc_make_safe_expr (&se); | |
3356 | gfc_add_block_to_block (&block, &se.pre); | |
3357 | step[n] = se.expr; | |
3358 | ||
3359 | /* Set the NEXT field of this_forall to NULL. */ | |
3360 | this_forall->next = NULL; | |
3361 | /* Link this_forall to the info construct. */ | |
bfcabc6c | 3362 | if (info->this_loop) |
6de9cd9a | 3363 | { |
bfcabc6c | 3364 | iter_info *iter_tmp = info->this_loop; |
6de9cd9a DN |
3365 | while (iter_tmp->next != NULL) |
3366 | iter_tmp = iter_tmp->next; | |
3367 | iter_tmp->next = this_forall; | |
3368 | } | |
bfcabc6c RS |
3369 | else |
3370 | info->this_loop = this_forall; | |
6de9cd9a DN |
3371 | |
3372 | n++; | |
3373 | } | |
3374 | nvar = n; | |
3375 | ||
bfcabc6c | 3376 | /* Calculate the size needed for the current forall level. */ |
7ab92584 | 3377 | size = gfc_index_one_node; |
6de9cd9a DN |
3378 | for (n = 0; n < nvar; n++) |
3379 | { | |
6de9cd9a | 3380 | /* size = (end + step - start) / step. */ |
bc98ed60 TB |
3381 | tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (start[n]), |
3382 | step[n], start[n]); | |
3383 | tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (end[n]), | |
3384 | end[n], tmp); | |
3385 | tmp = fold_build2_loc (input_location, FLOOR_DIV_EXPR, TREE_TYPE (tmp), | |
3386 | tmp, step[n]); | |
6de9cd9a DN |
3387 | tmp = convert (gfc_array_index_type, tmp); |
3388 | ||
bc98ed60 TB |
3389 | size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, |
3390 | size, tmp); | |
6de9cd9a DN |
3391 | } |
3392 | ||
3393 | /* Record the nvar and size of current forall level. */ | |
3394 | info->nvar = nvar; | |
3395 | info->size = size; | |
3396 | ||
a513927a | 3397 | if (code->expr1) |
e35a0e64 RS |
3398 | { |
3399 | /* If the mask is .true., consider the FORALL unconditional. */ | |
a513927a SK |
3400 | if (code->expr1->expr_type == EXPR_CONSTANT |
3401 | && code->expr1->value.logical) | |
e35a0e64 RS |
3402 | need_mask = false; |
3403 | else | |
3404 | need_mask = true; | |
3405 | } | |
3406 | else | |
3407 | need_mask = false; | |
3408 | ||
3409 | /* First we need to allocate the mask. */ | |
3410 | if (need_mask) | |
bfcabc6c RS |
3411 | { |
3412 | /* As the mask array can be very big, prefer compact boolean types. */ | |
3413 | tree mask_type = gfc_get_logical_type (gfc_logical_kinds[0].kind); | |
3414 | mask = allocate_temp_for_forall_nest (nested_forall_info, mask_type, | |
3415 | size, NULL, &block, &pmask); | |
3416 | maskindex = gfc_create_var_np (gfc_array_index_type, "mi"); | |
3417 | ||
3418 | /* Record them in the info structure. */ | |
3419 | info->maskindex = maskindex; | |
3420 | info->mask = mask; | |
3421 | } | |
6de9cd9a DN |
3422 | else |
3423 | { | |
bfcabc6c RS |
3424 | /* No mask was specified. */ |
3425 | maskindex = NULL_TREE; | |
3426 | mask = pmask = NULL_TREE; | |
3427 | } | |
3428 | ||
3429 | /* Link the current forall level to nested_forall_info. */ | |
e8d366ec RS |
3430 | info->prev_nest = nested_forall_info; |
3431 | nested_forall_info = info; | |
6de9cd9a DN |
3432 | |
3433 | /* Copy the mask into a temporary variable if required. | |
f7b529fa | 3434 | For now we assume a mask temporary is needed. */ |
e35a0e64 | 3435 | if (need_mask) |
6de9cd9a | 3436 | { |
bfcabc6c RS |
3437 | /* As the mask array can be very big, prefer compact boolean types. */ |
3438 | tree mask_type = gfc_get_logical_type (gfc_logical_kinds[0].kind); | |
6de9cd9a | 3439 | |
726a989a | 3440 | gfc_add_modify (&block, maskindex, gfc_index_zero_node); |
6de9cd9a DN |
3441 | |
3442 | /* Start of mask assignment loop body. */ | |
3443 | gfc_start_block (&body); | |
3444 | ||
3445 | /* Evaluate the mask expression. */ | |
3446 | gfc_init_se (&se, NULL); | |
a513927a | 3447 | gfc_conv_expr_val (&se, code->expr1); |
6de9cd9a DN |
3448 | gfc_add_block_to_block (&body, &se.pre); |
3449 | ||
3450 | /* Store the mask. */ | |
bfcabc6c | 3451 | se.expr = convert (mask_type, se.expr); |
6de9cd9a | 3452 | |
1d6b7f39 | 3453 | tmp = gfc_build_array_ref (mask, maskindex, NULL); |
726a989a | 3454 | gfc_add_modify (&body, tmp, se.expr); |
6de9cd9a DN |
3455 | |
3456 | /* Advance to the next mask element. */ | |
bc98ed60 TB |
3457 | tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, |
3458 | maskindex, gfc_index_one_node); | |
726a989a | 3459 | gfc_add_modify (&body, maskindex, tmp); |
6de9cd9a DN |
3460 | |
3461 | /* Generate the loops. */ | |
3462 | tmp = gfc_finish_block (&body); | |
bfcabc6c | 3463 | tmp = gfc_trans_nested_forall_loop (info, tmp, 0); |
6de9cd9a DN |
3464 | gfc_add_expr_to_block (&block, tmp); |
3465 | } | |
6de9cd9a DN |
3466 | |
3467 | c = code->block->next; | |
3468 | ||
3469 | /* TODO: loop merging in FORALL statements. */ | |
3470 | /* Now that we've got a copy of the mask, generate the assignment loops. */ | |
3471 | while (c) | |
3472 | { | |
3473 | switch (c->op) | |
3474 | { | |
3475 | case EXEC_ASSIGN: | |
640670c7 PT |
3476 | /* A scalar or array assignment. DO the simple check for |
3477 | lhs to rhs dependencies. These make a temporary for the | |
3478 | rhs and form a second forall block to copy to variable. */ | |
3479 | need_temp = check_forall_dependencies(c, &pre, &post); | |
3480 | ||
69de3b83 | 3481 | /* Temporaries due to array assignment data dependencies introduce |
6de9cd9a DN |
3482 | no end of problems. */ |
3483 | if (need_temp) | |
a513927a | 3484 | gfc_trans_assign_need_temp (c->expr1, c->expr2, NULL, false, |
6de9cd9a DN |
3485 | nested_forall_info, &block); |
3486 | else | |
3487 | { | |
3488 | /* Use the normal assignment copying routines. */ | |
2b56d6a4 | 3489 | assign = gfc_trans_assignment (c->expr1, c->expr2, false, true); |
6de9cd9a | 3490 | |
6de9cd9a | 3491 | /* Generate body and loops. */ |
bfcabc6c RS |
3492 | tmp = gfc_trans_nested_forall_loop (nested_forall_info, |
3493 | assign, 1); | |
6de9cd9a DN |
3494 | gfc_add_expr_to_block (&block, tmp); |
3495 | } | |
3496 | ||
640670c7 PT |
3497 | /* Cleanup any temporary symtrees that have been made to deal |
3498 | with dependencies. */ | |
3499 | if (new_symtree) | |
3500 | cleanup_forall_symtrees (c); | |
3501 | ||
6de9cd9a DN |
3502 | break; |
3503 | ||
3504 | case EXEC_WHERE: | |
6de9cd9a | 3505 | /* Translate WHERE or WHERE construct nested in FORALL. */ |
011daa76 | 3506 | gfc_trans_where_2 (c, NULL, false, nested_forall_info, &block); |
3891cee2 | 3507 | break; |
6de9cd9a DN |
3508 | |
3509 | /* Pointer assignment inside FORALL. */ | |
3510 | case EXEC_POINTER_ASSIGN: | |
a513927a | 3511 | need_temp = gfc_check_dependency (c->expr1, c->expr2, 0); |
6de9cd9a | 3512 | if (need_temp) |
a513927a | 3513 | gfc_trans_pointer_assign_need_temp (c->expr1, c->expr2, |
6de9cd9a DN |
3514 | nested_forall_info, &block); |
3515 | else | |
3516 | { | |
3517 | /* Use the normal assignment copying routines. */ | |
a513927a | 3518 | assign = gfc_trans_pointer_assignment (c->expr1, c->expr2); |
6de9cd9a | 3519 | |
6de9cd9a | 3520 | /* Generate body and loops. */ |
bfcabc6c RS |
3521 | tmp = gfc_trans_nested_forall_loop (nested_forall_info, |
3522 | assign, 1); | |
6de9cd9a DN |
3523 | gfc_add_expr_to_block (&block, tmp); |
3524 | } | |
3525 | break; | |
3526 | ||
3527 | case EXEC_FORALL: | |
3528 | tmp = gfc_trans_forall_1 (c, nested_forall_info); | |
3529 | gfc_add_expr_to_block (&block, tmp); | |
3530 | break; | |
3531 | ||
48474141 PT |
3532 | /* Explicit subroutine calls are prevented by the frontend but interface |
3533 | assignments can legitimately produce them. */ | |
476220e7 | 3534 | case EXEC_ASSIGN_CALL: |
eb74e79b | 3535 | assign = gfc_trans_call (c, true, NULL_TREE, NULL_TREE, false); |
bfcabc6c | 3536 | tmp = gfc_trans_nested_forall_loop (nested_forall_info, assign, 1); |
48474141 PT |
3537 | gfc_add_expr_to_block (&block, tmp); |
3538 | break; | |
3539 | ||
6de9cd9a | 3540 | default: |
6e45f57b | 3541 | gcc_unreachable (); |
6de9cd9a DN |
3542 | } |
3543 | ||
3544 | c = c->next; | |
3545 | } | |
3546 | ||
7b5b57b7 PB |
3547 | /* Restore the original index variables. */ |
3548 | for (fa = code->ext.forall_iterator, n = 0; fa; fa = fa->next, n++) | |
3549 | gfc_restore_sym (fa->var->symtree->n.sym, &saved_vars[n]); | |
6de9cd9a DN |
3550 | |
3551 | /* Free the space for var, start, end, step, varexpr. */ | |
3552 | gfc_free (var); | |
3553 | gfc_free (start); | |
3554 | gfc_free (end); | |
3555 | gfc_free (step); | |
3556 | gfc_free (varexpr); | |
7b5b57b7 | 3557 | gfc_free (saved_vars); |
6de9cd9a | 3558 | |
3231fe90 MM |
3559 | for (this_forall = info->this_loop; this_forall;) |
3560 | { | |
3561 | iter_info *next = this_forall->next; | |
3562 | gfc_free (this_forall); | |
3563 | this_forall = next; | |
3564 | } | |
3565 | ||
e8d366ec RS |
3566 | /* Free the space for this forall_info. */ |
3567 | gfc_free (info); | |
3568 | ||
6de9cd9a DN |
3569 | if (pmask) |
3570 | { | |
3571 | /* Free the temporary for the mask. */ | |
1529b8d9 | 3572 | tmp = gfc_call_free (pmask); |
6de9cd9a DN |
3573 | gfc_add_expr_to_block (&block, tmp); |
3574 | } | |
3575 | if (maskindex) | |
3576 | pushdecl (maskindex); | |
3577 | ||
640670c7 PT |
3578 | gfc_add_block_to_block (&pre, &block); |
3579 | gfc_add_block_to_block (&pre, &post); | |
3580 | ||
3581 | return gfc_finish_block (&pre); | |
6de9cd9a DN |
3582 | } |
3583 | ||
3584 | ||
3585 | /* Translate the FORALL statement or construct. */ | |
3586 | ||
3587 | tree gfc_trans_forall (gfc_code * code) | |
3588 | { | |
3589 | return gfc_trans_forall_1 (code, NULL); | |
3590 | } | |
3591 | ||
3592 | ||
3593 | /* Evaluate the WHERE mask expression, copy its value to a temporary. | |
3594 | If the WHERE construct is nested in FORALL, compute the overall temporary | |
3595 | needed by the WHERE mask expression multiplied by the iterator number of | |
3596 | the nested forall. | |
3597 | ME is the WHERE mask expression. | |
011daa76 RS |
3598 | MASK is the current execution mask upon input, whose sense may or may |
3599 | not be inverted as specified by the INVERT argument. | |
3891cee2 RS |
3600 | CMASK is the updated execution mask on output, or NULL if not required. |
3601 | PMASK is the pending execution mask on output, or NULL if not required. | |
3602 | BLOCK is the block in which to place the condition evaluation loops. */ | |
6de9cd9a | 3603 | |
3891cee2 | 3604 | static void |
6de9cd9a | 3605 | gfc_evaluate_where_mask (gfc_expr * me, forall_info * nested_forall_info, |
011daa76 | 3606 | tree mask, bool invert, tree cmask, tree pmask, |
3891cee2 | 3607 | tree mask_type, stmtblock_t * block) |
6de9cd9a DN |
3608 | { |
3609 | tree tmp, tmp1; | |
3610 | gfc_ss *lss, *rss; | |
3611 | gfc_loopinfo loop; | |
3891cee2 RS |
3612 | stmtblock_t body, body1; |
3613 | tree count, cond, mtmp; | |
6de9cd9a | 3614 | gfc_se lse, rse; |
6de9cd9a DN |
3615 | |
3616 | gfc_init_loopinfo (&loop); | |
3617 | ||
3891cee2 RS |
3618 | lss = gfc_walk_expr (me); |
3619 | rss = gfc_walk_expr (me); | |
6de9cd9a DN |
3620 | |
3621 | /* Variable to index the temporary. */ | |
3622 | count = gfc_create_var (gfc_array_index_type, "count"); | |
1f2959f0 | 3623 | /* Initialize count. */ |
726a989a | 3624 | gfc_add_modify (block, count, gfc_index_zero_node); |
6de9cd9a DN |
3625 | |
3626 | gfc_start_block (&body); | |
3627 | ||
3628 | gfc_init_se (&rse, NULL); | |
3629 | gfc_init_se (&lse, NULL); | |
3630 | ||
3631 | if (lss == gfc_ss_terminator) | |
3632 | { | |
3633 | gfc_init_block (&body1); | |
3634 | } | |
3635 | else | |
3636 | { | |
1f2959f0 | 3637 | /* Initialize the loop. */ |
6de9cd9a DN |
3638 | gfc_init_loopinfo (&loop); |
3639 | ||
3640 | /* We may need LSS to determine the shape of the expression. */ | |
3641 | gfc_add_ss_to_loop (&loop, lss); | |
3642 | gfc_add_ss_to_loop (&loop, rss); | |
3643 | ||
3644 | gfc_conv_ss_startstride (&loop); | |
bdfd2ff0 | 3645 | gfc_conv_loop_setup (&loop, &me->where); |
6de9cd9a DN |
3646 | |
3647 | gfc_mark_ss_chain_used (rss, 1); | |
3648 | /* Start the loop body. */ | |
3649 | gfc_start_scalarized_body (&loop, &body1); | |
3650 | ||
3651 | /* Translate the expression. */ | |
3652 | gfc_copy_loopinfo_to_se (&rse, &loop); | |
3653 | rse.ss = rss; | |
3654 | gfc_conv_expr (&rse, me); | |
3655 | } | |
6de9cd9a | 3656 | |
b82feea5 | 3657 | /* Variable to evaluate mask condition. */ |
3891cee2 RS |
3658 | cond = gfc_create_var (mask_type, "cond"); |
3659 | if (mask && (cmask || pmask)) | |
3660 | mtmp = gfc_create_var (mask_type, "mask"); | |
3661 | else mtmp = NULL_TREE; | |
3662 | ||
3663 | gfc_add_block_to_block (&body1, &lse.pre); | |
3664 | gfc_add_block_to_block (&body1, &rse.pre); | |
6de9cd9a | 3665 | |
726a989a | 3666 | gfc_add_modify (&body1, cond, fold_convert (mask_type, rse.expr)); |
3891cee2 RS |
3667 | |
3668 | if (mask && (cmask || pmask)) | |
42e73749 | 3669 | { |
1d6b7f39 | 3670 | tmp = gfc_build_array_ref (mask, count, NULL); |
011daa76 | 3671 | if (invert) |
bc98ed60 | 3672 | tmp = fold_build1_loc (input_location, TRUTH_NOT_EXPR, mask_type, tmp); |
726a989a | 3673 | gfc_add_modify (&body1, mtmp, tmp); |
42e73749 | 3674 | } |
6de9cd9a | 3675 | |
3891cee2 RS |
3676 | if (cmask) |
3677 | { | |
1d6b7f39 | 3678 | tmp1 = gfc_build_array_ref (cmask, count, NULL); |
3891cee2 RS |
3679 | tmp = cond; |
3680 | if (mask) | |
bc98ed60 TB |
3681 | tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR, mask_type, |
3682 | mtmp, tmp); | |
726a989a | 3683 | gfc_add_modify (&body1, tmp1, tmp); |
3891cee2 RS |
3684 | } |
3685 | ||
3686 | if (pmask) | |
3687 | { | |
1d6b7f39 | 3688 | tmp1 = gfc_build_array_ref (pmask, count, NULL); |
bc98ed60 | 3689 | tmp = fold_build1_loc (input_location, TRUTH_NOT_EXPR, mask_type, cond); |
3891cee2 | 3690 | if (mask) |
bc98ed60 TB |
3691 | tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR, mask_type, mtmp, |
3692 | tmp); | |
726a989a | 3693 | gfc_add_modify (&body1, tmp1, tmp); |
3891cee2 RS |
3694 | } |
3695 | ||
3696 | gfc_add_block_to_block (&body1, &lse.post); | |
3697 | gfc_add_block_to_block (&body1, &rse.post); | |
3698 | ||
3699 | if (lss == gfc_ss_terminator) | |
6de9cd9a DN |
3700 | { |
3701 | gfc_add_block_to_block (&body, &body1); | |
3702 | } | |
3703 | else | |
3704 | { | |
3705 | /* Increment count. */ | |
bc98ed60 TB |
3706 | tmp1 = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, |
3707 | count, gfc_index_one_node); | |
726a989a | 3708 | gfc_add_modify (&body1, count, tmp1); |
6de9cd9a DN |
3709 | |
3710 | /* Generate the copying loops. */ | |
3711 | gfc_trans_scalarizing_loops (&loop, &body1); | |
3712 | ||
3713 | gfc_add_block_to_block (&body, &loop.pre); | |
3714 | gfc_add_block_to_block (&body, &loop.post); | |
3715 | ||
3716 | gfc_cleanup_loop (&loop); | |
3717 | /* TODO: Reuse lss and rss when copying temp->lhs. Need to be careful | |
3718 | as tree nodes in SS may not be valid in different scope. */ | |
3719 | } | |
3720 | ||
3721 | tmp1 = gfc_finish_block (&body); | |
3722 | /* If the WHERE construct is inside FORALL, fill the full temporary. */ | |
3723 | if (nested_forall_info != NULL) | |
bfcabc6c | 3724 | tmp1 = gfc_trans_nested_forall_loop (nested_forall_info, tmp1, 1); |
6de9cd9a DN |
3725 | |
3726 | gfc_add_expr_to_block (block, tmp1); | |
6de9cd9a DN |
3727 | } |
3728 | ||
3729 | ||
3730 | /* Translate an assignment statement in a WHERE statement or construct | |
3731 | statement. The MASK expression is used to control which elements | |
011daa76 RS |
3732 | of EXPR1 shall be assigned. The sense of MASK is specified by |
3733 | INVERT. */ | |
6de9cd9a DN |
3734 | |
3735 | static tree | |
011daa76 RS |
3736 | gfc_trans_where_assign (gfc_expr *expr1, gfc_expr *expr2, |
3737 | tree mask, bool invert, | |
a00b8d1a | 3738 | tree count1, tree count2, |
eb74e79b | 3739 | gfc_code *cnext) |
6de9cd9a DN |
3740 | { |
3741 | gfc_se lse; | |
3742 | gfc_se rse; | |
3743 | gfc_ss *lss; | |
3744 | gfc_ss *lss_section; | |
3745 | gfc_ss *rss; | |
3746 | ||
3747 | gfc_loopinfo loop; | |
3748 | tree tmp; | |
3749 | stmtblock_t block; | |
3750 | stmtblock_t body; | |
3c90c9ae | 3751 | tree index, maskexpr; |
6de9cd9a | 3752 | |
eb74e79b PT |
3753 | /* A defined assignment. */ |
3754 | if (cnext && cnext->resolved_sym) | |
3755 | return gfc_trans_call (cnext, true, mask, count1, invert); | |
3756 | ||
6de9cd9a DN |
3757 | #if 0 |
3758 | /* TODO: handle this special case. | |
3759 | Special case a single function returning an array. */ | |
3760 | if (expr2->expr_type == EXPR_FUNCTION && expr2->rank > 0) | |
3761 | { | |
3762 | tmp = gfc_trans_arrayfunc_assign (expr1, expr2); | |
3763 | if (tmp) | |
3764 | return tmp; | |
3765 | } | |
3766 | #endif | |
3767 | ||
3768 | /* Assignment of the form lhs = rhs. */ | |
3769 | gfc_start_block (&block); | |
3770 | ||
3771 | gfc_init_se (&lse, NULL); | |
3772 | gfc_init_se (&rse, NULL); | |
3773 | ||
3774 | /* Walk the lhs. */ | |
3775 | lss = gfc_walk_expr (expr1); | |
3776 | rss = NULL; | |
3777 | ||
3778 | /* In each where-assign-stmt, the mask-expr and the variable being | |
3779 | defined shall be arrays of the same shape. */ | |
6e45f57b | 3780 | gcc_assert (lss != gfc_ss_terminator); |
6de9cd9a DN |
3781 | |
3782 | /* The assignment needs scalarization. */ | |
3783 | lss_section = lss; | |
3784 | ||
3785 | /* Find a non-scalar SS from the lhs. */ | |
3786 | while (lss_section != gfc_ss_terminator | |
3787 | && lss_section->type != GFC_SS_SECTION) | |
3788 | lss_section = lss_section->next; | |
3789 | ||
6e45f57b | 3790 | gcc_assert (lss_section != gfc_ss_terminator); |
6de9cd9a DN |
3791 | |
3792 | /* Initialize the scalarizer. */ | |
3793 | gfc_init_loopinfo (&loop); | |
3794 | ||
3795 | /* Walk the rhs. */ | |
3796 | rss = gfc_walk_expr (expr2); | |
3797 | if (rss == gfc_ss_terminator) | |
3798 | { | |
3799 | /* The rhs is scalar. Add a ss for the expression. */ | |
3800 | rss = gfc_get_ss (); | |
ae772c2d | 3801 | rss->where = 1; |
6de9cd9a DN |
3802 | rss->next = gfc_ss_terminator; |
3803 | rss->type = GFC_SS_SCALAR; | |
3804 | rss->expr = expr2; | |
3805 | } | |
3806 | ||
3807 | /* Associate the SS with the loop. */ | |
3808 | gfc_add_ss_to_loop (&loop, lss); | |
3809 | gfc_add_ss_to_loop (&loop, rss); | |
3810 | ||
3811 | /* Calculate the bounds of the scalarization. */ | |
3812 | gfc_conv_ss_startstride (&loop); | |
3813 | ||
3814 | /* Resolve any data dependencies in the statement. */ | |
3815 | gfc_conv_resolve_dependencies (&loop, lss_section, rss); | |
3816 | ||
3817 | /* Setup the scalarizing loops. */ | |
bdfd2ff0 | 3818 | gfc_conv_loop_setup (&loop, &expr2->where); |
6de9cd9a DN |
3819 | |
3820 | /* Setup the gfc_se structures. */ | |
3821 | gfc_copy_loopinfo_to_se (&lse, &loop); | |
3822 | gfc_copy_loopinfo_to_se (&rse, &loop); | |
3823 | ||
3824 | rse.ss = rss; | |
3825 | gfc_mark_ss_chain_used (rss, 1); | |
3826 | if (loop.temp_ss == NULL) | |
3827 | { | |
3828 | lse.ss = lss; | |
3829 | gfc_mark_ss_chain_used (lss, 1); | |
3830 | } | |
3831 | else | |
3832 | { | |
3833 | lse.ss = loop.temp_ss; | |
3834 | gfc_mark_ss_chain_used (lss, 3); | |
3835 | gfc_mark_ss_chain_used (loop.temp_ss, 3); | |
3836 | } | |
3837 | ||
3838 | /* Start the scalarized loop body. */ | |
3839 | gfc_start_scalarized_body (&loop, &body); | |
3840 | ||
3841 | /* Translate the expression. */ | |
3842 | gfc_conv_expr (&rse, expr2); | |
3843 | if (lss != gfc_ss_terminator && loop.temp_ss != NULL) | |
3db5d687 | 3844 | gfc_conv_tmp_array_ref (&lse); |
6de9cd9a DN |
3845 | else |
3846 | gfc_conv_expr (&lse, expr1); | |
3847 | ||
3c90c9ae | 3848 | /* Form the mask expression according to the mask. */ |
6de9cd9a | 3849 | index = count1; |
1d6b7f39 | 3850 | maskexpr = gfc_build_array_ref (mask, index, NULL); |
011daa76 | 3851 | if (invert) |
bc98ed60 TB |
3852 | maskexpr = fold_build1_loc (input_location, TRUTH_NOT_EXPR, |
3853 | TREE_TYPE (maskexpr), maskexpr); | |
6de9cd9a | 3854 | |
6de9cd9a | 3855 | /* Use the scalar assignment as is. */ |
eb74e79b | 3856 | tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts, |
2b56d6a4 | 3857 | loop.temp_ss != NULL, false, true); |
a00b8d1a | 3858 | |
c2255bc4 | 3859 | tmp = build3_v (COND_EXPR, maskexpr, tmp, build_empty_stmt (input_location)); |
6de9cd9a DN |
3860 | |
3861 | gfc_add_expr_to_block (&body, tmp); | |
3862 | ||
3863 | if (lss == gfc_ss_terminator) | |
3864 | { | |
3865 | /* Increment count1. */ | |
bc98ed60 TB |
3866 | tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, |
3867 | count1, gfc_index_one_node); | |
726a989a | 3868 | gfc_add_modify (&body, count1, tmp); |
6de9cd9a DN |
3869 | |
3870 | /* Use the scalar assignment as is. */ | |
3871 | gfc_add_block_to_block (&block, &body); | |
3872 | } | |
3873 | else | |
3874 | { | |
6e45f57b PB |
3875 | gcc_assert (lse.ss == gfc_ss_terminator |
3876 | && rse.ss == gfc_ss_terminator); | |
6de9cd9a DN |
3877 | |
3878 | if (loop.temp_ss != NULL) | |
3879 | { | |
3880 | /* Increment count1 before finish the main body of a scalarized | |
3881 | expression. */ | |
bc98ed60 TB |
3882 | tmp = fold_build2_loc (input_location, PLUS_EXPR, |
3883 | gfc_array_index_type, count1, gfc_index_one_node); | |
726a989a | 3884 | gfc_add_modify (&body, count1, tmp); |
6de9cd9a DN |
3885 | gfc_trans_scalarized_loop_boundary (&loop, &body); |
3886 | ||
3887 | /* We need to copy the temporary to the actual lhs. */ | |
3888 | gfc_init_se (&lse, NULL); | |
3889 | gfc_init_se (&rse, NULL); | |
3890 | gfc_copy_loopinfo_to_se (&lse, &loop); | |
3891 | gfc_copy_loopinfo_to_se (&rse, &loop); | |
3892 | ||
3893 | rse.ss = loop.temp_ss; | |
3894 | lse.ss = lss; | |
3895 | ||
3896 | gfc_conv_tmp_array_ref (&rse); | |
6de9cd9a DN |
3897 | gfc_conv_expr (&lse, expr1); |
3898 | ||
6e45f57b PB |
3899 | gcc_assert (lse.ss == gfc_ss_terminator |
3900 | && rse.ss == gfc_ss_terminator); | |
6de9cd9a DN |
3901 | |
3902 | /* Form the mask expression according to the mask tree list. */ | |
3903 | index = count2; | |
1d6b7f39 | 3904 | maskexpr = gfc_build_array_ref (mask, index, NULL); |
011daa76 | 3905 | if (invert) |
bc98ed60 TB |
3906 | maskexpr = fold_build1_loc (input_location, TRUTH_NOT_EXPR, |
3907 | TREE_TYPE (maskexpr), maskexpr); | |
6de9cd9a | 3908 | |
6de9cd9a | 3909 | /* Use the scalar assignment as is. */ |
2b56d6a4 TB |
3910 | tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts, false, false, |
3911 | true); | |
c2255bc4 AH |
3912 | tmp = build3_v (COND_EXPR, maskexpr, tmp, |
3913 | build_empty_stmt (input_location)); | |
6de9cd9a | 3914 | gfc_add_expr_to_block (&body, tmp); |
7ab92584 | 3915 | |
6de9cd9a | 3916 | /* Increment count2. */ |
bc98ed60 TB |
3917 | tmp = fold_build2_loc (input_location, PLUS_EXPR, |
3918 | gfc_array_index_type, count2, | |
3919 | gfc_index_one_node); | |
726a989a | 3920 | gfc_add_modify (&body, count2, tmp); |
6de9cd9a DN |
3921 | } |
3922 | else | |
3923 | { | |
3924 | /* Increment count1. */ | |
bc98ed60 TB |
3925 | tmp = fold_build2_loc (input_location, PLUS_EXPR, |
3926 | gfc_array_index_type, count1, | |
3927 | gfc_index_one_node); | |
726a989a | 3928 | gfc_add_modify (&body, count1, tmp); |
6de9cd9a DN |
3929 | } |
3930 | ||
3931 | /* Generate the copying loops. */ | |
3932 | gfc_trans_scalarizing_loops (&loop, &body); | |
3933 | ||
3934 | /* Wrap the whole thing up. */ | |
3935 | gfc_add_block_to_block (&block, &loop.pre); | |
3936 | gfc_add_block_to_block (&block, &loop.post); | |
3937 | gfc_cleanup_loop (&loop); | |
3938 | } | |
3939 | ||
3940 | return gfc_finish_block (&block); | |
3941 | } | |
3942 | ||
3943 | ||
3944 | /* Translate the WHERE construct or statement. | |
aa9c57ec | 3945 | This function can be called iteratively to translate the nested WHERE |
6de9cd9a | 3946 | construct or statement. |
3891cee2 | 3947 | MASK is the control mask. */ |
6de9cd9a DN |
3948 | |
3949 | static void | |
011daa76 | 3950 | gfc_trans_where_2 (gfc_code * code, tree mask, bool invert, |
3891cee2 | 3951 | forall_info * nested_forall_info, stmtblock_t * block) |
6de9cd9a | 3952 | { |
3891cee2 RS |
3953 | stmtblock_t inner_size_body; |
3954 | tree inner_size, size; | |
3955 | gfc_ss *lss, *rss; | |
3956 | tree mask_type; | |
6de9cd9a DN |
3957 | gfc_expr *expr1; |
3958 | gfc_expr *expr2; | |
3959 | gfc_code *cblock; | |
3960 | gfc_code *cnext; | |
3891cee2 | 3961 | tree tmp; |
ae772c2d | 3962 | tree cond; |
6de9cd9a | 3963 | tree count1, count2; |
011daa76 RS |
3964 | bool need_cmask; |
3965 | bool need_pmask; | |
6de9cd9a | 3966 | int need_temp; |
3891cee2 RS |
3967 | tree pcmask = NULL_TREE; |
3968 | tree ppmask = NULL_TREE; | |
3969 | tree cmask = NULL_TREE; | |
3970 | tree pmask = NULL_TREE; | |
a00b8d1a | 3971 | gfc_actual_arglist *arg; |
6de9cd9a DN |
3972 | |
3973 | /* the WHERE statement or the WHERE construct statement. */ | |
3974 | cblock = code->block; | |
3891cee2 | 3975 | |
3891cee2 RS |
3976 | /* As the mask array can be very big, prefer compact boolean types. */ |
3977 | mask_type = gfc_get_logical_type (gfc_logical_kinds[0].kind); | |
3978 | ||
011daa76 RS |
3979 | /* Determine which temporary masks are needed. */ |
3980 | if (!cblock->block) | |
90f58ec8 | 3981 | { |
011daa76 RS |
3982 | /* One clause: No ELSEWHEREs. */ |
3983 | need_cmask = (cblock->next != 0); | |
3984 | need_pmask = false; | |
90f58ec8 | 3985 | } |
011daa76 | 3986 | else if (cblock->block->block) |
90f58ec8 | 3987 | { |
011daa76 RS |
3988 | /* Three or more clauses: Conditional ELSEWHEREs. */ |
3989 | need_cmask = true; | |
3990 | need_pmask = true; | |
90f58ec8 | 3991 | } |
011daa76 RS |
3992 | else if (cblock->next) |
3993 | { | |
3994 | /* Two clauses, the first non-empty. */ | |
3995 | need_cmask = true; | |
3996 | need_pmask = (mask != NULL_TREE | |
3997 | && cblock->block->next != 0); | |
3998 | } | |
3999 | else if (!cblock->block->next) | |
3891cee2 | 4000 | { |
011daa76 RS |
4001 | /* Two clauses, both empty. */ |
4002 | need_cmask = false; | |
4003 | need_pmask = false; | |
4004 | } | |
4005 | /* Two clauses, the first empty, the second non-empty. */ | |
4006 | else if (mask) | |
4007 | { | |
a513927a | 4008 | need_cmask = (cblock->block->expr1 != 0); |
011daa76 | 4009 | need_pmask = true; |
3891cee2 RS |
4010 | } |
4011 | else | |
4012 | { | |
011daa76 RS |
4013 | need_cmask = true; |
4014 | need_pmask = false; | |
4015 | } | |
4016 | ||
4017 | if (need_cmask || need_pmask) | |
4018 | { | |
4019 | /* Calculate the size of temporary needed by the mask-expr. */ | |
4020 | gfc_init_block (&inner_size_body); | |
a513927a | 4021 | inner_size = compute_inner_temp_size (cblock->expr1, cblock->expr1, |
011daa76 RS |
4022 | &inner_size_body, &lss, &rss); |
4023 | ||
fcba5509 MM |
4024 | gfc_free_ss_chain (lss); |
4025 | gfc_free_ss_chain (rss); | |
4026 | ||
011daa76 RS |
4027 | /* Calculate the total size of temporary needed. */ |
4028 | size = compute_overall_iter_number (nested_forall_info, inner_size, | |
4029 | &inner_size_body, block); | |
4030 | ||
ae772c2d | 4031 | /* Check whether the size is negative. */ |
bc98ed60 TB |
4032 | cond = fold_build2_loc (input_location, LE_EXPR, boolean_type_node, size, |
4033 | gfc_index_zero_node); | |
4034 | size = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type, | |
4035 | cond, gfc_index_zero_node, size); | |
ae772c2d PT |
4036 | size = gfc_evaluate_now (size, block); |
4037 | ||
011daa76 RS |
4038 | /* Allocate temporary for WHERE mask if needed. */ |
4039 | if (need_cmask) | |
4040 | cmask = allocate_temp_for_forall_nest_1 (mask_type, size, block, | |
4041 | &pcmask); | |
4042 | ||
4043 | /* Allocate temporary for !mask if needed. */ | |
4044 | if (need_pmask) | |
4045 | pmask = allocate_temp_for_forall_nest_1 (mask_type, size, block, | |
4046 | &ppmask); | |
3891cee2 RS |
4047 | } |
4048 | ||
6de9cd9a DN |
4049 | while (cblock) |
4050 | { | |
011daa76 RS |
4051 | /* Each time around this loop, the where clause is conditional |
4052 | on the value of mask and invert, which are updated at the | |
4053 | bottom of the loop. */ | |
4054 | ||
6de9cd9a | 4055 | /* Has mask-expr. */ |
a513927a | 4056 | if (cblock->expr1) |
6de9cd9a | 4057 | { |
90f58ec8 RS |
4058 | /* Ensure that the WHERE mask will be evaluated exactly once. |
4059 | If there are no statements in this WHERE/ELSEWHERE clause, | |
4060 | then we don't need to update the control mask (cmask). | |
4061 | If this is the last clause of the WHERE construct, then | |
3891cee2 | 4062 | we don't need to update the pending control mask (pmask). */ |
011daa76 | 4063 | if (mask) |
a513927a | 4064 | gfc_evaluate_where_mask (cblock->expr1, nested_forall_info, |
011daa76 RS |
4065 | mask, invert, |
4066 | cblock->next ? cmask : NULL_TREE, | |
4067 | cblock->block ? pmask : NULL_TREE, | |
4068 | mask_type, block); | |
4069 | else | |
a513927a | 4070 | gfc_evaluate_where_mask (cblock->expr1, nested_forall_info, |
011daa76 RS |
4071 | NULL_TREE, false, |
4072 | (cblock->next || cblock->block) | |
4073 | ? cmask : NULL_TREE, | |
4074 | NULL_TREE, mask_type, block); | |
6de9cd9a | 4075 | |
011daa76 | 4076 | invert = false; |
6de9cd9a | 4077 | } |
90f58ec8 | 4078 | /* It's a final elsewhere-stmt. No mask-expr is present. */ |
6de9cd9a | 4079 | else |
3891cee2 | 4080 | cmask = mask; |
6de9cd9a | 4081 | |
011daa76 RS |
4082 | /* The body of this where clause are controlled by cmask with |
4083 | sense specified by invert. */ | |
4084 | ||
6de9cd9a DN |
4085 | /* Get the assignment statement of a WHERE statement, or the first |
4086 | statement in where-body-construct of a WHERE construct. */ | |
4087 | cnext = cblock->next; | |
4088 | while (cnext) | |
4089 | { | |
4090 | switch (cnext->op) | |
4091 | { | |
4092 | /* WHERE assignment statement. */ | |
a00b8d1a PT |
4093 | case EXEC_ASSIGN_CALL: |
4094 | ||
4095 | arg = cnext->ext.actual; | |
4096 | expr1 = expr2 = NULL; | |
4097 | for (; arg; arg = arg->next) | |
4098 | { | |
4099 | if (!arg->expr) | |
4100 | continue; | |
4101 | if (expr1 == NULL) | |
4102 | expr1 = arg->expr; | |
4103 | else | |
4104 | expr2 = arg->expr; | |
4105 | } | |
4106 | goto evaluate; | |
4107 | ||
6de9cd9a | 4108 | case EXEC_ASSIGN: |
a513927a | 4109 | expr1 = cnext->expr1; |
6de9cd9a | 4110 | expr2 = cnext->expr2; |
a00b8d1a | 4111 | evaluate: |
6de9cd9a DN |
4112 | if (nested_forall_info != NULL) |
4113 | { | |
3ded6210 | 4114 | need_temp = gfc_check_dependency (expr1, expr2, 0); |
a00b8d1a | 4115 | if (need_temp && cnext->op != EXEC_ASSIGN_CALL) |
011daa76 RS |
4116 | gfc_trans_assign_need_temp (expr1, expr2, |
4117 | cmask, invert, | |
6de9cd9a DN |
4118 | nested_forall_info, block); |
4119 | else | |
4120 | { | |
4121 | /* Variables to control maskexpr. */ | |
4122 | count1 = gfc_create_var (gfc_array_index_type, "count1"); | |
4123 | count2 = gfc_create_var (gfc_array_index_type, "count2"); | |
726a989a RB |
4124 | gfc_add_modify (block, count1, gfc_index_zero_node); |
4125 | gfc_add_modify (block, count2, gfc_index_zero_node); | |
6de9cd9a | 4126 | |
011daa76 RS |
4127 | tmp = gfc_trans_where_assign (expr1, expr2, |
4128 | cmask, invert, | |
a00b8d1a | 4129 | count1, count2, |
eb74e79b | 4130 | cnext); |
8de1f441 | 4131 | |
6de9cd9a | 4132 | tmp = gfc_trans_nested_forall_loop (nested_forall_info, |
bfcabc6c | 4133 | tmp, 1); |
6de9cd9a DN |
4134 | gfc_add_expr_to_block (block, tmp); |
4135 | } | |
4136 | } | |
4137 | else | |
4138 | { | |
4139 | /* Variables to control maskexpr. */ | |
4140 | count1 = gfc_create_var (gfc_array_index_type, "count1"); | |
4141 | count2 = gfc_create_var (gfc_array_index_type, "count2"); | |
726a989a RB |
4142 | gfc_add_modify (block, count1, gfc_index_zero_node); |
4143 | gfc_add_modify (block, count2, gfc_index_zero_node); | |
6de9cd9a | 4144 | |
011daa76 RS |
4145 | tmp = gfc_trans_where_assign (expr1, expr2, |
4146 | cmask, invert, | |
a00b8d1a | 4147 | count1, count2, |
eb74e79b | 4148 | cnext); |
6de9cd9a DN |
4149 | gfc_add_expr_to_block (block, tmp); |
4150 | ||
4151 | } | |
4152 | break; | |
4153 | ||
4154 | /* WHERE or WHERE construct is part of a where-body-construct. */ | |
4155 | case EXEC_WHERE: | |
011daa76 RS |
4156 | gfc_trans_where_2 (cnext, cmask, invert, |
4157 | nested_forall_info, block); | |
3891cee2 | 4158 | break; |
6de9cd9a DN |
4159 | |
4160 | default: | |
6e45f57b | 4161 | gcc_unreachable (); |
6de9cd9a DN |
4162 | } |
4163 | ||
4164 | /* The next statement within the same where-body-construct. */ | |
4165 | cnext = cnext->next; | |
4166 | } | |
4167 | /* The next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt. */ | |
4168 | cblock = cblock->block; | |
011daa76 RS |
4169 | if (mask == NULL_TREE) |
4170 | { | |
4171 | /* If we're the initial WHERE, we can simply invert the sense | |
4172 | of the current mask to obtain the "mask" for the remaining | |
4173 | ELSEWHEREs. */ | |
4174 | invert = true; | |
4175 | mask = cmask; | |
4176 | } | |
4177 | else | |
4178 | { | |
4179 | /* Otherwise, for nested WHERE's we need to use the pending mask. */ | |
4180 | invert = false; | |
4181 | mask = pmask; | |
4182 | } | |
6de9cd9a | 4183 | } |
3891cee2 RS |
4184 | |
4185 | /* If we allocated a pending mask array, deallocate it now. */ | |
4186 | if (ppmask) | |
4187 | { | |
1529b8d9 | 4188 | tmp = gfc_call_free (ppmask); |
3891cee2 RS |
4189 | gfc_add_expr_to_block (block, tmp); |
4190 | } | |
4191 | ||
4192 | /* If we allocated a current mask array, deallocate it now. */ | |
4193 | if (pcmask) | |
4194 | { | |
1529b8d9 | 4195 | tmp = gfc_call_free (pcmask); |
3891cee2 RS |
4196 | gfc_add_expr_to_block (block, tmp); |
4197 | } | |
6de9cd9a DN |
4198 | } |
4199 | ||
3ded6210 RS |
4200 | /* Translate a simple WHERE construct or statement without dependencies. |
4201 | CBLOCK is the "then" clause of the WHERE statement, where CBLOCK->EXPR | |
4202 | is the mask condition, and EBLOCK if non-NULL is the "else" clause. | |
4203 | Currently both CBLOCK and EBLOCK are restricted to single assignments. */ | |
4204 | ||
4205 | static tree | |
4206 | gfc_trans_where_3 (gfc_code * cblock, gfc_code * eblock) | |
4207 | { | |
4208 | stmtblock_t block, body; | |
4209 | gfc_expr *cond, *tdst, *tsrc, *edst, *esrc; | |
4210 | tree tmp, cexpr, tstmt, estmt; | |
4211 | gfc_ss *css, *tdss, *tsss; | |
4212 | gfc_se cse, tdse, tsse, edse, esse; | |
4213 | gfc_loopinfo loop; | |
4214 | gfc_ss *edss = 0; | |
4215 | gfc_ss *esss = 0; | |
4216 | ||
34d01e1d VL |
4217 | /* Allow the scalarizer to workshare simple where loops. */ |
4218 | if (ompws_flags & OMPWS_WORKSHARE_FLAG) | |
4219 | ompws_flags |= OMPWS_SCALARIZER_WS; | |
4220 | ||
a513927a SK |
4221 | cond = cblock->expr1; |
4222 | tdst = cblock->next->expr1; | |
3ded6210 | 4223 | tsrc = cblock->next->expr2; |
a513927a | 4224 | edst = eblock ? eblock->next->expr1 : NULL; |
3ded6210 RS |
4225 | esrc = eblock ? eblock->next->expr2 : NULL; |
4226 | ||
4227 | gfc_start_block (&block); | |
4228 | gfc_init_loopinfo (&loop); | |
4229 | ||
4230 | /* Handle the condition. */ | |
4231 | gfc_init_se (&cse, NULL); | |
4232 | css = gfc_walk_expr (cond); | |
4233 | gfc_add_ss_to_loop (&loop, css); | |
4234 | ||
4235 | /* Handle the then-clause. */ | |
4236 | gfc_init_se (&tdse, NULL); | |
4237 | gfc_init_se (&tsse, NULL); | |
4238 | tdss = gfc_walk_expr (tdst); | |
4239 | tsss = gfc_walk_expr (tsrc); | |
4240 | if (tsss == gfc_ss_terminator) | |
4241 | { | |
4242 | tsss = gfc_get_ss (); | |
ae772c2d | 4243 | tsss->where = 1; |
3ded6210 RS |
4244 | tsss->next = gfc_ss_terminator; |
4245 | tsss->type = GFC_SS_SCALAR; | |
4246 | tsss->expr = tsrc; | |
4247 | } | |
4248 | gfc_add_ss_to_loop (&loop, tdss); | |
4249 | gfc_add_ss_to_loop (&loop, tsss); | |
4250 | ||
4251 | if (eblock) | |
4252 | { | |
4253 | /* Handle the else clause. */ | |
4254 | gfc_init_se (&edse, NULL); | |
4255 | gfc_init_se (&esse, NULL); | |
4256 | edss = gfc_walk_expr (edst); | |
4257 | esss = gfc_walk_expr (esrc); | |
4258 | if (esss == gfc_ss_terminator) | |
4259 | { | |
4260 | esss = gfc_get_ss (); | |
ae772c2d | 4261 | esss->where = 1; |
3ded6210 RS |
4262 | esss->next = gfc_ss_terminator; |
4263 | esss->type = GFC_SS_SCALAR; | |
4264 | esss->expr = esrc; | |
4265 | } | |
4266 | gfc_add_ss_to_loop (&loop, edss); | |
4267 | gfc_add_ss_to_loop (&loop, esss); | |
4268 | } | |
4269 | ||
4270 | gfc_conv_ss_startstride (&loop); | |
bdfd2ff0 | 4271 | gfc_conv_loop_setup (&loop, &tdst->where); |
3ded6210 RS |
4272 | |
4273 | gfc_mark_ss_chain_used (css, 1); | |
4274 | gfc_mark_ss_chain_used (tdss, 1); | |
4275 | gfc_mark_ss_chain_used (tsss, 1); | |
4276 | if (eblock) | |
4277 | { | |
4278 | gfc_mark_ss_chain_used (edss, 1); | |
4279 | gfc_mark_ss_chain_used (esss, 1); | |
4280 | } | |
4281 | ||
4282 | gfc_start_scalarized_body (&loop, &body); | |
4283 | ||
4284 | gfc_copy_loopinfo_to_se (&cse, &loop); | |
4285 | gfc_copy_loopinfo_to_se (&tdse, &loop); | |
4286 | gfc_copy_loopinfo_to_se (&tsse, &loop); | |
4287 | cse.ss = css; | |
4288 | tdse.ss = tdss; | |
4289 | tsse.ss = tsss; | |
4290 | if (eblock) | |
4291 | { | |
4292 | gfc_copy_loopinfo_to_se (&edse, &loop); | |
4293 | gfc_copy_loopinfo_to_se (&esse, &loop); | |
4294 | edse.ss = edss; | |
4295 | esse.ss = esss; | |
4296 | } | |
4297 | ||
4298 | gfc_conv_expr (&cse, cond); | |
4299 | gfc_add_block_to_block (&body, &cse.pre); | |
4300 | cexpr = cse.expr; | |
4301 | ||
4302 | gfc_conv_expr (&tsse, tsrc); | |
4303 | if (tdss != gfc_ss_terminator && loop.temp_ss != NULL) | |
3db5d687 | 4304 | gfc_conv_tmp_array_ref (&tdse); |
3ded6210 RS |
4305 | else |
4306 | gfc_conv_expr (&tdse, tdst); | |
4307 | ||
4308 | if (eblock) | |
4309 | { | |
4310 | gfc_conv_expr (&esse, esrc); | |
4311 | if (edss != gfc_ss_terminator && loop.temp_ss != NULL) | |
3db5d687 | 4312 | gfc_conv_tmp_array_ref (&edse); |
3ded6210 | 4313 | else |
3db5d687 | 4314 | gfc_conv_expr (&edse, edst); |
3ded6210 RS |
4315 | } |
4316 | ||
2b56d6a4 TB |
4317 | tstmt = gfc_trans_scalar_assign (&tdse, &tsse, tdst->ts, false, false, true); |
4318 | estmt = eblock ? gfc_trans_scalar_assign (&edse, &esse, edst->ts, false, | |
4319 | false, true) | |
c2255bc4 | 4320 | : build_empty_stmt (input_location); |
3ded6210 RS |
4321 | tmp = build3_v (COND_EXPR, cexpr, tstmt, estmt); |
4322 | gfc_add_expr_to_block (&body, tmp); | |
4323 | gfc_add_block_to_block (&body, &cse.post); | |
4324 | ||
4325 | gfc_trans_scalarizing_loops (&loop, &body); | |
4326 | gfc_add_block_to_block (&block, &loop.pre); | |
4327 | gfc_add_block_to_block (&block, &loop.post); | |
4328 | gfc_cleanup_loop (&loop); | |
4329 | ||
4330 | return gfc_finish_block (&block); | |
4331 | } | |
6de9cd9a DN |
4332 | |
4333 | /* As the WHERE or WHERE construct statement can be nested, we call | |
4334 | gfc_trans_where_2 to do the translation, and pass the initial | |
f7b529fa | 4335 | NULL values for both the control mask and the pending control mask. */ |
6de9cd9a DN |
4336 | |
4337 | tree | |
4338 | gfc_trans_where (gfc_code * code) | |
4339 | { | |
4340 | stmtblock_t block; | |
3ded6210 RS |
4341 | gfc_code *cblock; |
4342 | gfc_code *eblock; | |
6de9cd9a | 4343 | |
3ded6210 RS |
4344 | cblock = code->block; |
4345 | if (cblock->next | |
4346 | && cblock->next->op == EXEC_ASSIGN | |
4347 | && !cblock->next->next) | |
4348 | { | |
4349 | eblock = cblock->block; | |
4350 | if (!eblock) | |
4351 | { | |
4352 | /* A simple "WHERE (cond) x = y" statement or block is | |
4353 | dependence free if cond is not dependent upon writing x, | |
4354 | and the source y is unaffected by the destination x. */ | |
a513927a SK |
4355 | if (!gfc_check_dependency (cblock->next->expr1, |
4356 | cblock->expr1, 0) | |
4357 | && !gfc_check_dependency (cblock->next->expr1, | |
3ded6210 RS |
4358 | cblock->next->expr2, 0)) |
4359 | return gfc_trans_where_3 (cblock, NULL); | |
4360 | } | |
a513927a | 4361 | else if (!eblock->expr1 |
3ded6210 RS |
4362 | && !eblock->block |
4363 | && eblock->next | |
4364 | && eblock->next->op == EXEC_ASSIGN | |
4365 | && !eblock->next->next) | |
4366 | { | |
4367 | /* A simple "WHERE (cond) x1 = y1 ELSEWHERE x2 = y2 ENDWHERE" | |
4368 | block is dependence free if cond is not dependent on writes | |
4369 | to x1 and x2, y1 is not dependent on writes to x2, and y2 | |
4370 | is not dependent on writes to x1, and both y's are not | |
ae772c2d PT |
4371 | dependent upon their own x's. In addition to this, the |
4372 | final two dependency checks below exclude all but the same | |
4373 | array reference if the where and elswhere destinations | |
4374 | are the same. In short, this is VERY conservative and this | |
4375 | is needed because the two loops, required by the standard | |
4376 | are coalesced in gfc_trans_where_3. */ | |
a513927a SK |
4377 | if (!gfc_check_dependency(cblock->next->expr1, |
4378 | cblock->expr1, 0) | |
4379 | && !gfc_check_dependency(eblock->next->expr1, | |
4380 | cblock->expr1, 0) | |
4381 | && !gfc_check_dependency(cblock->next->expr1, | |
ae772c2d | 4382 | eblock->next->expr2, 1) |
a513927a | 4383 | && !gfc_check_dependency(eblock->next->expr1, |
ae772c2d | 4384 | cblock->next->expr2, 1) |
a513927a | 4385 | && !gfc_check_dependency(cblock->next->expr1, |
ae772c2d | 4386 | cblock->next->expr2, 1) |
a513927a | 4387 | && !gfc_check_dependency(eblock->next->expr1, |
ae772c2d | 4388 | eblock->next->expr2, 1) |
a513927a SK |
4389 | && !gfc_check_dependency(cblock->next->expr1, |
4390 | eblock->next->expr1, 0) | |
4391 | && !gfc_check_dependency(eblock->next->expr1, | |
4392 | cblock->next->expr1, 0)) | |
3ded6210 RS |
4393 | return gfc_trans_where_3 (cblock, eblock); |
4394 | } | |
4395 | } | |
4396 | ||
6de9cd9a | 4397 | gfc_start_block (&block); |
6de9cd9a | 4398 | |
011daa76 | 4399 | gfc_trans_where_2 (code, NULL, false, NULL, &block); |
6de9cd9a | 4400 | |
6de9cd9a DN |
4401 | return gfc_finish_block (&block); |
4402 | } | |
4403 | ||
4404 | ||
4405 | /* CYCLE a DO loop. The label decl has already been created by | |
4406 | gfc_trans_do(), it's in TREE_PURPOSE (backend_decl) of the gfc_code | |
4407 | node at the head of the loop. We must mark the label as used. */ | |
4408 | ||
4409 | tree | |
4410 | gfc_trans_cycle (gfc_code * code) | |
4411 | { | |
4412 | tree cycle_label; | |
4413 | ||
e5ca9693 DK |
4414 | cycle_label = code->ext.which_construct->cycle_label; |
4415 | gcc_assert (cycle_label); | |
4416 | ||
6de9cd9a DN |
4417 | TREE_USED (cycle_label) = 1; |
4418 | return build1_v (GOTO_EXPR, cycle_label); | |
4419 | } | |
4420 | ||
4421 | ||
e7dc5b4f | 4422 | /* EXIT a DO loop. Similar to CYCLE, but now the label is in |
6de9cd9a DN |
4423 | TREE_VALUE (backend_decl) of the gfc_code node at the head of the |
4424 | loop. */ | |
4425 | ||
4426 | tree | |
4427 | gfc_trans_exit (gfc_code * code) | |
4428 | { | |
4429 | tree exit_label; | |
4430 | ||
e5ca9693 DK |
4431 | exit_label = code->ext.which_construct->exit_label; |
4432 | gcc_assert (exit_label); | |
4433 | ||
6de9cd9a DN |
4434 | TREE_USED (exit_label) = 1; |
4435 | return build1_v (GOTO_EXPR, exit_label); | |
4436 | } | |
4437 | ||
4438 | ||
4439 | /* Translate the ALLOCATE statement. */ | |
4440 | ||
4441 | tree | |
4442 | gfc_trans_allocate (gfc_code * code) | |
4443 | { | |
4444 | gfc_alloc *al; | |
7adac79a | 4445 | gfc_expr *expr; |
6de9cd9a DN |
4446 | gfc_se se; |
4447 | tree tmp; | |
4448 | tree parm; | |
6de9cd9a DN |
4449 | tree stat; |
4450 | tree pstat; | |
4451 | tree error_label; | |
60f5ed26 | 4452 | tree memsz; |
6de9cd9a DN |
4453 | stmtblock_t block; |
4454 | ||
cf2b3c22 | 4455 | if (!code->ext.alloc.list) |
6de9cd9a DN |
4456 | return NULL_TREE; |
4457 | ||
60f5ed26 | 4458 | pstat = stat = error_label = tmp = memsz = NULL_TREE; |
3759634f | 4459 | |
6de9cd9a DN |
4460 | gfc_start_block (&block); |
4461 | ||
3759634f | 4462 | /* Either STAT= and/or ERRMSG is present. */ |
a513927a | 4463 | if (code->expr1 || code->expr2) |
6de9cd9a | 4464 | { |
e2cad04b RH |
4465 | tree gfc_int4_type_node = gfc_get_int_type (4); |
4466 | ||
6de9cd9a | 4467 | stat = gfc_create_var (gfc_int4_type_node, "stat"); |
628c189e | 4468 | pstat = gfc_build_addr_expr (NULL_TREE, stat); |
6de9cd9a DN |
4469 | |
4470 | error_label = gfc_build_label_decl (NULL_TREE); | |
4471 | TREE_USED (error_label) = 1; | |
4472 | } | |
6de9cd9a | 4473 | |
cf2b3c22 | 4474 | for (al = code->ext.alloc.list; al != NULL; al = al->next) |
6de9cd9a | 4475 | { |
f43085aa JW |
4476 | expr = gfc_copy_expr (al->expr); |
4477 | ||
4478 | if (expr->ts.type == BT_CLASS) | |
b04533af | 4479 | gfc_add_data_component (expr); |
6de9cd9a DN |
4480 | |
4481 | gfc_init_se (&se, NULL); | |
4482 | gfc_start_block (&se.pre); | |
4483 | ||
4484 | se.want_pointer = 1; | |
4485 | se.descriptor_only = 1; | |
4486 | gfc_conv_expr (&se, expr); | |
4487 | ||
5b725b8d | 4488 | if (!gfc_array_allocate (&se, expr, pstat)) |
6de9cd9a DN |
4489 | { |
4490 | /* A scalar or derived type. */ | |
cf2b3c22 TB |
4491 | |
4492 | /* Determine allocate size. */ | |
94bff632 | 4493 | if (al->expr->ts.type == BT_CLASS && code->expr3) |
cf2b3c22 | 4494 | { |
94bff632 JW |
4495 | if (code->expr3->ts.type == BT_CLASS) |
4496 | { | |
4497 | gfc_expr *sz; | |
4498 | gfc_se se_sz; | |
4499 | sz = gfc_copy_expr (code->expr3); | |
b04533af JW |
4500 | gfc_add_vptr_component (sz); |
4501 | gfc_add_size_component (sz); | |
94bff632 JW |
4502 | gfc_init_se (&se_sz, NULL); |
4503 | gfc_conv_expr (&se_sz, sz); | |
4504 | gfc_free_expr (sz); | |
4505 | memsz = se_sz.expr; | |
4506 | } | |
4507 | else | |
4508 | memsz = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&code->expr3->ts)); | |
cf2b3c22 | 4509 | } |
cf2b3c22 | 4510 | else if (code->ext.alloc.ts.type != BT_UNKNOWN) |
60f5ed26 | 4511 | memsz = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&code->ext.alloc.ts)); |
cf2b3c22 | 4512 | else |
60f5ed26 | 4513 | memsz = TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (se.expr))); |
c4bbc105 | 4514 | |
60f5ed26 JW |
4515 | if (expr->ts.type == BT_CHARACTER && memsz == NULL_TREE) |
4516 | memsz = se.string_length; | |
c4bbc105 | 4517 | |
5b130807 TB |
4518 | /* Allocate - for non-pointers with re-alloc checking. */ |
4519 | { | |
4520 | gfc_ref *ref; | |
4521 | bool allocatable; | |
4522 | ||
4523 | ref = expr->ref; | |
4524 | ||
4525 | /* Find the last reference in the chain. */ | |
4526 | while (ref && ref->next != NULL) | |
4527 | { | |
4528 | gcc_assert (ref->type != REF_ARRAY || ref->u.ar.type == AR_ELEMENT); | |
4529 | ref = ref->next; | |
4530 | } | |
4531 | ||
4532 | if (!ref) | |
4533 | allocatable = expr->symtree->n.sym->attr.allocatable; | |
4534 | else | |
4535 | allocatable = ref->u.c.component->attr.allocatable; | |
4536 | ||
4537 | if (allocatable) | |
4538 | tmp = gfc_allocate_array_with_status (&se.pre, se.expr, memsz, | |
4539 | pstat, expr); | |
4540 | else | |
4541 | tmp = gfc_allocate_with_status (&se.pre, memsz, pstat); | |
4542 | } | |
4543 | ||
bc98ed60 TB |
4544 | tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, |
4545 | se.expr, | |
4546 | fold_convert (TREE_TYPE (se.expr), tmp)); | |
6de9cd9a DN |
4547 | gfc_add_expr_to_block (&se.pre, tmp); |
4548 | ||
a513927a | 4549 | if (code->expr1 || code->expr2) |
6de9cd9a DN |
4550 | { |
4551 | tmp = build1_v (GOTO_EXPR, error_label); | |
bc98ed60 TB |
4552 | parm = fold_build2_loc (input_location, NE_EXPR, |
4553 | boolean_type_node, stat, | |
4554 | build_int_cst (TREE_TYPE (stat), 0)); | |
4555 | tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, | |
4556 | parm, tmp, | |
4557 | build_empty_stmt (input_location)); | |
6de9cd9a DN |
4558 | gfc_add_expr_to_block (&se.pre, tmp); |
4559 | } | |
5046aff5 | 4560 | |
bc21d315 | 4561 | if (expr->ts.type == BT_DERIVED && expr->ts.u.derived->attr.alloc_comp) |
5046aff5 | 4562 | { |
db3927fb | 4563 | tmp = build_fold_indirect_ref_loc (input_location, se.expr); |
bc21d315 | 4564 | tmp = gfc_nullify_alloc_comp (expr->ts.u.derived, tmp, 0); |
5046aff5 PT |
4565 | gfc_add_expr_to_block (&se.pre, tmp); |
4566 | } | |
4567 | ||
6de9cd9a DN |
4568 | } |
4569 | ||
4570 | tmp = gfc_finish_block (&se.pre); | |
4571 | gfc_add_expr_to_block (&block, tmp); | |
cf2b3c22 | 4572 | |
94bff632 | 4573 | if (code->expr3 && !code->expr3->mold) |
cf2b3c22 | 4574 | { |
b6ff8128 JW |
4575 | /* Initialization via SOURCE block |
4576 | (or static default initializer). */ | |
f43085aa | 4577 | gfc_expr *rhs = gfc_copy_expr (code->expr3); |
611c64f0 | 4578 | if (al->expr->ts.type == BT_CLASS) |
f43085aa | 4579 | { |
611c64f0 JW |
4580 | gfc_se call; |
4581 | gfc_actual_arglist *actual; | |
4582 | gfc_expr *ppc; | |
4583 | gfc_init_se (&call, NULL); | |
4584 | /* Do a polymorphic deep copy. */ | |
4585 | actual = gfc_get_actual_arglist (); | |
4586 | actual->expr = gfc_copy_expr (rhs); | |
60f5ed26 | 4587 | if (rhs->ts.type == BT_CLASS) |
b04533af | 4588 | gfc_add_data_component (actual->expr); |
611c64f0 JW |
4589 | actual->next = gfc_get_actual_arglist (); |
4590 | actual->next->expr = gfc_copy_expr (al->expr); | |
b04533af | 4591 | gfc_add_data_component (actual->next->expr); |
611c64f0 JW |
4592 | if (rhs->ts.type == BT_CLASS) |
4593 | { | |
4594 | ppc = gfc_copy_expr (rhs); | |
b04533af | 4595 | gfc_add_vptr_component (ppc); |
611c64f0 JW |
4596 | } |
4597 | else | |
4598 | ppc = gfc_lval_expr_from_sym (gfc_find_derived_vtab (rhs->ts.u.derived)); | |
b04533af | 4599 | gfc_add_component_ref (ppc, "_copy"); |
611c64f0 JW |
4600 | gfc_conv_procedure_call (&call, ppc->symtree->n.sym, actual, |
4601 | ppc, NULL); | |
4602 | gfc_add_expr_to_block (&call.pre, call.expr); | |
4603 | gfc_add_block_to_block (&call.pre, &call.post); | |
4604 | tmp = gfc_finish_block (&call.pre); | |
f43085aa JW |
4605 | } |
4606 | else | |
4607 | tmp = gfc_trans_assignment (gfc_expr_to_initialize (expr), | |
2b56d6a4 | 4608 | rhs, false, false); |
f43085aa JW |
4609 | gfc_free_expr (rhs); |
4610 | gfc_add_expr_to_block (&block, tmp); | |
4611 | } | |
b6ff8128 JW |
4612 | else if (code->expr3 && code->expr3->mold |
4613 | && code->expr3->ts.type == BT_CLASS) | |
50f30801 | 4614 | { |
b6ff8128 JW |
4615 | /* Default-initialization via MOLD (polymorphic). */ |
4616 | gfc_expr *rhs = gfc_copy_expr (code->expr3); | |
4617 | gfc_se dst,src; | |
b04533af JW |
4618 | gfc_add_vptr_component (rhs); |
4619 | gfc_add_def_init_component (rhs); | |
b6ff8128 JW |
4620 | gfc_init_se (&dst, NULL); |
4621 | gfc_init_se (&src, NULL); | |
4622 | gfc_conv_expr (&dst, expr); | |
4623 | gfc_conv_expr (&src, rhs); | |
4624 | gfc_add_block_to_block (&block, &src.pre); | |
4625 | tmp = gfc_build_memcpy_call (dst.expr, src.expr, memsz); | |
4626 | gfc_add_expr_to_block (&block, tmp); | |
4627 | gfc_free_expr (rhs); | |
50f30801 | 4628 | } |
f43085aa JW |
4629 | |
4630 | /* Allocation of CLASS entities. */ | |
4631 | gfc_free_expr (expr); | |
4632 | expr = al->expr; | |
4633 | if (expr->ts.type == BT_CLASS) | |
cf2b3c22 | 4634 | { |
f43085aa | 4635 | gfc_expr *lhs,*rhs; |
60f5ed26 | 4636 | gfc_se lse; |
7c1dab0d JW |
4637 | |
4638 | /* Initialize VPTR for CLASS objects. */ | |
f43085aa | 4639 | lhs = gfc_expr_to_initialize (expr); |
b04533af | 4640 | gfc_add_vptr_component (lhs); |
7c1dab0d | 4641 | rhs = NULL; |
f43085aa JW |
4642 | if (code->expr3 && code->expr3->ts.type == BT_CLASS) |
4643 | { | |
94bff632 | 4644 | /* Polymorphic SOURCE: VPTR must be determined at run time. */ |
f43085aa | 4645 | rhs = gfc_copy_expr (code->expr3); |
b04533af | 4646 | gfc_add_vptr_component (rhs); |
7c1dab0d JW |
4647 | tmp = gfc_trans_pointer_assignment (lhs, rhs); |
4648 | gfc_add_expr_to_block (&block, tmp); | |
4649 | gfc_free_expr (rhs); | |
f43085aa JW |
4650 | } |
4651 | else | |
4652 | { | |
7c1dab0d JW |
4653 | /* VPTR is fixed at compile time. */ |
4654 | gfc_symbol *vtab; | |
4655 | gfc_typespec *ts; | |
f43085aa | 4656 | if (code->expr3) |
7c1dab0d JW |
4657 | ts = &code->expr3->ts; |
4658 | else if (expr->ts.type == BT_DERIVED) | |
4659 | ts = &expr->ts; | |
f43085aa | 4660 | else if (code->ext.alloc.ts.type == BT_DERIVED) |
7c1dab0d | 4661 | ts = &code->ext.alloc.ts; |
f43085aa | 4662 | else if (expr->ts.type == BT_CLASS) |
7a08eda1 | 4663 | ts = &CLASS_DATA (expr)->ts; |
f43085aa | 4664 | else |
7c1dab0d | 4665 | ts = &expr->ts; |
f43085aa | 4666 | |
7c1dab0d JW |
4667 | if (ts->type == BT_DERIVED) |
4668 | { | |
88ce8031 | 4669 | vtab = gfc_find_derived_vtab (ts->u.derived); |
7c1dab0d JW |
4670 | gcc_assert (vtab); |
4671 | gfc_init_se (&lse, NULL); | |
4672 | lse.want_pointer = 1; | |
4673 | gfc_conv_expr (&lse, lhs); | |
4674 | tmp = gfc_build_addr_expr (NULL_TREE, | |
4675 | gfc_get_symbol_decl (vtab)); | |
4676 | gfc_add_modify (&block, lse.expr, | |
4677 | fold_convert (TREE_TYPE (lse.expr), tmp)); | |
4678 | } | |
4679 | } | |
c956e9af | 4680 | gfc_free_expr (lhs); |
cf2b3c22 TB |
4681 | } |
4682 | ||
6de9cd9a DN |
4683 | } |
4684 | ||
3759634f | 4685 | /* STAT block. */ |
a513927a | 4686 | if (code->expr1) |
6de9cd9a DN |
4687 | { |
4688 | tmp = build1_v (LABEL_EXPR, error_label); | |
4689 | gfc_add_expr_to_block (&block, tmp); | |
4690 | ||
4691 | gfc_init_se (&se, NULL); | |
a513927a | 4692 | gfc_conv_expr_lhs (&se, code->expr1); |
6de9cd9a | 4693 | tmp = convert (TREE_TYPE (se.expr), stat); |
726a989a | 4694 | gfc_add_modify (&block, se.expr, tmp); |
6de9cd9a DN |
4695 | } |
4696 | ||
3759634f SK |
4697 | /* ERRMSG block. */ |
4698 | if (code->expr2) | |
4699 | { | |
4700 | /* A better error message may be possible, but not required. */ | |
4701 | const char *msg = "Attempt to allocate an allocated object"; | |
4702 | tree errmsg, slen, dlen; | |
4703 | ||
4704 | gfc_init_se (&se, NULL); | |
4705 | gfc_conv_expr_lhs (&se, code->expr2); | |
4706 | ||
4707 | errmsg = gfc_create_var (pchar_type_node, "ERRMSG"); | |
4708 | ||
4709 | gfc_add_modify (&block, errmsg, | |
4710 | gfc_build_addr_expr (pchar_type_node, | |
4711 | gfc_build_localized_cstring_const (msg))); | |
4712 | ||
4713 | slen = build_int_cst (gfc_charlen_type_node, ((int) strlen (msg))); | |
4714 | dlen = gfc_get_expr_charlen (code->expr2); | |
bc98ed60 TB |
4715 | slen = fold_build2_loc (input_location, MIN_EXPR, TREE_TYPE (slen), dlen, |
4716 | slen); | |
3759634f | 4717 | |
db3927fb AH |
4718 | dlen = build_call_expr_loc (input_location, |
4719 | built_in_decls[BUILT_IN_MEMCPY], 3, | |
3759634f SK |
4720 | gfc_build_addr_expr (pvoid_type_node, se.expr), errmsg, slen); |
4721 | ||
bc98ed60 TB |
4722 | tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, stat, |
4723 | build_int_cst (TREE_TYPE (stat), 0)); | |
3759634f | 4724 | |
c2255bc4 | 4725 | tmp = build3_v (COND_EXPR, tmp, dlen, build_empty_stmt (input_location)); |
3759634f SK |
4726 | |
4727 | gfc_add_expr_to_block (&block, tmp); | |
4728 | } | |
4729 | ||
6de9cd9a DN |
4730 | return gfc_finish_block (&block); |
4731 | } | |
4732 | ||
4733 | ||
3759634f SK |
4734 | /* Translate a DEALLOCATE statement. */ |
4735 | ||
6de9cd9a | 4736 | tree |
3759634f | 4737 | gfc_trans_deallocate (gfc_code *code) |
6de9cd9a DN |
4738 | { |
4739 | gfc_se se; | |
4740 | gfc_alloc *al; | |
4741 | gfc_expr *expr; | |
5039610b | 4742 | tree apstat, astat, pstat, stat, tmp; |
6de9cd9a DN |
4743 | stmtblock_t block; |
4744 | ||
3759634f SK |
4745 | pstat = apstat = stat = astat = tmp = NULL_TREE; |
4746 | ||
6de9cd9a DN |
4747 | gfc_start_block (&block); |
4748 | ||
3759634f SK |
4749 | /* Count the number of failed deallocations. If deallocate() was |
4750 | called with STAT= , then set STAT to the count. If deallocate | |
4751 | was called with ERRMSG, then set ERRMG to a string. */ | |
a513927a | 4752 | if (code->expr1 || code->expr2) |
364667a1 SK |
4753 | { |
4754 | tree gfc_int4_type_node = gfc_get_int_type (4); | |
4755 | ||
364667a1 | 4756 | stat = gfc_create_var (gfc_int4_type_node, "stat"); |
628c189e | 4757 | pstat = gfc_build_addr_expr (NULL_TREE, stat); |
364667a1 SK |
4758 | |
4759 | /* Running total of possible deallocation failures. */ | |
4760 | astat = gfc_create_var (gfc_int4_type_node, "astat"); | |
628c189e | 4761 | apstat = gfc_build_addr_expr (NULL_TREE, astat); |
364667a1 SK |
4762 | |
4763 | /* Initialize astat to 0. */ | |
726a989a | 4764 | gfc_add_modify (&block, astat, build_int_cst (TREE_TYPE (astat), 0)); |
364667a1 | 4765 | } |
364667a1 | 4766 | |
cf2b3c22 | 4767 | for (al = code->ext.alloc.list; al != NULL; al = al->next) |
6de9cd9a DN |
4768 | { |
4769 | expr = al->expr; | |
6e45f57b | 4770 | gcc_assert (expr->expr_type == EXPR_VARIABLE); |
6de9cd9a DN |
4771 | |
4772 | gfc_init_se (&se, NULL); | |
4773 | gfc_start_block (&se.pre); | |
4774 | ||
4775 | se.want_pointer = 1; | |
4776 | se.descriptor_only = 1; | |
4777 | gfc_conv_expr (&se, expr); | |
4778 | ||
2c807128 JW |
4779 | if (expr->rank) |
4780 | { | |
4781 | if (expr->ts.type == BT_DERIVED && expr->ts.u.derived->attr.alloc_comp) | |
5046aff5 | 4782 | { |
2c807128 JW |
4783 | gfc_ref *ref; |
4784 | gfc_ref *last = NULL; | |
4785 | for (ref = expr->ref; ref; ref = ref->next) | |
4786 | if (ref->type == REF_COMPONENT) | |
4787 | last = ref; | |
4788 | ||
4789 | /* Do not deallocate the components of a derived type | |
4790 | ultimate pointer component. */ | |
4791 | if (!(last && last->u.c.component->attr.pointer) | |
4792 | && !(!last && expr->symtree->n.sym->attr.pointer)) | |
4793 | { | |
4794 | tmp = gfc_deallocate_alloc_comp (expr->ts.u.derived, se.expr, | |
4795 | expr->rank); | |
4796 | gfc_add_expr_to_block (&se.pre, tmp); | |
4797 | } | |
5046aff5 | 4798 | } |
2c807128 | 4799 | tmp = gfc_array_deallocate (se.expr, pstat, expr); |
5046aff5 | 4800 | } |
6de9cd9a DN |
4801 | else |
4802 | { | |
2c807128 JW |
4803 | tmp = gfc_deallocate_scalar_with_status (se.expr, pstat, false, |
4804 | expr, expr->ts); | |
54200abb RG |
4805 | gfc_add_expr_to_block (&se.pre, tmp); |
4806 | ||
bc98ed60 TB |
4807 | tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, |
4808 | se.expr, | |
4809 | build_int_cst (TREE_TYPE (se.expr), 0)); | |
6de9cd9a | 4810 | } |
364667a1 SK |
4811 | |
4812 | gfc_add_expr_to_block (&se.pre, tmp); | |
4813 | ||
4814 | /* Keep track of the number of failed deallocations by adding stat | |
4815 | of the last deallocation to the running total. */ | |
a513927a | 4816 | if (code->expr1 || code->expr2) |
364667a1 | 4817 | { |
bc98ed60 TB |
4818 | apstat = fold_build2_loc (input_location, PLUS_EXPR, |
4819 | TREE_TYPE (stat), astat, stat); | |
726a989a | 4820 | gfc_add_modify (&se.pre, astat, apstat); |
364667a1 SK |
4821 | } |
4822 | ||
6de9cd9a DN |
4823 | tmp = gfc_finish_block (&se.pre); |
4824 | gfc_add_expr_to_block (&block, tmp); | |
364667a1 SK |
4825 | |
4826 | } | |
4827 | ||
3759634f | 4828 | /* Set STAT. */ |
a513927a | 4829 | if (code->expr1) |
364667a1 SK |
4830 | { |
4831 | gfc_init_se (&se, NULL); | |
a513927a | 4832 | gfc_conv_expr_lhs (&se, code->expr1); |
364667a1 | 4833 | tmp = convert (TREE_TYPE (se.expr), astat); |
726a989a | 4834 | gfc_add_modify (&block, se.expr, tmp); |
6de9cd9a DN |
4835 | } |
4836 | ||
3759634f SK |
4837 | /* Set ERRMSG. */ |
4838 | if (code->expr2) | |
4839 | { | |
4840 | /* A better error message may be possible, but not required. */ | |
4841 | const char *msg = "Attempt to deallocate an unallocated object"; | |
4842 | tree errmsg, slen, dlen; | |
4843 | ||
4844 | gfc_init_se (&se, NULL); | |
4845 | gfc_conv_expr_lhs (&se, code->expr2); | |
4846 | ||
4847 | errmsg = gfc_create_var (pchar_type_node, "ERRMSG"); | |
4848 | ||
4849 | gfc_add_modify (&block, errmsg, | |
4850 | gfc_build_addr_expr (pchar_type_node, | |
4851 | gfc_build_localized_cstring_const (msg))); | |
4852 | ||
4853 | slen = build_int_cst (gfc_charlen_type_node, ((int) strlen (msg))); | |
4854 | dlen = gfc_get_expr_charlen (code->expr2); | |
bc98ed60 TB |
4855 | slen = fold_build2_loc (input_location, MIN_EXPR, TREE_TYPE (slen), dlen, |
4856 | slen); | |
3759634f | 4857 | |
db3927fb AH |
4858 | dlen = build_call_expr_loc (input_location, |
4859 | built_in_decls[BUILT_IN_MEMCPY], 3, | |
3759634f SK |
4860 | gfc_build_addr_expr (pvoid_type_node, se.expr), errmsg, slen); |
4861 | ||
bc98ed60 TB |
4862 | tmp = fold_build2_loc (input_location, NE_EXPR, boolean_type_node, astat, |
4863 | build_int_cst (TREE_TYPE (astat), 0)); | |
3759634f | 4864 | |
c2255bc4 | 4865 | tmp = build3_v (COND_EXPR, tmp, dlen, build_empty_stmt (input_location)); |
3759634f SK |
4866 | |
4867 | gfc_add_expr_to_block (&block, tmp); | |
4868 | } | |
4869 | ||
6de9cd9a DN |
4870 | return gfc_finish_block (&block); |
4871 | } | |
4872 | ||
d2886bc7 | 4873 | #include "gt-fortran-trans-stmt.h" |