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