]>
Commit | Line | Data |
---|---|---|
6de9cd9a | 1 | /* Statement translation -- generate GCC trees from gfc_code. |
a945c346 | 2 | Copyright (C) 2002-2024 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" | |
c7131fb2 | 26 | #include "options.h" |
2adfab87 | 27 | #include "tree.h" |
6de9cd9a DN |
28 | #include "gfortran.h" |
29 | #include "trans.h" | |
2adfab87 | 30 | #include "stringpool.h" |
2adfab87 | 31 | #include "fold-const.h" |
6de9cd9a DN |
32 | #include "trans-stmt.h" |
33 | #include "trans-types.h" | |
34 | #include "trans-array.h" | |
35 | #include "trans-const.h" | |
3ded6210 | 36 | #include "dependency.h" |
6de9cd9a | 37 | |
6de9cd9a DN |
38 | typedef struct iter_info |
39 | { | |
40 | tree var; | |
41 | tree start; | |
42 | tree end; | |
43 | tree step; | |
9935667a | 44 | gfc_loop_annot annot; |
6de9cd9a DN |
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 | 85 | /* Deals with dummy argument. Get the parameter declaration. */ |
22ab4ed5 | 86 | else if (INDIRECT_REF_P (se->expr)) |
910450c1 | 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); | |
f622221a | 116 | len_tree = build_int_cst (gfc_charlen_type_node, -1); |
6de9cd9a DN |
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 | ||
f622221a | 129 | gfc_add_modify (&se.pre, len, fold_convert (TREE_TYPE (len), len_tree)); |
726a989a | 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); |
63ee5404 | 154 | tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node, tmp, |
bc98ed60 | 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 | ||
5c5ce609 HA |
202 | /* Make sure that trailing references are not lost. */ |
203 | if (old_ss->info | |
204 | && old_ss->info->data.array.ref | |
205 | && old_ss->info->data.array.ref->next | |
206 | && !(new_ss->info->data.array.ref | |
207 | && new_ss->info->data.array.ref->next)) | |
208 | new_ss->info->data.array.ref = old_ss->info->data.array.ref; | |
fafcf9e6 MM |
209 | |
210 | for (loopss = &(se->loop->ss); *loopss != gfc_ss_terminator; | |
211 | loopss = &((*loopss)->loop_chain)) | |
212 | if (*loopss == old_ss) | |
213 | break; | |
214 | gcc_assert (*loopss != gfc_ss_terminator); | |
215 | ||
216 | *loopss = new_ss; | |
217 | new_ss->loop_chain = old_ss->loop_chain; | |
218 | new_ss->loop = old_ss->loop; | |
219 | ||
220 | gfc_free_ss (old_ss); | |
221 | } | |
222 | ||
223 | ||
476220e7 PT |
224 | /* Check for dependencies between INTENT(IN) and INTENT(OUT) arguments of |
225 | elemental subroutines. Make temporaries for output arguments if any such | |
226 | dependencies are found. Output arguments are chosen because internal_unpack | |
227 | can be used, as is, to copy the result back to the variable. */ | |
228 | static void | |
229 | gfc_conv_elemental_dependencies (gfc_se * se, gfc_se * loopse, | |
2b0bd714 MM |
230 | gfc_symbol * sym, gfc_actual_arglist * arg, |
231 | gfc_dep_check check_variable) | |
476220e7 PT |
232 | { |
233 | gfc_actual_arglist *arg0; | |
234 | gfc_expr *e; | |
235 | gfc_formal_arglist *formal; | |
476220e7 PT |
236 | gfc_se parmse; |
237 | gfc_ss *ss; | |
476220e7 | 238 | gfc_symbol *fsym; |
476220e7 | 239 | tree data; |
476220e7 PT |
240 | tree size; |
241 | tree tmp; | |
242 | ||
243 | if (loopse->ss == NULL) | |
244 | return; | |
245 | ||
246 | ss = loopse->ss; | |
247 | arg0 = arg; | |
4cbc9039 | 248 | formal = gfc_sym_get_dummy_args (sym); |
476220e7 PT |
249 | |
250 | /* Loop over all the arguments testing for dependencies. */ | |
251 | for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL) | |
252 | { | |
253 | e = arg->expr; | |
254 | if (e == NULL) | |
255 | continue; | |
256 | ||
8b704316 | 257 | /* Obtain the info structure for the current argument. */ |
476220e7 | 258 | for (ss = loopse->ss; ss && ss != gfc_ss_terminator; ss = ss->next) |
fafcf9e6 | 259 | if (ss->info->expr == e) |
476220e7 | 260 | break; |
476220e7 PT |
261 | |
262 | /* If there is a dependency, create a temporary and use it | |
66e4ab31 | 263 | instead of the variable. */ |
476220e7 PT |
264 | fsym = formal ? formal->sym : NULL; |
265 | if (e->expr_type == EXPR_VARIABLE | |
266 | && e->rank && fsym | |
06bcd751 | 267 | && fsym->attr.intent != INTENT_IN |
07b9bcc1 | 268 | && !fsym->attr.value |
06bcd751 | 269 | && gfc_check_fncall_dependency (e, fsym->attr.intent, |
2b0bd714 | 270 | sym, arg0, check_variable)) |
476220e7 | 271 | { |
79e5286c | 272 | tree initial, temptype; |
12f681a0 | 273 | stmtblock_t temp_post; |
fafcf9e6 | 274 | gfc_ss *tmp_ss; |
12f681a0 | 275 | |
fafcf9e6 MM |
276 | tmp_ss = gfc_get_array_ss (gfc_ss_terminator, NULL, ss->dimen, |
277 | GFC_SS_SECTION); | |
278 | gfc_mark_ss_chain_used (tmp_ss, 1); | |
279 | tmp_ss->info->expr = ss->info->expr; | |
280 | replace_ss (loopse, ss, tmp_ss); | |
476220e7 | 281 | |
12f681a0 DK |
282 | /* Obtain the argument descriptor for unpacking. */ |
283 | gfc_init_se (&parmse, NULL); | |
284 | parmse.want_pointer = 1; | |
2960a368 | 285 | gfc_conv_expr_descriptor (&parmse, e); |
12f681a0 DK |
286 | gfc_add_block_to_block (&se->pre, &parmse.pre); |
287 | ||
eb74e79b PT |
288 | /* If we've got INTENT(INOUT) or a derived type with INTENT(OUT), |
289 | initialize the array temporary with a copy of the values. */ | |
290 | if (fsym->attr.intent == INTENT_INOUT | |
291 | || (fsym->ts.type ==BT_DERIVED | |
292 | && fsym->attr.intent == INTENT_OUT)) | |
12f681a0 | 293 | initial = parmse.expr; |
866e6d1b PT |
294 | /* For class expressions, we always initialize with the copy of |
295 | the values. */ | |
296 | else if (e->ts.type == BT_CLASS) | |
297 | initial = parmse.expr; | |
12f681a0 DK |
298 | else |
299 | initial = NULL_TREE; | |
300 | ||
866e6d1b PT |
301 | if (e->ts.type != BT_CLASS) |
302 | { | |
303 | /* Find the type of the temporary to create; we don't use the type | |
304 | of e itself as this breaks for subcomponent-references in e | |
305 | (where the type of e is that of the final reference, but | |
306 | parmse.expr's type corresponds to the full derived-type). */ | |
307 | /* TODO: Fix this somehow so we don't need a temporary of the whole | |
308 | array but instead only the components referenced. */ | |
309 | temptype = TREE_TYPE (parmse.expr); /* Pointer to descriptor. */ | |
310 | gcc_assert (TREE_CODE (temptype) == POINTER_TYPE); | |
311 | temptype = TREE_TYPE (temptype); | |
312 | temptype = gfc_get_element_type (temptype); | |
313 | } | |
314 | ||
315 | else | |
316 | /* For class arrays signal that the size of the dynamic type has to | |
317 | be obtained from the vtable, using the 'initial' expression. */ | |
318 | temptype = NULL_TREE; | |
79e5286c DK |
319 | |
320 | /* Generate the temporary. Cleaning up the temporary should be the | |
321 | very last thing done, so we add the code to a new block and add it | |
322 | to se->post as last instructions. */ | |
476220e7 PT |
323 | size = gfc_create_var (gfc_array_index_type, NULL); |
324 | data = gfc_create_var (pvoid_type_node, NULL); | |
12f681a0 | 325 | gfc_init_block (&temp_post); |
fafcf9e6 | 326 | tmp = gfc_trans_create_temp_array (&se->pre, &temp_post, tmp_ss, |
41645793 MM |
327 | temptype, initial, false, true, |
328 | false, &arg->expr->where); | |
726a989a | 329 | gfc_add_modify (&se->pre, size, tmp); |
fafcf9e6 | 330 | tmp = fold_convert (pvoid_type_node, tmp_ss->info->data.array.data); |
726a989a | 331 | gfc_add_modify (&se->pre, data, tmp); |
476220e7 | 332 | |
fafcf9e6 MM |
333 | /* Update other ss' delta. */ |
334 | gfc_set_delta (loopse->loop); | |
476220e7 | 335 | |
866e6d1b PT |
336 | /* Copy the result back using unpack..... */ |
337 | if (e->ts.type != BT_CLASS) | |
338 | tmp = build_call_expr_loc (input_location, | |
339 | gfor_fndecl_in_unpack, 2, parmse.expr, data); | |
340 | else | |
341 | { | |
342 | /* ... except for class results where the copy is | |
343 | unconditional. */ | |
344 | tmp = build_fold_indirect_ref_loc (input_location, parmse.expr); | |
345 | tmp = gfc_conv_descriptor_data_get (tmp); | |
346 | tmp = build_call_expr_loc (input_location, | |
347 | builtin_decl_explicit (BUILT_IN_MEMCPY), | |
ee4b6b52 JJ |
348 | 3, tmp, data, |
349 | fold_convert (size_type_node, size)); | |
866e6d1b | 350 | } |
476220e7 PT |
351 | gfc_add_expr_to_block (&se->post, tmp); |
352 | ||
79e5286c | 353 | /* parmse.pre is already added above. */ |
476220e7 | 354 | gfc_add_block_to_block (&se->post, &parmse.post); |
12f681a0 | 355 | gfc_add_block_to_block (&se->post, &temp_post); |
476220e7 PT |
356 | } |
357 | } | |
358 | } | |
359 | ||
360 | ||
68d62cb2 MM |
361 | /* Given an executable statement referring to an intrinsic function call, |
362 | returns the intrinsic symbol. */ | |
363 | ||
364 | static gfc_intrinsic_sym * | |
365 | get_intrinsic_for_code (gfc_code *code) | |
366 | { | |
367 | if (code->op == EXEC_CALL) | |
368 | { | |
369 | gfc_intrinsic_sym * const isym = code->resolved_isym; | |
370 | if (isym) | |
371 | return isym; | |
372 | else | |
373 | return gfc_get_intrinsic_for_expr (code->expr1); | |
374 | } | |
375 | ||
376 | return NULL; | |
377 | } | |
378 | ||
379 | ||
6de9cd9a DN |
380 | /* Translate the CALL statement. Builds a call to an F95 subroutine. */ |
381 | ||
382 | tree | |
eb74e79b PT |
383 | gfc_trans_call (gfc_code * code, bool dependency_check, |
384 | tree mask, tree count1, bool invert) | |
6de9cd9a DN |
385 | { |
386 | gfc_se se; | |
48474141 | 387 | gfc_ss * ss; |
dda895f9 | 388 | int has_alternate_specifier; |
2b0bd714 | 389 | gfc_dep_check check_variable; |
eb74e79b PT |
390 | tree index = NULL_TREE; |
391 | tree maskexpr = NULL_TREE; | |
392 | tree tmp; | |
5c5ce609 | 393 | bool is_intrinsic_mvbits; |
6de9cd9a DN |
394 | |
395 | /* A CALL starts a new block because the actual arguments may have to | |
396 | be evaluated first. */ | |
397 | gfc_init_se (&se, NULL); | |
398 | gfc_start_block (&se.pre); | |
399 | ||
6e45f57b | 400 | gcc_assert (code->resolved_sym); |
6de9cd9a | 401 | |
48474141 PT |
402 | ss = gfc_ss_terminator; |
403 | if (code->resolved_sym->attr.elemental) | |
17d038cd | 404 | ss = gfc_walk_elemental_function_args (ss, code->ext.actual, |
68d62cb2 | 405 | get_intrinsic_for_code (code), |
dec131b6 | 406 | GFC_SS_REFERENCE); |
6de9cd9a | 407 | |
5c5ce609 HA |
408 | /* MVBITS is inlined but needs the dependency checking found here. */ |
409 | is_intrinsic_mvbits = code->resolved_isym | |
410 | && code->resolved_isym->id == GFC_ISYM_MVBITS; | |
411 | ||
48474141 PT |
412 | /* Is not an elemental subroutine call with array valued arguments. */ |
413 | if (ss == gfc_ss_terminator) | |
6de9cd9a | 414 | { |
48474141 | 415 | |
5c5ce609 HA |
416 | if (is_intrinsic_mvbits) |
417 | { | |
418 | has_alternate_specifier = 0; | |
419 | gfc_conv_intrinsic_mvbits (&se, code->ext.actual, NULL); | |
420 | } | |
421 | else | |
422 | { | |
423 | /* Translate the call. */ | |
424 | has_alternate_specifier = | |
425 | gfc_conv_procedure_call (&se, code->resolved_sym, | |
426 | code->ext.actual, code->expr1, NULL); | |
48474141 | 427 | |
5c5ce609 HA |
428 | /* A subroutine without side-effect, by definition, does nothing! */ |
429 | TREE_SIDE_EFFECTS (se.expr) = 1; | |
430 | } | |
48474141 PT |
431 | |
432 | /* Chain the pieces together and return the block. */ | |
433 | if (has_alternate_specifier) | |
434 | { | |
435 | gfc_code *select_code; | |
436 | gfc_symbol *sym; | |
437 | select_code = code->next; | |
438 | gcc_assert(select_code->op == EXEC_SELECT); | |
a513927a | 439 | sym = select_code->expr1->symtree->n.sym; |
48474141 | 440 | se.expr = convert (gfc_typenode_for_spec (&sym->ts), se.expr); |
9ebe2d22 PT |
441 | if (sym->backend_decl == NULL) |
442 | sym->backend_decl = gfc_get_symbol_decl (sym); | |
726a989a | 443 | gfc_add_modify (&se.pre, sym->backend_decl, se.expr); |
48474141 PT |
444 | } |
445 | else | |
446 | gfc_add_expr_to_block (&se.pre, se.expr); | |
447 | ||
d7caf313 PT |
448 | gfc_add_block_to_block (&se.finalblock, &se.post); |
449 | gfc_add_block_to_block (&se.pre, &se.finalblock); | |
6de9cd9a | 450 | } |
48474141 | 451 | |
6de9cd9a | 452 | else |
48474141 PT |
453 | { |
454 | /* An elemental subroutine call with array valued arguments has | |
455 | to be scalarized. */ | |
456 | gfc_loopinfo loop; | |
457 | stmtblock_t body; | |
458 | stmtblock_t block; | |
459 | gfc_se loopse; | |
70e72065 | 460 | gfc_se depse; |
48474141 PT |
461 | |
462 | /* gfc_walk_elemental_function_args renders the ss chain in the | |
12f681a0 | 463 | reverse order to the actual argument order. */ |
48474141 PT |
464 | ss = gfc_reverse_ss (ss); |
465 | ||
466 | /* Initialize the loop. */ | |
467 | gfc_init_se (&loopse, NULL); | |
468 | gfc_init_loopinfo (&loop); | |
469 | gfc_add_ss_to_loop (&loop, ss); | |
470 | ||
471 | gfc_conv_ss_startstride (&loop); | |
8b704316 PT |
472 | /* TODO: gfc_conv_loop_setup generates a temporary for vector |
473 | subscripts. This could be prevented in the elemental case | |
7ebd4a1d | 474 | as temporaries are handled separately |
2b0bd714 | 475 | (below in gfc_conv_elemental_dependencies). */ |
88016532 JD |
476 | if (code->expr1) |
477 | gfc_conv_loop_setup (&loop, &code->expr1->where); | |
478 | else | |
479 | gfc_conv_loop_setup (&loop, &code->loc); | |
480 | ||
48474141 PT |
481 | gfc_mark_ss_chain_used (ss, 1); |
482 | ||
476220e7 PT |
483 | /* Convert the arguments, checking for dependencies. */ |
484 | gfc_copy_loopinfo_to_se (&loopse, &loop); | |
485 | loopse.ss = ss; | |
486 | ||
06bcd751 | 487 | /* For operator assignment, do dependency checking. */ |
476220e7 | 488 | if (dependency_check) |
2b0bd714 MM |
489 | check_variable = ELEM_CHECK_VARIABLE; |
490 | else | |
491 | check_variable = ELEM_DONT_CHECK_VARIABLE; | |
70e72065 MM |
492 | |
493 | gfc_init_se (&depse, NULL); | |
494 | gfc_conv_elemental_dependencies (&depse, &loopse, code->resolved_sym, | |
2b0bd714 | 495 | code->ext.actual, check_variable); |
476220e7 | 496 | |
70e72065 MM |
497 | gfc_add_block_to_block (&loop.pre, &depse.pre); |
498 | gfc_add_block_to_block (&loop.post, &depse.post); | |
499 | ||
48474141 PT |
500 | /* Generate the loop body. */ |
501 | gfc_start_scalarized_body (&loop, &body); | |
502 | gfc_init_block (&block); | |
48474141 | 503 | |
eb74e79b PT |
504 | if (mask && count1) |
505 | { | |
506 | /* Form the mask expression according to the mask. */ | |
507 | index = count1; | |
508 | maskexpr = gfc_build_array_ref (mask, index, NULL); | |
509 | if (invert) | |
bc98ed60 TB |
510 | maskexpr = fold_build1_loc (input_location, TRUTH_NOT_EXPR, |
511 | TREE_TYPE (maskexpr), maskexpr); | |
eb74e79b PT |
512 | } |
513 | ||
5c5ce609 HA |
514 | if (is_intrinsic_mvbits) |
515 | { | |
516 | has_alternate_specifier = 0; | |
517 | gfc_conv_intrinsic_mvbits (&loopse, code->ext.actual, &loop); | |
518 | } | |
519 | else | |
520 | { | |
521 | /* Add the subroutine call to the block. */ | |
522 | gfc_conv_procedure_call (&loopse, code->resolved_sym, | |
523 | code->ext.actual, code->expr1, | |
524 | NULL); | |
525 | } | |
eb74e79b PT |
526 | |
527 | if (mask && count1) | |
528 | { | |
529 | tmp = build3_v (COND_EXPR, maskexpr, loopse.expr, | |
c2255bc4 | 530 | build_empty_stmt (input_location)); |
eb74e79b | 531 | gfc_add_expr_to_block (&loopse.pre, tmp); |
bc98ed60 TB |
532 | tmp = fold_build2_loc (input_location, PLUS_EXPR, |
533 | gfc_array_index_type, | |
534 | count1, gfc_index_one_node); | |
eb74e79b PT |
535 | gfc_add_modify (&loopse.pre, count1, tmp); |
536 | } | |
537 | else | |
538 | gfc_add_expr_to_block (&loopse.pre, loopse.expr); | |
48474141 PT |
539 | |
540 | gfc_add_block_to_block (&block, &loopse.pre); | |
541 | gfc_add_block_to_block (&block, &loopse.post); | |
542 | ||
543 | /* Finish up the loop block and the loop. */ | |
544 | gfc_add_expr_to_block (&body, gfc_finish_block (&block)); | |
545 | gfc_trans_scalarizing_loops (&loop, &body); | |
546 | gfc_add_block_to_block (&se.pre, &loop.pre); | |
547 | gfc_add_block_to_block (&se.pre, &loop.post); | |
d7caf313 | 548 | gfc_add_block_to_block (&se.pre, &loopse.finalblock); |
476220e7 | 549 | gfc_add_block_to_block (&se.pre, &se.post); |
48474141 PT |
550 | gfc_cleanup_loop (&loop); |
551 | } | |
6de9cd9a | 552 | |
6de9cd9a DN |
553 | return gfc_finish_block (&se.pre); |
554 | } | |
555 | ||
556 | ||
557 | /* Translate the RETURN statement. */ | |
558 | ||
559 | tree | |
d74d8807 | 560 | gfc_trans_return (gfc_code * code) |
6de9cd9a | 561 | { |
a513927a | 562 | if (code->expr1) |
6de9cd9a DN |
563 | { |
564 | gfc_se se; | |
565 | tree tmp; | |
566 | tree result; | |
567 | ||
da4c6ed8 | 568 | /* If code->expr is not NULL, this return statement must appear |
d74d8807 | 569 | in a subroutine and current_fake_result_decl has already |
6de9cd9a DN |
570 | been generated. */ |
571 | ||
5f20c93a | 572 | result = gfc_get_fake_result_decl (NULL, 0); |
6de9cd9a | 573 | if (!result) |
d74d8807 | 574 | { |
db30e21c JM |
575 | gfc_warning (0, |
576 | "An alternate return at %L without a * dummy argument", | |
48749dbc | 577 | &code->expr1->where); |
d74d8807 DK |
578 | return gfc_generate_return (); |
579 | } | |
6de9cd9a DN |
580 | |
581 | /* Start a new block for this statement. */ | |
582 | gfc_init_se (&se, NULL); | |
583 | gfc_start_block (&se.pre); | |
584 | ||
a513927a | 585 | gfc_conv_expr (&se, code->expr1); |
6de9cd9a | 586 | |
ba3ff5c2 DK |
587 | /* Note that the actually returned expression is a simple value and |
588 | does not depend on any pointers or such; thus we can clean-up with | |
589 | se.post before returning. */ | |
bc98ed60 TB |
590 | tmp = fold_build2_loc (input_location, MODIFY_EXPR, TREE_TYPE (result), |
591 | result, fold_convert (TREE_TYPE (result), | |
592 | se.expr)); | |
6de9cd9a | 593 | gfc_add_expr_to_block (&se.pre, tmp); |
ba3ff5c2 | 594 | gfc_add_block_to_block (&se.pre, &se.post); |
6de9cd9a | 595 | |
d74d8807 | 596 | tmp = gfc_generate_return (); |
6de9cd9a | 597 | gfc_add_expr_to_block (&se.pre, tmp); |
6de9cd9a DN |
598 | return gfc_finish_block (&se.pre); |
599 | } | |
d74d8807 DK |
600 | |
601 | return gfc_generate_return (); | |
6de9cd9a DN |
602 | } |
603 | ||
604 | ||
605 | /* Translate the PAUSE statement. We have to translate this statement | |
606 | to a runtime library call. */ | |
607 | ||
608 | tree | |
609 | gfc_trans_pause (gfc_code * code) | |
610 | { | |
6cc22cf4 | 611 | tree gfc_int8_type_node = gfc_get_int_type (8); |
6de9cd9a | 612 | gfc_se se; |
6de9cd9a | 613 | tree tmp; |
6de9cd9a DN |
614 | |
615 | /* Start a new block for this statement. */ | |
616 | gfc_init_se (&se, NULL); | |
617 | gfc_start_block (&se.pre); | |
618 | ||
619 | ||
a513927a | 620 | if (code->expr1 == NULL) |
6de9cd9a | 621 | { |
6cc22cf4 | 622 | tmp = build_int_cst (size_type_node, 0); |
db3927fb | 623 | tmp = build_call_expr_loc (input_location, |
6d1b0f92 JD |
624 | gfor_fndecl_pause_string, 2, |
625 | build_int_cst (pchar_type_node, 0), tmp); | |
626 | } | |
627 | else if (code->expr1->ts.type == BT_INTEGER) | |
628 | { | |
629 | gfc_conv_expr (&se, code->expr1); | |
630 | tmp = build_call_expr_loc (input_location, | |
631 | gfor_fndecl_pause_numeric, 1, | |
6cc22cf4 | 632 | fold_convert (gfc_int8_type_node, se.expr)); |
6de9cd9a DN |
633 | } |
634 | else | |
635 | { | |
a513927a | 636 | gfc_conv_expr_reference (&se, code->expr1); |
db3927fb AH |
637 | tmp = build_call_expr_loc (input_location, |
638 | gfor_fndecl_pause_string, 2, | |
6cc22cf4 JB |
639 | se.expr, fold_convert (size_type_node, |
640 | se.string_length)); | |
6de9cd9a DN |
641 | } |
642 | ||
6de9cd9a DN |
643 | gfc_add_expr_to_block (&se.pre, tmp); |
644 | ||
645 | gfc_add_block_to_block (&se.pre, &se.post); | |
646 | ||
647 | return gfc_finish_block (&se.pre); | |
648 | } | |
649 | ||
650 | ||
651 | /* Translate the STOP statement. We have to translate this statement | |
652 | to a runtime library call. */ | |
653 | ||
654 | tree | |
d0a4a61c | 655 | gfc_trans_stop (gfc_code *code, bool error_stop) |
6de9cd9a DN |
656 | { |
657 | gfc_se se; | |
6de9cd9a | 658 | tree tmp; |
916b809f | 659 | tree quiet; |
6de9cd9a DN |
660 | |
661 | /* Start a new block for this statement. */ | |
662 | gfc_init_se (&se, NULL); | |
663 | gfc_start_block (&se.pre); | |
664 | ||
916b809f HA |
665 | if (code->expr2) |
666 | { | |
667 | gfc_conv_expr_val (&se, code->expr2); | |
668 | quiet = fold_convert (boolean_type_node, se.expr); | |
669 | } | |
670 | else | |
671 | quiet = boolean_false_node; | |
672 | ||
a513927a | 673 | if (code->expr1 == NULL) |
6de9cd9a | 674 | { |
3f5fabc0 | 675 | tmp = build_int_cst (size_type_node, 0); |
6d1b0f92 | 676 | tmp = build_call_expr_loc (input_location, |
60386f50 | 677 | error_stop |
f19626cf | 678 | ? (flag_coarray == GFC_FCOARRAY_LIB |
60386f50 TB |
679 | ? gfor_fndecl_caf_error_stop_str |
680 | : gfor_fndecl_error_stop_string) | |
0daa7ed9 AF |
681 | : (flag_coarray == GFC_FCOARRAY_LIB |
682 | ? gfor_fndecl_caf_stop_str | |
683 | : gfor_fndecl_stop_string), | |
dffb1e22 | 684 | 3, build_int_cst (pchar_type_node, 0), tmp, |
916b809f | 685 | quiet); |
6d1b0f92 JD |
686 | } |
687 | else if (code->expr1->ts.type == BT_INTEGER) | |
688 | { | |
689 | gfc_conv_expr (&se, code->expr1); | |
db3927fb | 690 | tmp = build_call_expr_loc (input_location, |
60386f50 | 691 | error_stop |
f19626cf | 692 | ? (flag_coarray == GFC_FCOARRAY_LIB |
60386f50 TB |
693 | ? gfor_fndecl_caf_error_stop |
694 | : gfor_fndecl_error_stop_numeric) | |
0daa7ed9 AF |
695 | : (flag_coarray == GFC_FCOARRAY_LIB |
696 | ? gfor_fndecl_caf_stop_numeric | |
dffb1e22 JB |
697 | : gfor_fndecl_stop_numeric), 2, |
698 | fold_convert (integer_type_node, se.expr), | |
916b809f | 699 | quiet); |
6de9cd9a DN |
700 | } |
701 | else | |
702 | { | |
a513927a | 703 | gfc_conv_expr_reference (&se, code->expr1); |
db3927fb | 704 | tmp = build_call_expr_loc (input_location, |
60386f50 | 705 | error_stop |
f19626cf | 706 | ? (flag_coarray == GFC_FCOARRAY_LIB |
60386f50 TB |
707 | ? gfor_fndecl_caf_error_stop_str |
708 | : gfor_fndecl_error_stop_string) | |
0daa7ed9 AF |
709 | : (flag_coarray == GFC_FCOARRAY_LIB |
710 | ? gfor_fndecl_caf_stop_str | |
711 | : gfor_fndecl_stop_string), | |
dffb1e22 JB |
712 | 3, se.expr, fold_convert (size_type_node, |
713 | se.string_length), | |
916b809f | 714 | quiet); |
6de9cd9a DN |
715 | } |
716 | ||
6de9cd9a DN |
717 | gfc_add_expr_to_block (&se.pre, tmp); |
718 | ||
719 | gfc_add_block_to_block (&se.pre, &se.post); | |
720 | ||
721 | return gfc_finish_block (&se.pre); | |
722 | } | |
723 | ||
ef78bc3c AV |
724 | /* Translate the FAIL IMAGE statement. */ |
725 | ||
726 | tree | |
727 | gfc_trans_fail_image (gfc_code *code ATTRIBUTE_UNUSED) | |
728 | { | |
729 | if (flag_coarray == GFC_FCOARRAY_LIB) | |
730 | return build_call_expr_loc (input_location, | |
3489d80f | 731 | gfor_fndecl_caf_fail_image, 0); |
ef78bc3c AV |
732 | else |
733 | { | |
734 | const char *name = gfc_get_string (PREFIX ("exit_i%d"), 4); | |
735 | gfc_symbol *exsym = gfc_get_intrinsic_sub_symbol (name); | |
736 | tree tmp = gfc_get_symbol_decl (exsym); | |
737 | return build_call_expr_loc (input_location, tmp, 1, integer_zero_node); | |
738 | } | |
739 | } | |
740 | ||
f8862a1b DR |
741 | /* Translate the FORM TEAM statement. */ |
742 | ||
743 | tree | |
744 | gfc_trans_form_team (gfc_code *code) | |
745 | { | |
746 | if (flag_coarray == GFC_FCOARRAY_LIB) | |
747 | { | |
91ab2a1d TB |
748 | gfc_se se; |
749 | gfc_se argse1, argse2; | |
750 | tree team_id, team_type, tmp; | |
f8862a1b | 751 | |
91ab2a1d TB |
752 | gfc_init_se (&se, NULL); |
753 | gfc_init_se (&argse1, NULL); | |
754 | gfc_init_se (&argse2, NULL); | |
755 | gfc_start_block (&se.pre); | |
756 | ||
757 | gfc_conv_expr_val (&argse1, code->expr1); | |
758 | gfc_conv_expr_val (&argse2, code->expr2); | |
759 | team_id = fold_convert (integer_type_node, argse1.expr); | |
760 | team_type = gfc_build_addr_expr (ppvoid_type_node, argse2.expr); | |
761 | ||
762 | gfc_add_block_to_block (&se.pre, &argse1.pre); | |
763 | gfc_add_block_to_block (&se.pre, &argse2.pre); | |
764 | tmp = build_call_expr_loc (input_location, | |
765 | gfor_fndecl_caf_form_team, 3, | |
766 | team_id, team_type, | |
59067ddf | 767 | integer_zero_node); |
91ab2a1d TB |
768 | gfc_add_expr_to_block (&se.pre, tmp); |
769 | gfc_add_block_to_block (&se.pre, &argse1.post); | |
770 | gfc_add_block_to_block (&se.pre, &argse2.post); | |
771 | return gfc_finish_block (&se.pre); | |
f8862a1b DR |
772 | } |
773 | else | |
774 | { | |
775 | const char *name = gfc_get_string (PREFIX ("exit_i%d"), 4); | |
776 | gfc_symbol *exsym = gfc_get_intrinsic_sub_symbol (name); | |
777 | tree tmp = gfc_get_symbol_decl (exsym); | |
778 | return build_call_expr_loc (input_location, tmp, 1, integer_zero_node); | |
779 | } | |
780 | } | |
781 | ||
782 | /* Translate the CHANGE TEAM statement. */ | |
783 | ||
784 | tree | |
785 | gfc_trans_change_team (gfc_code *code) | |
786 | { | |
787 | if (flag_coarray == GFC_FCOARRAY_LIB) | |
788 | { | |
789 | gfc_se argse; | |
91ab2a1d | 790 | tree team_type, tmp; |
f8862a1b DR |
791 | |
792 | gfc_init_se (&argse, NULL); | |
793 | gfc_conv_expr_val (&argse, code->expr1); | |
794 | team_type = gfc_build_addr_expr (ppvoid_type_node, argse.expr); | |
795 | ||
91ab2a1d TB |
796 | tmp = build_call_expr_loc (input_location, |
797 | gfor_fndecl_caf_change_team, 2, team_type, | |
59067ddf | 798 | integer_zero_node); |
91ab2a1d TB |
799 | gfc_add_expr_to_block (&argse.pre, tmp); |
800 | gfc_add_block_to_block (&argse.pre, &argse.post); | |
801 | return gfc_finish_block (&argse.pre); | |
f8862a1b DR |
802 | } |
803 | else | |
804 | { | |
805 | const char *name = gfc_get_string (PREFIX ("exit_i%d"), 4); | |
806 | gfc_symbol *exsym = gfc_get_intrinsic_sub_symbol (name); | |
807 | tree tmp = gfc_get_symbol_decl (exsym); | |
808 | return build_call_expr_loc (input_location, tmp, 1, integer_zero_node); | |
809 | } | |
810 | } | |
811 | ||
812 | /* Translate the END TEAM statement. */ | |
813 | ||
814 | tree | |
815 | gfc_trans_end_team (gfc_code *code ATTRIBUTE_UNUSED) | |
816 | { | |
817 | if (flag_coarray == GFC_FCOARRAY_LIB) | |
818 | { | |
819 | return build_call_expr_loc (input_location, | |
820 | gfor_fndecl_caf_end_team, 1, | |
821 | build_int_cst (pchar_type_node, 0)); | |
822 | } | |
823 | else | |
824 | { | |
825 | const char *name = gfc_get_string (PREFIX ("exit_i%d"), 4); | |
826 | gfc_symbol *exsym = gfc_get_intrinsic_sub_symbol (name); | |
827 | tree tmp = gfc_get_symbol_decl (exsym); | |
828 | return build_call_expr_loc (input_location, tmp, 1, integer_zero_node); | |
829 | } | |
830 | } | |
831 | ||
832 | /* Translate the SYNC TEAM statement. */ | |
833 | ||
834 | tree | |
835 | gfc_trans_sync_team (gfc_code *code) | |
836 | { | |
837 | if (flag_coarray == GFC_FCOARRAY_LIB) | |
838 | { | |
839 | gfc_se argse; | |
91ab2a1d | 840 | tree team_type, tmp; |
f8862a1b DR |
841 | |
842 | gfc_init_se (&argse, NULL); | |
843 | gfc_conv_expr_val (&argse, code->expr1); | |
844 | team_type = gfc_build_addr_expr (ppvoid_type_node, argse.expr); | |
845 | ||
91ab2a1d TB |
846 | tmp = build_call_expr_loc (input_location, |
847 | gfor_fndecl_caf_sync_team, 2, | |
848 | team_type, | |
59067ddf | 849 | integer_zero_node); |
91ab2a1d TB |
850 | gfc_add_expr_to_block (&argse.pre, tmp); |
851 | gfc_add_block_to_block (&argse.pre, &argse.post); | |
852 | return gfc_finish_block (&argse.pre); | |
f8862a1b DR |
853 | } |
854 | else | |
855 | { | |
856 | const char *name = gfc_get_string (PREFIX ("exit_i%d"), 4); | |
857 | gfc_symbol *exsym = gfc_get_intrinsic_sub_symbol (name); | |
858 | tree tmp = gfc_get_symbol_decl (exsym); | |
859 | return build_call_expr_loc (input_location, tmp, 1, integer_zero_node); | |
860 | } | |
861 | } | |
6de9cd9a | 862 | |
fea54935 | 863 | tree |
9f3880d1 | 864 | gfc_trans_lock_unlock (gfc_code *code, gfc_exec_op op) |
fea54935 TB |
865 | { |
866 | gfc_se se, argse; | |
9f3880d1 TB |
867 | tree stat = NULL_TREE, stat2 = NULL_TREE; |
868 | tree lock_acquired = NULL_TREE, lock_acquired2 = NULL_TREE; | |
fea54935 TB |
869 | |
870 | /* Short cut: For single images without STAT= or LOCK_ACQUIRED | |
871 | return early. (ERRMSG= is always untouched for -fcoarray=single.) */ | |
f19626cf | 872 | if (!code->expr2 && !code->expr4 && flag_coarray != GFC_FCOARRAY_LIB) |
8b704316 | 873 | return NULL_TREE; |
fea54935 | 874 | |
fea54935 TB |
875 | if (code->expr2) |
876 | { | |
877 | gcc_assert (code->expr2->expr_type == EXPR_VARIABLE); | |
878 | gfc_init_se (&argse, NULL); | |
879 | gfc_conv_expr_val (&argse, code->expr2); | |
880 | stat = argse.expr; | |
881 | } | |
9f3880d1 TB |
882 | else if (flag_coarray == GFC_FCOARRAY_LIB) |
883 | stat = null_pointer_node; | |
fea54935 TB |
884 | |
885 | if (code->expr4) | |
886 | { | |
887 | gcc_assert (code->expr4->expr_type == EXPR_VARIABLE); | |
888 | gfc_init_se (&argse, NULL); | |
889 | gfc_conv_expr_val (&argse, code->expr4); | |
890 | lock_acquired = argse.expr; | |
891 | } | |
9f3880d1 TB |
892 | else if (flag_coarray == GFC_FCOARRAY_LIB) |
893 | lock_acquired = null_pointer_node; | |
894 | ||
895 | gfc_start_block (&se.pre); | |
896 | if (flag_coarray == GFC_FCOARRAY_LIB) | |
897 | { | |
898 | tree tmp, token, image_index, errmsg, errmsg_len; | |
0f97b81b | 899 | tree index = build_zero_cst (gfc_array_index_type); |
9f3880d1 TB |
900 | tree caf_decl = gfc_get_tree_for_caf_expr (code->expr1); |
901 | ||
902 | if (code->expr1->symtree->n.sym->ts.type != BT_DERIVED | |
903 | || code->expr1->symtree->n.sym->ts.u.derived->from_intmod | |
904 | != INTMOD_ISO_FORTRAN_ENV | |
905 | || code->expr1->symtree->n.sym->ts.u.derived->intmod_sym_id | |
906 | != ISOFORTRAN_LOCK_TYPE) | |
907 | { | |
908 | gfc_error ("Sorry, the lock component of derived type at %L is not " | |
909 | "yet supported", &code->expr1->where); | |
910 | return NULL_TREE; | |
911 | } | |
912 | ||
3c9f5092 AV |
913 | gfc_get_caf_token_offset (&se, &token, NULL, caf_decl, NULL_TREE, |
914 | code->expr1); | |
9f3880d1 TB |
915 | |
916 | if (gfc_is_coindexed (code->expr1)) | |
917 | image_index = gfc_caf_get_image_index (&se.pre, code->expr1, caf_decl); | |
918 | else | |
919 | image_index = integer_zero_node; | |
920 | ||
921 | /* For arrays, obtain the array index. */ | |
922 | if (gfc_expr_attr (code->expr1).dimension) | |
923 | { | |
924 | tree desc, tmp, extent, lbound, ubound; | |
925 | gfc_array_ref *ar, ar2; | |
926 | int i; | |
927 | ||
928 | /* TODO: Extend this, once DT components are supported. */ | |
929 | ar = &code->expr1->ref->u.ar; | |
930 | ar2 = *ar; | |
931 | memset (ar, '\0', sizeof (*ar)); | |
932 | ar->as = ar2.as; | |
933 | ar->type = AR_FULL; | |
934 | ||
935 | gfc_init_se (&argse, NULL); | |
936 | argse.descriptor_only = 1; | |
937 | gfc_conv_expr_descriptor (&argse, code->expr1); | |
938 | gfc_add_block_to_block (&se.pre, &argse.pre); | |
939 | desc = argse.expr; | |
940 | *ar = ar2; | |
941 | ||
0f97b81b | 942 | extent = build_one_cst (gfc_array_index_type); |
9f3880d1 TB |
943 | for (i = 0; i < ar->dimen; i++) |
944 | { | |
945 | gfc_init_se (&argse, NULL); | |
0f97b81b | 946 | gfc_conv_expr_type (&argse, ar->start[i], gfc_array_index_type); |
9f3880d1 TB |
947 | gfc_add_block_to_block (&argse.pre, &argse.pre); |
948 | lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[i]); | |
949 | tmp = fold_build2_loc (input_location, MINUS_EXPR, | |
0f97b81b | 950 | TREE_TYPE (lbound), argse.expr, lbound); |
9f3880d1 | 951 | tmp = fold_build2_loc (input_location, MULT_EXPR, |
0f97b81b | 952 | TREE_TYPE (tmp), extent, tmp); |
9f3880d1 | 953 | index = fold_build2_loc (input_location, PLUS_EXPR, |
0f97b81b | 954 | TREE_TYPE (tmp), index, tmp); |
9f3880d1 TB |
955 | if (i < ar->dimen - 1) |
956 | { | |
957 | ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[i]); | |
958 | tmp = gfc_conv_array_extent_dim (lbound, ubound, NULL); | |
9f3880d1 | 959 | extent = fold_build2_loc (input_location, MULT_EXPR, |
0f97b81b | 960 | TREE_TYPE (tmp), extent, tmp); |
9f3880d1 TB |
961 | } |
962 | } | |
963 | } | |
964 | ||
965 | /* errmsg. */ | |
966 | if (code->expr3) | |
967 | { | |
968 | gfc_init_se (&argse, NULL); | |
5df445a2 | 969 | argse.want_pointer = 1; |
9f3880d1 TB |
970 | gfc_conv_expr (&argse, code->expr3); |
971 | gfc_add_block_to_block (&se.pre, &argse.pre); | |
972 | errmsg = argse.expr; | |
3f5fabc0 | 973 | errmsg_len = fold_convert (size_type_node, argse.string_length); |
9f3880d1 TB |
974 | } |
975 | else | |
976 | { | |
977 | errmsg = null_pointer_node; | |
3f5fabc0 | 978 | errmsg_len = build_zero_cst (size_type_node); |
9f3880d1 TB |
979 | } |
980 | ||
981 | if (stat != null_pointer_node && TREE_TYPE (stat) != integer_type_node) | |
982 | { | |
983 | stat2 = stat; | |
984 | stat = gfc_create_var (integer_type_node, "stat"); | |
985 | } | |
986 | ||
987 | if (lock_acquired != null_pointer_node | |
988 | && TREE_TYPE (lock_acquired) != integer_type_node) | |
989 | { | |
990 | lock_acquired2 = lock_acquired; | |
991 | lock_acquired = gfc_create_var (integer_type_node, "acquired"); | |
992 | } | |
993 | ||
0f97b81b | 994 | index = fold_convert (size_type_node, index); |
9f3880d1 TB |
995 | if (op == EXEC_LOCK) |
996 | tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_lock, 7, | |
997 | token, index, image_index, | |
998 | lock_acquired != null_pointer_node | |
999 | ? gfc_build_addr_expr (NULL, lock_acquired) | |
1000 | : lock_acquired, | |
1001 | stat != null_pointer_node | |
1002 | ? gfc_build_addr_expr (NULL, stat) : stat, | |
1003 | errmsg, errmsg_len); | |
1004 | else | |
1005 | tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_unlock, 6, | |
1006 | token, index, image_index, | |
1007 | stat != null_pointer_node | |
1008 | ? gfc_build_addr_expr (NULL, stat) : stat, | |
1009 | errmsg, errmsg_len); | |
1010 | gfc_add_expr_to_block (&se.pre, tmp); | |
1011 | ||
985f6c79 TB |
1012 | /* It guarantees memory consistency within the same segment */ |
1013 | tmp = gfc_build_string_const (strlen ("memory")+1, "memory"), | |
1014 | tmp = build5_loc (input_location, ASM_EXPR, void_type_node, | |
1015 | gfc_build_string_const (1, ""), NULL_TREE, NULL_TREE, | |
1016 | tree_cons (NULL_TREE, tmp, NULL_TREE), NULL_TREE); | |
1017 | ASM_VOLATILE_P (tmp) = 1; | |
1018 | ||
1019 | gfc_add_expr_to_block (&se.pre, tmp); | |
1020 | ||
9f3880d1 TB |
1021 | if (stat2 != NULL_TREE) |
1022 | gfc_add_modify (&se.pre, stat2, | |
1023 | fold_convert (TREE_TYPE (stat2), stat)); | |
1024 | ||
1025 | if (lock_acquired2 != NULL_TREE) | |
1026 | gfc_add_modify (&se.pre, lock_acquired2, | |
1027 | fold_convert (TREE_TYPE (lock_acquired2), | |
1028 | lock_acquired)); | |
1029 | ||
1030 | return gfc_finish_block (&se.pre); | |
1031 | } | |
fea54935 TB |
1032 | |
1033 | if (stat != NULL_TREE) | |
1034 | gfc_add_modify (&se.pre, stat, build_int_cst (TREE_TYPE (stat), 0)); | |
1035 | ||
1036 | if (lock_acquired != NULL_TREE) | |
1037 | gfc_add_modify (&se.pre, lock_acquired, | |
1038 | fold_convert (TREE_TYPE (lock_acquired), | |
1039 | boolean_true_node)); | |
1040 | ||
1041 | return gfc_finish_block (&se.pre); | |
1042 | } | |
1043 | ||
5df445a2 TB |
1044 | tree |
1045 | gfc_trans_event_post_wait (gfc_code *code, gfc_exec_op op) | |
1046 | { | |
1047 | gfc_se se, argse; | |
1048 | tree stat = NULL_TREE, stat2 = NULL_TREE; | |
1049 | tree until_count = NULL_TREE; | |
1050 | ||
1051 | if (code->expr2) | |
1052 | { | |
1053 | gcc_assert (code->expr2->expr_type == EXPR_VARIABLE); | |
1054 | gfc_init_se (&argse, NULL); | |
1055 | gfc_conv_expr_val (&argse, code->expr2); | |
1056 | stat = argse.expr; | |
1057 | } | |
1058 | else if (flag_coarray == GFC_FCOARRAY_LIB) | |
1059 | stat = null_pointer_node; | |
1060 | ||
1061 | if (code->expr4) | |
1062 | { | |
1063 | gfc_init_se (&argse, NULL); | |
1064 | gfc_conv_expr_val (&argse, code->expr4); | |
1065 | until_count = fold_convert (integer_type_node, argse.expr); | |
1066 | } | |
1067 | else | |
1068 | until_count = integer_one_node; | |
1069 | ||
1070 | if (flag_coarray != GFC_FCOARRAY_LIB) | |
1071 | { | |
1072 | gfc_start_block (&se.pre); | |
1073 | gfc_init_se (&argse, NULL); | |
1074 | gfc_conv_expr_val (&argse, code->expr1); | |
1075 | ||
1076 | if (op == EXEC_EVENT_POST) | |
1077 | gfc_add_modify (&se.pre, argse.expr, | |
1078 | fold_build2_loc (input_location, PLUS_EXPR, | |
1079 | TREE_TYPE (argse.expr), argse.expr, | |
1080 | build_int_cst (TREE_TYPE (argse.expr), 1))); | |
1081 | else | |
1082 | gfc_add_modify (&se.pre, argse.expr, | |
1083 | fold_build2_loc (input_location, MINUS_EXPR, | |
1084 | TREE_TYPE (argse.expr), argse.expr, | |
1085 | fold_convert (TREE_TYPE (argse.expr), | |
1086 | until_count))); | |
1087 | if (stat != NULL_TREE) | |
1088 | gfc_add_modify (&se.pre, stat, build_int_cst (TREE_TYPE (stat), 0)); | |
1089 | ||
1090 | return gfc_finish_block (&se.pre); | |
1091 | } | |
1092 | ||
1093 | gfc_start_block (&se.pre); | |
1094 | tree tmp, token, image_index, errmsg, errmsg_len; | |
0f97b81b | 1095 | tree index = build_zero_cst (gfc_array_index_type); |
5df445a2 TB |
1096 | tree caf_decl = gfc_get_tree_for_caf_expr (code->expr1); |
1097 | ||
1098 | if (code->expr1->symtree->n.sym->ts.type != BT_DERIVED | |
1099 | || code->expr1->symtree->n.sym->ts.u.derived->from_intmod | |
1100 | != INTMOD_ISO_FORTRAN_ENV | |
1101 | || code->expr1->symtree->n.sym->ts.u.derived->intmod_sym_id | |
1102 | != ISOFORTRAN_EVENT_TYPE) | |
1103 | { | |
1104 | gfc_error ("Sorry, the event component of derived type at %L is not " | |
1105 | "yet supported", &code->expr1->where); | |
1106 | return NULL_TREE; | |
1107 | } | |
1108 | ||
3c9f5092 AV |
1109 | gfc_init_se (&argse, NULL); |
1110 | gfc_get_caf_token_offset (&argse, &token, NULL, caf_decl, NULL_TREE, | |
1111 | code->expr1); | |
1112 | gfc_add_block_to_block (&se.pre, &argse.pre); | |
5df445a2 TB |
1113 | |
1114 | if (gfc_is_coindexed (code->expr1)) | |
1115 | image_index = gfc_caf_get_image_index (&se.pre, code->expr1, caf_decl); | |
1116 | else | |
1117 | image_index = integer_zero_node; | |
1118 | ||
1119 | /* For arrays, obtain the array index. */ | |
1120 | if (gfc_expr_attr (code->expr1).dimension) | |
1121 | { | |
1122 | tree desc, tmp, extent, lbound, ubound; | |
1123 | gfc_array_ref *ar, ar2; | |
1124 | int i; | |
1125 | ||
1126 | /* TODO: Extend this, once DT components are supported. */ | |
1127 | ar = &code->expr1->ref->u.ar; | |
1128 | ar2 = *ar; | |
1129 | memset (ar, '\0', sizeof (*ar)); | |
1130 | ar->as = ar2.as; | |
1131 | ar->type = AR_FULL; | |
1132 | ||
1133 | gfc_init_se (&argse, NULL); | |
1134 | argse.descriptor_only = 1; | |
1135 | gfc_conv_expr_descriptor (&argse, code->expr1); | |
1136 | gfc_add_block_to_block (&se.pre, &argse.pre); | |
1137 | desc = argse.expr; | |
1138 | *ar = ar2; | |
1139 | ||
0f97b81b | 1140 | extent = build_one_cst (gfc_array_index_type); |
5df445a2 TB |
1141 | for (i = 0; i < ar->dimen; i++) |
1142 | { | |
1143 | gfc_init_se (&argse, NULL); | |
0f97b81b | 1144 | gfc_conv_expr_type (&argse, ar->start[i], gfc_array_index_type); |
5df445a2 TB |
1145 | gfc_add_block_to_block (&argse.pre, &argse.pre); |
1146 | lbound = gfc_conv_descriptor_lbound_get (desc, gfc_rank_cst[i]); | |
1147 | tmp = fold_build2_loc (input_location, MINUS_EXPR, | |
0f97b81b | 1148 | TREE_TYPE (lbound), argse.expr, lbound); |
5df445a2 | 1149 | tmp = fold_build2_loc (input_location, MULT_EXPR, |
0f97b81b | 1150 | TREE_TYPE (tmp), extent, tmp); |
5df445a2 | 1151 | index = fold_build2_loc (input_location, PLUS_EXPR, |
0f97b81b | 1152 | TREE_TYPE (tmp), index, tmp); |
5df445a2 TB |
1153 | if (i < ar->dimen - 1) |
1154 | { | |
1155 | ubound = gfc_conv_descriptor_ubound_get (desc, gfc_rank_cst[i]); | |
1156 | tmp = gfc_conv_array_extent_dim (lbound, ubound, NULL); | |
5df445a2 | 1157 | extent = fold_build2_loc (input_location, MULT_EXPR, |
0f97b81b | 1158 | TREE_TYPE (tmp), extent, tmp); |
5df445a2 TB |
1159 | } |
1160 | } | |
1161 | } | |
1162 | ||
1163 | /* errmsg. */ | |
1164 | if (code->expr3) | |
1165 | { | |
1166 | gfc_init_se (&argse, NULL); | |
1167 | argse.want_pointer = 1; | |
1168 | gfc_conv_expr (&argse, code->expr3); | |
1169 | gfc_add_block_to_block (&se.pre, &argse.pre); | |
1170 | errmsg = argse.expr; | |
3f5fabc0 | 1171 | errmsg_len = fold_convert (size_type_node, argse.string_length); |
5df445a2 TB |
1172 | } |
1173 | else | |
1174 | { | |
1175 | errmsg = null_pointer_node; | |
3f5fabc0 | 1176 | errmsg_len = build_zero_cst (size_type_node); |
5df445a2 TB |
1177 | } |
1178 | ||
1179 | if (stat != null_pointer_node && TREE_TYPE (stat) != integer_type_node) | |
1180 | { | |
1181 | stat2 = stat; | |
1182 | stat = gfc_create_var (integer_type_node, "stat"); | |
1183 | } | |
1184 | ||
cbd29d0e | 1185 | index = fold_convert (size_type_node, index); |
5df445a2 TB |
1186 | if (op == EXEC_EVENT_POST) |
1187 | tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_event_post, 6, | |
1188 | token, index, image_index, | |
1189 | stat != null_pointer_node | |
1190 | ? gfc_build_addr_expr (NULL, stat) : stat, | |
1191 | errmsg, errmsg_len); | |
1192 | else | |
1193 | tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_event_wait, 6, | |
1194 | token, index, until_count, | |
1195 | stat != null_pointer_node | |
1196 | ? gfc_build_addr_expr (NULL, stat) : stat, | |
1197 | errmsg, errmsg_len); | |
1198 | gfc_add_expr_to_block (&se.pre, tmp); | |
1199 | ||
985f6c79 TB |
1200 | /* It guarantees memory consistency within the same segment */ |
1201 | tmp = gfc_build_string_const (strlen ("memory")+1, "memory"), | |
1202 | tmp = build5_loc (input_location, ASM_EXPR, void_type_node, | |
1203 | gfc_build_string_const (1, ""), NULL_TREE, NULL_TREE, | |
1204 | tree_cons (NULL_TREE, tmp, NULL_TREE), NULL_TREE); | |
1205 | ASM_VOLATILE_P (tmp) = 1; | |
1206 | gfc_add_expr_to_block (&se.pre, tmp); | |
1207 | ||
5df445a2 TB |
1208 | if (stat2 != NULL_TREE) |
1209 | gfc_add_modify (&se.pre, stat2, fold_convert (TREE_TYPE (stat2), stat)); | |
1210 | ||
1211 | return gfc_finish_block (&se.pre); | |
1212 | } | |
fea54935 | 1213 | |
d0a4a61c | 1214 | tree |
60386f50 | 1215 | gfc_trans_sync (gfc_code *code, gfc_exec_op type) |
d0a4a61c | 1216 | { |
60386f50 TB |
1217 | gfc_se se, argse; |
1218 | tree tmp; | |
1219 | tree images = NULL_TREE, stat = NULL_TREE, | |
1220 | errmsg = NULL_TREE, errmsglen = NULL_TREE; | |
d0a4a61c | 1221 | |
60386f50 TB |
1222 | /* Short cut: For single images without bound checking or without STAT=, |
1223 | return early. (ERRMSG= is always untouched for -fcoarray=single.) */ | |
1224 | if (!code->expr2 && !(gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) | |
f19626cf | 1225 | && flag_coarray != GFC_FCOARRAY_LIB) |
8b704316 | 1226 | return NULL_TREE; |
60386f50 TB |
1227 | |
1228 | gfc_init_se (&se, NULL); | |
1229 | gfc_start_block (&se.pre); | |
1230 | ||
1231 | if (code->expr1 && code->expr1->rank == 0) | |
d0a4a61c | 1232 | { |
60386f50 TB |
1233 | gfc_init_se (&argse, NULL); |
1234 | gfc_conv_expr_val (&argse, code->expr1); | |
1235 | images = argse.expr; | |
1236 | } | |
1237 | ||
1238 | if (code->expr2) | |
1239 | { | |
bbf19f9c HA |
1240 | gcc_assert (code->expr2->expr_type == EXPR_VARIABLE |
1241 | || code->expr2->expr_type == EXPR_FUNCTION); | |
60386f50 TB |
1242 | gfc_init_se (&argse, NULL); |
1243 | gfc_conv_expr_val (&argse, code->expr2); | |
1244 | stat = argse.expr; | |
1245 | } | |
f5c01f5b DC |
1246 | else |
1247 | stat = null_pointer_node; | |
60386f50 | 1248 | |
9315dff0 | 1249 | if (code->expr3 && flag_coarray == GFC_FCOARRAY_LIB) |
60386f50 | 1250 | { |
bbf19f9c HA |
1251 | gcc_assert (code->expr3->expr_type == EXPR_VARIABLE |
1252 | || code->expr3->expr_type == EXPR_FUNCTION); | |
60386f50 | 1253 | gfc_init_se (&argse, NULL); |
5df445a2 | 1254 | argse.want_pointer = 1; |
60386f50 TB |
1255 | gfc_conv_expr (&argse, code->expr3); |
1256 | gfc_conv_string_parameter (&argse); | |
f5c01f5b | 1257 | errmsg = gfc_build_addr_expr (NULL, argse.expr); |
3f5fabc0 | 1258 | errmsglen = fold_convert (size_type_node, argse.string_length); |
60386f50 | 1259 | } |
9315dff0 | 1260 | else if (flag_coarray == GFC_FCOARRAY_LIB) |
60386f50 TB |
1261 | { |
1262 | errmsg = null_pointer_node; | |
3f5fabc0 | 1263 | errmsglen = build_int_cst (size_type_node, 0); |
d0a4a61c TB |
1264 | } |
1265 | ||
1266 | /* Check SYNC IMAGES(imageset) for valid image index. | |
1cc0e193 | 1267 | FIXME: Add a check for image-set arrays. */ |
d0a4a61c TB |
1268 | if (code->expr1 && (gfc_option.rtcheck & GFC_RTCHECK_BOUNDS) |
1269 | && code->expr1->rank == 0) | |
1270 | { | |
e6cc67f6 | 1271 | tree images2 = fold_convert (integer_type_node, images); |
d0a4a61c | 1272 | tree cond; |
f19626cf | 1273 | if (flag_coarray != GFC_FCOARRAY_LIB) |
63ee5404 | 1274 | cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node, |
60386f50 TB |
1275 | images, build_int_cst (TREE_TYPE (images), 1)); |
1276 | else | |
1277 | { | |
1278 | tree cond2; | |
a8a5f4a9 TB |
1279 | tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_num_images, |
1280 | 2, integer_zero_node, | |
1281 | build_int_cst (integer_type_node, -1)); | |
63ee5404 | 1282 | cond = fold_build2_loc (input_location, GT_EXPR, logical_type_node, |
e6cc67f6 | 1283 | images2, tmp); |
63ee5404 | 1284 | cond2 = fold_build2_loc (input_location, LT_EXPR, logical_type_node, |
60386f50 TB |
1285 | images, |
1286 | build_int_cst (TREE_TYPE (images), 1)); | |
45d5889a | 1287 | cond = fold_build2_loc (input_location, TRUTH_OR_EXPR, |
63ee5404 | 1288 | logical_type_node, cond, cond2); |
60386f50 | 1289 | } |
d0a4a61c TB |
1290 | gfc_trans_runtime_check (true, false, cond, &se.pre, |
1291 | &code->expr1->where, "Invalid image number " | |
e6cc67f6 | 1292 | "%d in SYNC IMAGES", images2); |
d0a4a61c TB |
1293 | } |
1294 | ||
985f6c79 TB |
1295 | /* Per F2008, 8.5.1, a SYNC MEMORY is implied by calling the |
1296 | image control statements SYNC IMAGES and SYNC ALL. */ | |
1297 | if (flag_coarray == GFC_FCOARRAY_LIB) | |
1298 | { | |
1299 | tmp = gfc_build_string_const (strlen ("memory")+1, "memory"), | |
1300 | tmp = build5_loc (input_location, ASM_EXPR, void_type_node, | |
1301 | gfc_build_string_const (1, ""), NULL_TREE, NULL_TREE, | |
1302 | tree_cons (NULL_TREE, tmp, NULL_TREE), NULL_TREE); | |
1303 | ASM_VOLATILE_P (tmp) = 1; | |
1304 | gfc_add_expr_to_block (&se.pre, tmp); | |
1305 | } | |
1306 | ||
9315dff0 | 1307 | if (flag_coarray != GFC_FCOARRAY_LIB) |
d0a4a61c | 1308 | { |
60386f50 TB |
1309 | /* Set STAT to zero. */ |
1310 | if (code->expr2) | |
1311 | gfc_add_modify (&se.pre, stat, build_int_cst (TREE_TYPE (stat), 0)); | |
1312 | } | |
9315dff0 | 1313 | else if (type == EXEC_SYNC_ALL || type == EXEC_SYNC_MEMORY) |
60386f50 | 1314 | { |
f5c01f5b DC |
1315 | /* SYNC ALL => stat == null_pointer_node |
1316 | SYNC ALL(stat=s) => stat has an integer type | |
1317 | ||
1318 | If "stat" has the wrong integer type, use a temp variable of | |
1319 | the right type and later cast the result back into "stat". */ | |
1320 | if (stat == null_pointer_node || TREE_TYPE (stat) == integer_type_node) | |
1321 | { | |
1322 | if (TREE_TYPE (stat) == integer_type_node) | |
1323 | stat = gfc_build_addr_expr (NULL, stat); | |
8b704316 | 1324 | |
9315dff0 AF |
1325 | if(type == EXEC_SYNC_MEMORY) |
1326 | tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_sync_memory, | |
1327 | 3, stat, errmsg, errmsglen); | |
1328 | else | |
1329 | tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_sync_all, | |
1330 | 3, stat, errmsg, errmsglen); | |
1331 | ||
f5c01f5b DC |
1332 | gfc_add_expr_to_block (&se.pre, tmp); |
1333 | } | |
60386f50 | 1334 | else |
f5c01f5b DC |
1335 | { |
1336 | tree tmp_stat = gfc_create_var (integer_type_node, "stat"); | |
1337 | ||
1338 | tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_sync_all, | |
1339 | 3, gfc_build_addr_expr (NULL, tmp_stat), | |
1340 | errmsg, errmsglen); | |
1341 | gfc_add_expr_to_block (&se.pre, tmp); | |
8b704316 | 1342 | |
f5c01f5b DC |
1343 | gfc_add_modify (&se.pre, stat, |
1344 | fold_convert (TREE_TYPE (stat), tmp_stat)); | |
1345 | } | |
60386f50 TB |
1346 | } |
1347 | else | |
1348 | { | |
1349 | tree len; | |
1350 | ||
1351 | gcc_assert (type == EXEC_SYNC_IMAGES); | |
1352 | ||
1353 | if (!code->expr1) | |
1354 | { | |
1355 | len = build_int_cst (integer_type_node, -1); | |
1356 | images = null_pointer_node; | |
1357 | } | |
1358 | else if (code->expr1->rank == 0) | |
1359 | { | |
59067ddf | 1360 | len = integer_one_node; |
60386f50 TB |
1361 | images = gfc_build_addr_expr (NULL_TREE, images); |
1362 | } | |
1363 | else | |
1364 | { | |
1365 | /* FIXME. */ | |
1366 | if (code->expr1->ts.kind != gfc_c_int_kind) | |
29e0597e TB |
1367 | gfc_fatal_error ("Sorry, only support for integer kind %d " |
1368 | "implemented for image-set at %L", | |
1369 | gfc_c_int_kind, &code->expr1->where); | |
60386f50 | 1370 | |
2960a368 | 1371 | gfc_conv_array_parameter (&se, code->expr1, true, NULL, NULL, &len); |
60386f50 TB |
1372 | images = se.expr; |
1373 | ||
1374 | tmp = gfc_typenode_for_spec (&code->expr1->ts); | |
1375 | if (GFC_ARRAY_TYPE_P (tmp) || GFC_DESCRIPTOR_TYPE_P (tmp)) | |
1376 | tmp = gfc_get_element_type (tmp); | |
1377 | ||
1378 | len = fold_build2_loc (input_location, TRUNC_DIV_EXPR, | |
1379 | TREE_TYPE (len), len, | |
1380 | fold_convert (TREE_TYPE (len), | |
1381 | TYPE_SIZE_UNIT (tmp))); | |
1382 | len = fold_convert (integer_type_node, len); | |
1383 | } | |
1384 | ||
f5c01f5b DC |
1385 | /* SYNC IMAGES(imgs) => stat == null_pointer_node |
1386 | SYNC IMAGES(imgs,stat=s) => stat has an integer type | |
1387 | ||
1388 | If "stat" has the wrong integer type, use a temp variable of | |
1389 | the right type and later cast the result back into "stat". */ | |
1390 | if (stat == null_pointer_node || TREE_TYPE (stat) == integer_type_node) | |
1391 | { | |
1392 | if (TREE_TYPE (stat) == integer_type_node) | |
1393 | stat = gfc_build_addr_expr (NULL, stat); | |
1394 | ||
8b704316 | 1395 | tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_sync_images, |
f5c01f5b DC |
1396 | 5, fold_convert (integer_type_node, len), |
1397 | images, stat, errmsg, errmsglen); | |
1398 | gfc_add_expr_to_block (&se.pre, tmp); | |
1399 | } | |
60386f50 | 1400 | else |
f5c01f5b DC |
1401 | { |
1402 | tree tmp_stat = gfc_create_var (integer_type_node, "stat"); | |
1403 | ||
8b704316 | 1404 | tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_sync_images, |
f5c01f5b DC |
1405 | 5, fold_convert (integer_type_node, len), |
1406 | images, gfc_build_addr_expr (NULL, tmp_stat), | |
1407 | errmsg, errmsglen); | |
1408 | gfc_add_expr_to_block (&se.pre, tmp); | |
1409 | ||
8b704316 | 1410 | gfc_add_modify (&se.pre, stat, |
f5c01f5b DC |
1411 | fold_convert (TREE_TYPE (stat), tmp_stat)); |
1412 | } | |
d0a4a61c TB |
1413 | } |
1414 | ||
60386f50 | 1415 | return gfc_finish_block (&se.pre); |
d0a4a61c TB |
1416 | } |
1417 | ||
1418 | ||
6de9cd9a DN |
1419 | /* Generate GENERIC for the IF construct. This function also deals with |
1420 | the simple IF statement, because the front end translates the IF | |
1421 | statement into an IF construct. | |
1422 | ||
1423 | We translate: | |
1424 | ||
1425 | IF (cond) THEN | |
1426 | then_clause | |
1427 | ELSEIF (cond2) | |
1428 | elseif_clause | |
1429 | ELSE | |
1430 | else_clause | |
1431 | ENDIF | |
1432 | ||
1433 | into: | |
1434 | ||
1435 | pre_cond_s; | |
1436 | if (cond_s) | |
1437 | { | |
1438 | then_clause; | |
1439 | } | |
1440 | else | |
1441 | { | |
1442 | pre_cond_s | |
1443 | if (cond_s) | |
1444 | { | |
1445 | elseif_clause | |
1446 | } | |
1447 | else | |
1448 | { | |
1449 | else_clause; | |
1450 | } | |
1451 | } | |
1452 | ||
1453 | where COND_S is the simplified version of the predicate. PRE_COND_S | |
1454 | are the pre side-effects produced by the translation of the | |
1455 | conditional. | |
1456 | We need to build the chain recursively otherwise we run into | |
1457 | problems with folding incomplete statements. */ | |
1458 | ||
1459 | static tree | |
1460 | gfc_trans_if_1 (gfc_code * code) | |
1461 | { | |
1462 | gfc_se if_se; | |
1463 | tree stmt, elsestmt; | |
e84589e1 | 1464 | locus saved_loc; |
55bd9c35 | 1465 | location_t loc; |
6de9cd9a DN |
1466 | |
1467 | /* Check for an unconditional ELSE clause. */ | |
a513927a | 1468 | if (!code->expr1) |
6de9cd9a DN |
1469 | return gfc_trans_code (code->next); |
1470 | ||
1471 | /* Initialize a statement builder for each block. Puts in NULL_TREEs. */ | |
1472 | gfc_init_se (&if_se, NULL); | |
1473 | gfc_start_block (&if_se.pre); | |
1474 | ||
1475 | /* Calculate the IF condition expression. */ | |
e84589e1 TB |
1476 | if (code->expr1->where.lb) |
1477 | { | |
1478 | gfc_save_backend_locus (&saved_loc); | |
1479 | gfc_set_backend_locus (&code->expr1->where); | |
1480 | } | |
1481 | ||
a513927a | 1482 | gfc_conv_expr_val (&if_se, code->expr1); |
6de9cd9a | 1483 | |
e84589e1 TB |
1484 | if (code->expr1->where.lb) |
1485 | gfc_restore_backend_locus (&saved_loc); | |
1486 | ||
6de9cd9a DN |
1487 | /* Translate the THEN clause. */ |
1488 | stmt = gfc_trans_code (code->next); | |
1489 | ||
1490 | /* Translate the ELSE clause. */ | |
1491 | if (code->block) | |
1492 | elsestmt = gfc_trans_if_1 (code->block); | |
1493 | else | |
c2255bc4 | 1494 | elsestmt = build_empty_stmt (input_location); |
6de9cd9a DN |
1495 | |
1496 | /* Build the condition expression and add it to the condition block. */ | |
9c81750c TB |
1497 | loc = code->expr1->where.lb ? gfc_get_location (&code->expr1->where) |
1498 | : input_location; | |
55bd9c35 TB |
1499 | stmt = fold_build3_loc (loc, COND_EXPR, void_type_node, if_se.expr, stmt, |
1500 | elsestmt); | |
8b704316 | 1501 | |
6de9cd9a DN |
1502 | gfc_add_expr_to_block (&if_se.pre, stmt); |
1503 | ||
1504 | /* Finish off this statement. */ | |
1505 | return gfc_finish_block (&if_se.pre); | |
1506 | } | |
1507 | ||
1508 | tree | |
1509 | gfc_trans_if (gfc_code * code) | |
1510 | { | |
e5ca9693 DK |
1511 | stmtblock_t body; |
1512 | tree exit_label; | |
1513 | ||
1514 | /* Create exit label so it is available for trans'ing the body code. */ | |
1515 | exit_label = gfc_build_label_decl (NULL_TREE); | |
1516 | code->exit_label = exit_label; | |
1517 | ||
1518 | /* Translate the actual code in code->block. */ | |
1519 | gfc_init_block (&body); | |
1520 | gfc_add_expr_to_block (&body, gfc_trans_if_1 (code->block)); | |
1521 | ||
1522 | /* Add exit label. */ | |
1523 | gfc_add_expr_to_block (&body, build1_v (LABEL_EXPR, exit_label)); | |
6de9cd9a | 1524 | |
e5ca9693 | 1525 | return gfc_finish_block (&body); |
6de9cd9a DN |
1526 | } |
1527 | ||
1528 | ||
fa951694 | 1529 | /* Translate an arithmetic IF expression. |
6de9cd9a DN |
1530 | |
1531 | IF (cond) label1, label2, label3 translates to | |
1532 | ||
1533 | if (cond <= 0) | |
1534 | { | |
1535 | if (cond < 0) | |
1536 | goto label1; | |
1537 | else // cond == 0 | |
1538 | goto label2; | |
1539 | } | |
1540 | else // cond > 0 | |
1541 | goto label3; | |
442c1644 CY |
1542 | |
1543 | An optimized version can be generated in case of equal labels. | |
1544 | E.g., if label1 is equal to label2, we can translate it to | |
1545 | ||
1546 | if (cond <= 0) | |
1547 | goto label1; | |
1548 | else | |
1549 | goto label3; | |
6de9cd9a DN |
1550 | */ |
1551 | ||
1552 | tree | |
1553 | gfc_trans_arithmetic_if (gfc_code * code) | |
1554 | { | |
1555 | gfc_se se; | |
1556 | tree tmp; | |
1557 | tree branch1; | |
1558 | tree branch2; | |
1559 | tree zero; | |
1560 | ||
1561 | /* Start a new block. */ | |
1562 | gfc_init_se (&se, NULL); | |
1563 | gfc_start_block (&se.pre); | |
1564 | ||
1565 | /* Pre-evaluate COND. */ | |
a513927a | 1566 | gfc_conv_expr_val (&se, code->expr1); |
5ec1334b | 1567 | se.expr = gfc_evaluate_now (se.expr, &se.pre); |
6de9cd9a DN |
1568 | |
1569 | /* Build something to compare with. */ | |
1570 | zero = gfc_build_const (TREE_TYPE (se.expr), integer_zero_node); | |
1571 | ||
79bd1948 | 1572 | if (code->label1->value != code->label2->value) |
442c1644 CY |
1573 | { |
1574 | /* If (cond < 0) take branch1 else take branch2. | |
1575 | First build jumps to the COND .LT. 0 and the COND .EQ. 0 cases. */ | |
79bd1948 | 1576 | branch1 = build1_v (GOTO_EXPR, gfc_get_label_decl (code->label1)); |
442c1644 CY |
1577 | branch2 = build1_v (GOTO_EXPR, gfc_get_label_decl (code->label2)); |
1578 | ||
79bd1948 | 1579 | if (code->label1->value != code->label3->value) |
63ee5404 | 1580 | tmp = fold_build2_loc (input_location, LT_EXPR, logical_type_node, |
bc98ed60 | 1581 | se.expr, zero); |
442c1644 | 1582 | else |
63ee5404 | 1583 | tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node, |
bc98ed60 | 1584 | se.expr, zero); |
6de9cd9a | 1585 | |
bc98ed60 TB |
1586 | branch1 = fold_build3_loc (input_location, COND_EXPR, void_type_node, |
1587 | tmp, branch1, branch2); | |
442c1644 CY |
1588 | } |
1589 | else | |
79bd1948 | 1590 | branch1 = build1_v (GOTO_EXPR, gfc_get_label_decl (code->label1)); |
6de9cd9a | 1591 | |
79bd1948 | 1592 | if (code->label1->value != code->label3->value |
442c1644 CY |
1593 | && code->label2->value != code->label3->value) |
1594 | { | |
1595 | /* if (cond <= 0) take branch1 else take branch2. */ | |
1596 | branch2 = build1_v (GOTO_EXPR, gfc_get_label_decl (code->label3)); | |
63ee5404 | 1597 | tmp = fold_build2_loc (input_location, LE_EXPR, logical_type_node, |
bc98ed60 TB |
1598 | se.expr, zero); |
1599 | branch1 = fold_build3_loc (input_location, COND_EXPR, void_type_node, | |
1600 | tmp, branch1, branch2); | |
442c1644 | 1601 | } |
6de9cd9a DN |
1602 | |
1603 | /* Append the COND_EXPR to the evaluation of COND, and return. */ | |
1604 | gfc_add_expr_to_block (&se.pre, branch1); | |
1605 | return gfc_finish_block (&se.pre); | |
1606 | } | |
1607 | ||
1608 | ||
1cc0e193 | 1609 | /* Translate a CRITICAL block. */ |
d0a4a61c TB |
1610 | tree |
1611 | gfc_trans_critical (gfc_code *code) | |
1612 | { | |
1613 | stmtblock_t block; | |
bc0229f9 | 1614 | tree tmp, token = NULL_TREE; |
d0a4a61c TB |
1615 | |
1616 | gfc_start_block (&block); | |
60386f50 | 1617 | |
f19626cf | 1618 | if (flag_coarray == GFC_FCOARRAY_LIB) |
60386f50 | 1619 | { |
0f09fc8a | 1620 | tree zero_size = build_zero_cst (size_type_node); |
bc0229f9 TB |
1621 | token = gfc_get_symbol_decl (code->resolved_sym); |
1622 | token = GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (token)); | |
1623 | tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_lock, 7, | |
0f09fc8a | 1624 | token, zero_size, integer_one_node, |
9de8e7af | 1625 | null_pointer_node, null_pointer_node, |
0f09fc8a | 1626 | null_pointer_node, zero_size); |
60386f50 | 1627 | gfc_add_expr_to_block (&block, tmp); |
985f6c79 TB |
1628 | |
1629 | /* It guarantees memory consistency within the same segment */ | |
1630 | tmp = gfc_build_string_const (strlen ("memory")+1, "memory"), | |
1631 | tmp = build5_loc (input_location, ASM_EXPR, void_type_node, | |
1632 | gfc_build_string_const (1, ""), | |
1633 | NULL_TREE, NULL_TREE, | |
1634 | tree_cons (NULL_TREE, tmp, NULL_TREE), | |
1635 | NULL_TREE); | |
1636 | ASM_VOLATILE_P (tmp) = 1; | |
afbc5ae8 | 1637 | |
985f6c79 | 1638 | gfc_add_expr_to_block (&block, tmp); |
60386f50 TB |
1639 | } |
1640 | ||
d0a4a61c TB |
1641 | tmp = gfc_trans_code (code->block->next); |
1642 | gfc_add_expr_to_block (&block, tmp); | |
1643 | ||
f19626cf | 1644 | if (flag_coarray == GFC_FCOARRAY_LIB) |
60386f50 | 1645 | { |
0f09fc8a | 1646 | tree zero_size = build_zero_cst (size_type_node); |
bc0229f9 | 1647 | tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_unlock, 6, |
0f09fc8a | 1648 | token, zero_size, integer_one_node, |
bc0229f9 | 1649 | null_pointer_node, null_pointer_node, |
0f09fc8a | 1650 | zero_size); |
60386f50 | 1651 | gfc_add_expr_to_block (&block, tmp); |
60386f50 | 1652 | |
985f6c79 TB |
1653 | /* It guarantees memory consistency within the same segment */ |
1654 | tmp = gfc_build_string_const (strlen ("memory")+1, "memory"), | |
1655 | tmp = build5_loc (input_location, ASM_EXPR, void_type_node, | |
1656 | gfc_build_string_const (1, ""), | |
1657 | NULL_TREE, NULL_TREE, | |
1658 | tree_cons (NULL_TREE, tmp, NULL_TREE), | |
1659 | NULL_TREE); | |
1660 | ASM_VOLATILE_P (tmp) = 1; | |
1661 | ||
1662 | gfc_add_expr_to_block (&block, tmp); | |
1663 | } | |
60386f50 | 1664 | |
d0a4a61c TB |
1665 | return gfc_finish_block (&block); |
1666 | } | |
1667 | ||
1668 | ||
5b384b3d PT |
1669 | /* Return true, when the class has a _len component. */ |
1670 | ||
1671 | static bool | |
1672 | class_has_len_component (gfc_symbol *sym) | |
1673 | { | |
1674 | gfc_component *comp = sym->ts.u.derived->components; | |
1675 | while (comp) | |
1676 | { | |
1677 | if (strcmp (comp->name, "_len") == 0) | |
1678 | return true; | |
1679 | comp = comp->next; | |
1680 | } | |
1681 | return false; | |
1682 | } | |
1683 | ||
1684 | ||
70570ec1 PT |
1685 | static void |
1686 | copy_descriptor (stmtblock_t *block, tree dst, tree src, int rank) | |
1687 | { | |
1688 | int n; | |
1689 | tree dim; | |
1690 | tree tmp; | |
1691 | tree tmp2; | |
1692 | tree size; | |
1693 | tree offset; | |
1694 | ||
1695 | offset = gfc_index_zero_node; | |
1696 | ||
1697 | /* Use memcpy to copy the descriptor. The size is the minimum of | |
1698 | the sizes of 'src' and 'dst'. This avoids a non-trivial conversion. */ | |
1699 | tmp = TYPE_SIZE_UNIT (TREE_TYPE (src)); | |
1700 | tmp2 = TYPE_SIZE_UNIT (TREE_TYPE (dst)); | |
1701 | size = fold_build2_loc (input_location, MIN_EXPR, | |
1702 | TREE_TYPE (tmp), tmp, tmp2); | |
1703 | tmp = builtin_decl_explicit (BUILT_IN_MEMCPY); | |
1704 | tmp = build_call_expr_loc (input_location, tmp, 3, | |
1705 | gfc_build_addr_expr (NULL_TREE, dst), | |
1706 | gfc_build_addr_expr (NULL_TREE, src), | |
1707 | fold_convert (size_type_node, size)); | |
1708 | gfc_add_expr_to_block (block, tmp); | |
1709 | ||
1710 | /* Set the offset correctly. */ | |
1711 | for (n = 0; n < rank; n++) | |
1712 | { | |
1713 | dim = gfc_rank_cst[n]; | |
1714 | tmp = gfc_conv_descriptor_lbound_get (src, dim); | |
1715 | tmp2 = gfc_conv_descriptor_stride_get (src, dim); | |
1716 | tmp = fold_build2_loc (input_location, MULT_EXPR, TREE_TYPE (tmp), | |
1717 | tmp, tmp2); | |
1718 | offset = fold_build2_loc (input_location, MINUS_EXPR, | |
1719 | TREE_TYPE (offset), offset, tmp); | |
1720 | offset = gfc_evaluate_now (offset, block); | |
1721 | } | |
1722 | ||
1723 | gfc_conv_descriptor_offset_set (block, dst, offset); | |
1724 | } | |
1725 | ||
1726 | ||
6312ef45 JW |
1727 | /* Do proper initialization for ASSOCIATE names. */ |
1728 | ||
1729 | static void | |
1730 | trans_associate_var (gfc_symbol *sym, gfc_wrapped_block *block) | |
1731 | { | |
1732 | gfc_expr *e; | |
1733 | tree tmp; | |
c49ea23d | 1734 | bool class_target; |
8b704316 | 1735 | bool unlimited; |
8f75db9f PT |
1736 | tree desc; |
1737 | tree offset; | |
1738 | tree dim; | |
1739 | int n; | |
5b384b3d PT |
1740 | tree charlen; |
1741 | bool need_len_assign; | |
ff3598bc PT |
1742 | bool whole_array = true; |
1743 | gfc_ref *ref; | |
70570ec1 | 1744 | gfc_symbol *sym2; |
6312ef45 JW |
1745 | |
1746 | gcc_assert (sym->assoc); | |
1747 | e = sym->assoc->target; | |
1748 | ||
c49ea23d | 1749 | class_target = (e->expr_type == EXPR_VARIABLE) |
3fd46d85 PT |
1750 | && e->ts.type == BT_CLASS |
1751 | && (gfc_is_class_scalar_expr (e) | |
1752 | || gfc_is_class_array_ref (e, NULL)); | |
c49ea23d | 1753 | |
8b704316 PT |
1754 | unlimited = UNLIMITED_POLY (e); |
1755 | ||
ff3598bc PT |
1756 | for (ref = e->ref; ref; ref = ref->next) |
1757 | if (ref->type == REF_ARRAY | |
1758 | && ref->u.ar.type == AR_FULL | |
1759 | && ref->next) | |
1760 | { | |
1761 | whole_array = false; | |
1762 | break; | |
1763 | } | |
1764 | ||
5b384b3d PT |
1765 | /* Assignments to the string length need to be generated, when |
1766 | ( sym is a char array or | |
1767 | sym has a _len component) | |
1768 | and the associated expression is unlimited polymorphic, which is | |
1769 | not (yet) correctly in 'unlimited', because for an already associated | |
1770 | BT_DERIVED the u-poly flag is not set, i.e., | |
1771 | __tmp_CHARACTER_0_1 => w => arg | |
1772 | ^ generated temp ^ from code, the w does not have the u-poly | |
1773 | flag set, where UNLIMITED_POLY(e) expects it. */ | |
1774 | need_len_assign = ((unlimited || (e->ts.type == BT_DERIVED | |
1775 | && e->ts.u.derived->attr.unlimited_polymorphic)) | |
1776 | && (sym->ts.type == BT_CHARACTER | |
1777 | || ((sym->ts.type == BT_CLASS || sym->ts.type == BT_DERIVED) | |
70570ec1 PT |
1778 | && class_has_len_component (sym))) |
1779 | && !sym->attr.select_rank_temporary); | |
1780 | ||
6312ef45 JW |
1781 | /* Do a `pointer assignment' with updated descriptor (or assign descriptor |
1782 | to array temporary) for arrays with either unknown shape or if associating | |
70570ec1 PT |
1783 | to a variable. Select rank temporaries need somewhat different treatment |
1784 | to other associate names and case temporaries. This because the selector | |
1785 | is assumed rank and so the offset in particular has to be changed. Also, | |
1786 | the case temporaries carry both allocatable and target attributes if | |
1787 | present in the selector. This means that an allocatation or change of | |
1788 | association can occur and so has to be dealt with. */ | |
1789 | if (sym->attr.select_rank_temporary) | |
1790 | { | |
1791 | gfc_se se; | |
1792 | tree class_decl = NULL_TREE; | |
1793 | int rank = 0; | |
1794 | bool class_ptr; | |
1795 | ||
1796 | sym2 = e->symtree->n.sym; | |
1797 | gfc_init_se (&se, NULL); | |
1798 | if (e->ts.type == BT_CLASS) | |
1799 | { | |
1800 | /* Go straight to the class data. */ | |
c4a67898 | 1801 | if (sym2->attr.dummy && !sym2->attr.optional) |
70570ec1 | 1802 | { |
8fa9e73e SL |
1803 | class_decl = sym2->backend_decl; |
1804 | if (DECL_LANG_SPECIFIC (class_decl) | |
1805 | && GFC_DECL_SAVED_DESCRIPTOR (class_decl)) | |
1806 | class_decl = GFC_DECL_SAVED_DESCRIPTOR (class_decl); | |
70570ec1 PT |
1807 | if (POINTER_TYPE_P (TREE_TYPE (class_decl))) |
1808 | class_decl = build_fold_indirect_ref_loc (input_location, | |
1809 | class_decl); | |
1810 | gcc_assert (GFC_CLASS_TYPE_P (TREE_TYPE (class_decl))); | |
1811 | se.expr = gfc_class_data_get (class_decl); | |
1812 | } | |
1813 | else | |
1814 | { | |
1815 | class_decl = sym2->backend_decl; | |
1816 | gfc_conv_expr_descriptor (&se, e); | |
1817 | if (POINTER_TYPE_P (TREE_TYPE (se.expr))) | |
1818 | se.expr = build_fold_indirect_ref_loc (input_location, | |
1819 | se.expr); | |
1820 | } | |
1821 | ||
1822 | if (CLASS_DATA (sym)->as && CLASS_DATA (sym)->as->rank > 0) | |
1823 | rank = CLASS_DATA (sym)->as->rank; | |
1824 | } | |
1825 | else | |
1826 | { | |
1827 | gfc_conv_expr_descriptor (&se, e); | |
1828 | if (sym->as && sym->as->rank > 0) | |
1829 | rank = sym->as->rank; | |
1830 | } | |
1831 | ||
1832 | desc = sym->backend_decl; | |
1833 | ||
1834 | /* The SELECT TYPE mechanisms turn class temporaries into pointers, which | |
1835 | point to the selector. */ | |
1836 | class_ptr = class_decl != NULL_TREE && POINTER_TYPE_P (TREE_TYPE (desc)); | |
1837 | if (class_ptr) | |
1838 | { | |
1839 | tmp = gfc_create_var (TREE_TYPE (TREE_TYPE (desc)), "class"); | |
1840 | tmp = gfc_build_addr_expr (NULL, tmp); | |
1841 | gfc_add_modify (&se.pre, desc, tmp); | |
1842 | ||
1843 | tmp = gfc_class_vptr_get (class_decl); | |
1844 | gfc_add_modify (&se.pre, gfc_class_vptr_get (desc), tmp); | |
1845 | if (UNLIMITED_POLY (sym)) | |
1846 | gfc_add_modify (&se.pre, gfc_class_len_get (desc), | |
1847 | gfc_class_len_get (class_decl)); | |
1848 | ||
1849 | desc = gfc_class_data_get (desc); | |
1850 | } | |
1851 | ||
1852 | /* SELECT RANK temporaries can carry the allocatable and pointer | |
1853 | attributes so the selector descriptor must be copied in and | |
1854 | copied out. */ | |
1855 | if (rank > 0) | |
1856 | copy_descriptor (&se.pre, desc, se.expr, rank); | |
1857 | else | |
1858 | { | |
1859 | tmp = gfc_conv_descriptor_data_get (se.expr); | |
1860 | gfc_add_modify (&se.pre, desc, | |
1861 | fold_convert (TREE_TYPE (desc), tmp)); | |
1862 | } | |
1863 | ||
1864 | /* Deal with associate_name => selector. Class associate names are | |
1865 | treated in the same way as in SELECT TYPE. */ | |
1866 | sym2 = sym->assoc->target->symtree->n.sym; | |
1867 | if (sym2->assoc && sym->assoc->target && sym2->ts.type != BT_CLASS) | |
1868 | { | |
1869 | sym2 = sym2->assoc->target->symtree->n.sym; | |
1870 | se.expr = sym2->backend_decl; | |
1871 | ||
1872 | if (POINTER_TYPE_P (TREE_TYPE (se.expr))) | |
1873 | se.expr = build_fold_indirect_ref_loc (input_location, | |
1874 | se.expr); | |
1875 | } | |
1876 | ||
1877 | /* There could have been reallocation. Copy descriptor back to the | |
1878 | selector and update the offset. */ | |
1879 | if (sym->attr.allocatable || sym->attr.pointer | |
1880 | || (sym->ts.type == BT_CLASS | |
1881 | && (CLASS_DATA (sym)->attr.allocatable | |
1882 | || CLASS_DATA (sym)->attr.pointer))) | |
1883 | { | |
1884 | if (rank > 0) | |
1885 | copy_descriptor (&se.post, se.expr, desc, rank); | |
1886 | else | |
0313a84a | 1887 | gfc_conv_descriptor_data_set (&se.post, se.expr, desc); |
70570ec1 PT |
1888 | |
1889 | /* The dynamic type could have changed too. */ | |
1890 | if (sym->ts.type == BT_CLASS) | |
1891 | { | |
1892 | tmp = sym->backend_decl; | |
1893 | if (class_ptr) | |
1894 | tmp = build_fold_indirect_ref_loc (input_location, tmp); | |
1895 | gfc_add_modify (&se.post, gfc_class_vptr_get (class_decl), | |
1896 | gfc_class_vptr_get (tmp)); | |
1897 | if (UNLIMITED_POLY (sym)) | |
1898 | gfc_add_modify (&se.post, gfc_class_len_get (class_decl), | |
1899 | gfc_class_len_get (tmp)); | |
1900 | } | |
1901 | } | |
1902 | ||
1903 | tmp = gfc_finish_block (&se.post); | |
1904 | ||
1905 | gfc_add_init_cleanup (block, gfc_finish_block (&se.pre), tmp); | |
1906 | } | |
1907 | /* Now all the other kinds of associate variable. */ | |
1908 | else if (sym->attr.dimension && !class_target | |
1909 | && (sym->as->type == AS_DEFERRED || sym->assoc->variable)) | |
6312ef45 JW |
1910 | { |
1911 | gfc_se se; | |
6312ef45 | 1912 | tree desc; |
bcac046f | 1913 | bool cst_array_ctor; |
6312ef45 JW |
1914 | |
1915 | desc = sym->backend_decl; | |
bcac046f | 1916 | cst_array_ctor = e->expr_type == EXPR_ARRAY |
84ee745e PT |
1917 | && gfc_constant_array_constructor_p (e->value.constructor) |
1918 | && e->ts.type != BT_CHARACTER; | |
6312ef45 JW |
1919 | |
1920 | /* If association is to an expression, evaluate it and create temporary. | |
1921 | Otherwise, get descriptor of target for pointer assignment. */ | |
1922 | gfc_init_se (&se, NULL); | |
d5f48c7c | 1923 | |
bcac046f | 1924 | if (sym->assoc->variable || cst_array_ctor) |
6312ef45 JW |
1925 | { |
1926 | se.direct_byref = 1; | |
1cf43a1d | 1927 | se.use_offset = 1; |
6312ef45 | 1928 | se.expr = desc; |
d5f48c7c | 1929 | GFC_DECL_PTR_ARRAY_P (sym->backend_decl) = 1; |
6312ef45 | 1930 | } |
1cf43a1d | 1931 | |
2960a368 | 1932 | gfc_conv_expr_descriptor (&se, e); |
6312ef45 | 1933 | |
707905d0 | 1934 | if (sym->ts.type == BT_CHARACTER |
707905d0 | 1935 | && !sym->attr.select_type_temporary |
d08f2e4f | 1936 | && sym->ts.u.cl->backend_decl |
707905d0 PT |
1937 | && VAR_P (sym->ts.u.cl->backend_decl) |
1938 | && se.string_length != sym->ts.u.cl->backend_decl) | |
d08f2e4f | 1939 | gfc_add_modify (&se.pre, sym->ts.u.cl->backend_decl, |
f622221a | 1940 | fold_convert (TREE_TYPE (sym->ts.u.cl->backend_decl), |
707905d0 | 1941 | se.string_length)); |
707905d0 | 1942 | |
6312ef45 JW |
1943 | /* If we didn't already do the pointer assignment, set associate-name |
1944 | descriptor to the one generated for the temporary. */ | |
ff3598bc PT |
1945 | if ((!sym->assoc->variable && !cst_array_ctor) |
1946 | || !whole_array) | |
6312ef45 JW |
1947 | { |
1948 | int dim; | |
1949 | ||
ff3598bc PT |
1950 | if (whole_array) |
1951 | gfc_add_modify (&se.pre, desc, se.expr); | |
6312ef45 JW |
1952 | |
1953 | /* The generated descriptor has lower bound zero (as array | |
1954 | temporary), shift bounds so we get lower bounds of 1. */ | |
1955 | for (dim = 0; dim < e->rank; ++dim) | |
1956 | gfc_conv_shift_descriptor_lbound (&se.pre, desc, | |
1957 | dim, gfc_index_one_node); | |
1958 | } | |
1959 | ||
68b1c5e1 PT |
1960 | /* If this is a subreference array pointer associate name use the |
1961 | associate variable element size for the value of 'span'. */ | |
d5f48c7c | 1962 | if (sym->attr.subref_array_pointer && !se.direct_byref) |
68b1c5e1 PT |
1963 | { |
1964 | gcc_assert (e->expr_type == EXPR_VARIABLE); | |
f82f425b PT |
1965 | tmp = gfc_get_array_span (se.expr, e); |
1966 | ||
ff3598bc | 1967 | gfc_conv_descriptor_span_set (&se.pre, desc, tmp); |
68b1c5e1 PT |
1968 | } |
1969 | ||
0b627b58 PT |
1970 | if (e->expr_type == EXPR_FUNCTION |
1971 | && sym->ts.type == BT_DERIVED | |
1972 | && sym->ts.u.derived | |
1973 | && sym->ts.u.derived->attr.pdt_type) | |
1974 | { | |
1975 | tmp = gfc_deallocate_pdt_comp (sym->ts.u.derived, se.expr, | |
1976 | sym->as->rank); | |
1977 | gfc_add_expr_to_block (&se.post, tmp); | |
1978 | } | |
1979 | ||
6312ef45 JW |
1980 | /* Done, register stuff as init / cleanup code. */ |
1981 | gfc_add_init_cleanup (block, gfc_finish_block (&se.pre), | |
1982 | gfc_finish_block (&se.post)); | |
1983 | } | |
1984 | ||
8b704316 PT |
1985 | /* Temporaries, arising from TYPE IS, just need the descriptor of class |
1986 | arrays to be assigned directly. */ | |
1987 | else if (class_target && sym->attr.dimension | |
1988 | && (sym->ts.type == BT_DERIVED || unlimited)) | |
c49ea23d PT |
1989 | { |
1990 | gfc_se se; | |
1991 | ||
1992 | gfc_init_se (&se, NULL); | |
102344e2 | 1993 | se.descriptor_only = 1; |
f3b0bb7a AV |
1994 | /* In a select type the (temporary) associate variable shall point to |
1995 | a standard fortran array (lower bound == 1), but conv_expr () | |
1996 | just maps to the input array in the class object, whose lbound may | |
1997 | be arbitrary. conv_expr_descriptor solves this by inserting a | |
1998 | temporary array descriptor. */ | |
1999 | gfc_conv_expr_descriptor (&se, e); | |
c49ea23d | 2000 | |
f3b0bb7a AV |
2001 | gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se.expr)) |
2002 | || GFC_ARRAY_TYPE_P (TREE_TYPE (se.expr))); | |
c49ea23d PT |
2003 | gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (sym->backend_decl))); |
2004 | ||
f3b0bb7a AV |
2005 | if (GFC_ARRAY_TYPE_P (TREE_TYPE (se.expr))) |
2006 | { | |
2007 | if (INDIRECT_REF_P (se.expr)) | |
2008 | tmp = TREE_OPERAND (se.expr, 0); | |
2009 | else | |
2010 | tmp = se.expr; | |
2011 | ||
2012 | gfc_add_modify (&se.pre, sym->backend_decl, | |
2013 | gfc_class_data_get (GFC_DECL_SAVED_DESCRIPTOR (tmp))); | |
2014 | } | |
2015 | else | |
2016 | gfc_add_modify (&se.pre, sym->backend_decl, se.expr); | |
8b704316 PT |
2017 | |
2018 | if (unlimited) | |
2019 | { | |
2020 | /* Recover the dtype, which has been overwritten by the | |
2021 | assignment from an unlimited polymorphic object. */ | |
2022 | tmp = gfc_conv_descriptor_dtype (sym->backend_decl); | |
2023 | gfc_add_modify (&se.pre, tmp, | |
2024 | gfc_get_dtype (TREE_TYPE (sym->backend_decl))); | |
2025 | } | |
2026 | ||
f3b0bb7a | 2027 | gfc_add_init_cleanup (block, gfc_finish_block (&se.pre), |
c49ea23d PT |
2028 | gfc_finish_block (&se.post)); |
2029 | } | |
2030 | ||
6312ef45 JW |
2031 | /* Do a scalar pointer assignment; this is for scalar variable targets. */ |
2032 | else if (gfc_is_associate_pointer (sym)) | |
2033 | { | |
2034 | gfc_se se; | |
2035 | ||
2036 | gcc_assert (!sym->attr.dimension); | |
2037 | ||
2038 | gfc_init_se (&se, NULL); | |
8f75db9f PT |
2039 | |
2040 | /* Class associate-names come this way because they are | |
2041 | unconditionally associate pointers and the symbol is scalar. */ | |
5ae6f524 PT |
2042 | if (sym->ts.type == BT_CLASS && e->expr_type == EXPR_FUNCTION) |
2043 | { | |
2044 | gfc_conv_expr (&se, e); | |
2045 | se.expr = gfc_evaluate_now (se.expr, &se.pre); | |
3fd46d85 PT |
2046 | /* Finalize the expression and free if it is allocatable. */ |
2047 | gfc_finalize_tree_expr (&se, NULL, gfc_expr_attr (e), e->rank); | |
2048 | gfc_add_block_to_block (&se.post, &se.finalblock); | |
2049 | need_len_assign = false; | |
5ae6f524 PT |
2050 | } |
2051 | else if (sym->ts.type == BT_CLASS && CLASS_DATA (sym)->attr.dimension) | |
8f75db9f | 2052 | { |
5b384b3d | 2053 | tree target_expr; |
8f75db9f | 2054 | /* For a class array we need a descriptor for the selector. */ |
2960a368 | 2055 | gfc_conv_expr_descriptor (&se, e); |
5b384b3d PT |
2056 | /* Needed to get/set the _len component below. */ |
2057 | target_expr = se.expr; | |
8f75db9f | 2058 | |
8b704316 | 2059 | /* Obtain a temporary class container for the result. */ |
16e82b25 | 2060 | gfc_conv_class_to_class (&se, e, sym->ts, false, true, false, false); |
8f75db9f PT |
2061 | se.expr = build_fold_indirect_ref_loc (input_location, se.expr); |
2062 | ||
2063 | /* Set the offset. */ | |
2064 | desc = gfc_class_data_get (se.expr); | |
2065 | offset = gfc_index_zero_node; | |
2066 | for (n = 0; n < e->rank; n++) | |
2067 | { | |
2068 | dim = gfc_rank_cst[n]; | |
2069 | tmp = fold_build2_loc (input_location, MULT_EXPR, | |
2070 | gfc_array_index_type, | |
2071 | gfc_conv_descriptor_stride_get (desc, dim), | |
2072 | gfc_conv_descriptor_lbound_get (desc, dim)); | |
2073 | offset = fold_build2_loc (input_location, MINUS_EXPR, | |
2074 | gfc_array_index_type, | |
2075 | offset, tmp); | |
2076 | } | |
5b384b3d PT |
2077 | if (need_len_assign) |
2078 | { | |
f3b0bb7a AV |
2079 | if (e->symtree |
2080 | && DECL_LANG_SPECIFIC (e->symtree->n.sym->backend_decl) | |
d05ccada PT |
2081 | && GFC_DECL_SAVED_DESCRIPTOR (e->symtree->n.sym->backend_decl) |
2082 | && TREE_CODE (target_expr) != COMPONENT_REF) | |
f3b0bb7a AV |
2083 | /* Use the original class descriptor stored in the saved |
2084 | descriptor to get the target_expr. */ | |
2085 | target_expr = | |
2086 | GFC_DECL_SAVED_DESCRIPTOR (e->symtree->n.sym->backend_decl); | |
2087 | else | |
2088 | /* Strip the _data component from the target_expr. */ | |
2089 | target_expr = TREE_OPERAND (target_expr, 0); | |
2090 | /* Add a reference to the _len comp to the target expr. */ | |
2091 | tmp = gfc_class_len_get (target_expr); | |
5b384b3d PT |
2092 | /* Get the component-ref for the temp structure's _len comp. */ |
2093 | charlen = gfc_class_len_get (se.expr); | |
026c3cfd | 2094 | /* Add the assign to the beginning of the block... */ |
5b384b3d PT |
2095 | gfc_add_modify (&se.pre, charlen, |
2096 | fold_convert (TREE_TYPE (charlen), tmp)); | |
2097 | /* and the oposite way at the end of the block, to hand changes | |
2098 | on the string length back. */ | |
2099 | gfc_add_modify (&se.post, tmp, | |
2100 | fold_convert (TREE_TYPE (tmp), charlen)); | |
2101 | /* Length assignment done, prevent adding it again below. */ | |
2102 | need_len_assign = false; | |
2103 | } | |
8f75db9f PT |
2104 | gfc_conv_descriptor_offset_set (&se.pre, desc, offset); |
2105 | } | |
2106 | else if (sym->ts.type == BT_CLASS && e->ts.type == BT_CLASS | |
2107 | && CLASS_DATA (e)->attr.dimension) | |
2108 | { | |
2109 | /* This is bound to be a class array element. */ | |
2110 | gfc_conv_expr_reference (&se, e); | |
8b704316 | 2111 | /* Get the _vptr component of the class object. */ |
8f75db9f PT |
2112 | tmp = gfc_get_vptr_from_expr (se.expr); |
2113 | /* Obtain a temporary class container for the result. */ | |
16e82b25 | 2114 | gfc_conv_derived_to_class (&se, e, sym->ts, tmp, false, false); |
8f75db9f | 2115 | se.expr = build_fold_indirect_ref_loc (input_location, se.expr); |
fcc4891d | 2116 | need_len_assign = false; |
8f75db9f PT |
2117 | } |
2118 | else | |
5b384b3d PT |
2119 | { |
2120 | /* For BT_CLASS and BT_DERIVED, this boils down to a pointer assign, | |
2121 | which has the string length included. For CHARACTERS it is still | |
2122 | needed and will be done at the end of this routine. */ | |
2123 | gfc_conv_expr (&se, e); | |
2124 | need_len_assign = need_len_assign && sym->ts.type == BT_CHARACTER; | |
2125 | } | |
6312ef45 | 2126 | |
707905d0 | 2127 | if (sym->ts.type == BT_CHARACTER |
707905d0 PT |
2128 | && !sym->attr.select_type_temporary |
2129 | && VAR_P (sym->ts.u.cl->backend_decl) | |
2130 | && se.string_length != sym->ts.u.cl->backend_decl) | |
2131 | { | |
2132 | gfc_add_modify (&se.pre, sym->ts.u.cl->backend_decl, | |
f622221a | 2133 | fold_convert (TREE_TYPE (sym->ts.u.cl->backend_decl), |
707905d0 PT |
2134 | se.string_length)); |
2135 | if (e->expr_type == EXPR_FUNCTION) | |
2136 | { | |
2137 | tmp = gfc_call_free (sym->backend_decl); | |
2138 | gfc_add_expr_to_block (&se.post, tmp); | |
2139 | } | |
2140 | } | |
2141 | ||
707905d0 | 2142 | if (sym->ts.type == BT_CHARACTER && e->ts.type == BT_CHARACTER |
b14a13fa | 2143 | && POINTER_TYPE_P (TREE_TYPE (se.expr))) |
707905d0 PT |
2144 | { |
2145 | /* These are pointer types already. */ | |
2146 | tmp = fold_convert (TREE_TYPE (sym->backend_decl), se.expr); | |
2147 | } | |
2148 | else | |
2149 | { | |
56b070e3 | 2150 | tree ctree = gfc_get_class_from_expr (se.expr); |
75cdd535 | 2151 | tmp = TREE_TYPE (sym->backend_decl); |
56b070e3 | 2152 | |
577223ae PT |
2153 | /* F2018:19.5.1.6 "If a selector has the POINTER attribute, |
2154 | it shall be associated; the associate name is associated | |
2155 | with the target of the pointer and does not have the | |
2156 | POINTER attribute." */ | |
56b070e3 | 2157 | if (sym->ts.type == BT_CLASS |
577223ae PT |
2158 | && e->ts.type == BT_CLASS && e->rank == 0 && ctree |
2159 | && (!GFC_CLASS_TYPE_P (TREE_TYPE (se.expr)) | |
2160 | || CLASS_DATA (e)->attr.class_pointer)) | |
56b070e3 PT |
2161 | { |
2162 | tree stmp; | |
2163 | tree dtmp; | |
3fd46d85 | 2164 | tree ctmp; |
56b070e3 | 2165 | |
3fd46d85 | 2166 | ctmp = ctree; |
56b070e3 PT |
2167 | dtmp = TREE_TYPE (TREE_TYPE (sym->backend_decl)); |
2168 | ctree = gfc_create_var (dtmp, "class"); | |
2169 | ||
3fd46d85 PT |
2170 | if (IS_INFERRED_TYPE (e) |
2171 | && !GFC_CLASS_TYPE_P (TREE_TYPE (se.expr))) | |
2172 | stmp = se.expr; | |
2173 | else | |
2174 | stmp = gfc_class_data_get (ctmp); | |
2175 | ||
577223ae PT |
2176 | /* Coarray scalar component expressions can emerge from |
2177 | the front end as array elements of the _data field. */ | |
2178 | if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (stmp))) | |
2179 | stmp = gfc_conv_descriptor_data_get (stmp); | |
3fd46d85 PT |
2180 | |
2181 | if (!POINTER_TYPE_P (TREE_TYPE (stmp))) | |
2182 | stmp = gfc_build_addr_expr (NULL, stmp); | |
2183 | ||
56b070e3 PT |
2184 | dtmp = gfc_class_data_get (ctree); |
2185 | stmp = fold_convert (TREE_TYPE (dtmp), stmp); | |
2186 | gfc_add_modify (&se.pre, dtmp, stmp); | |
3fd46d85 | 2187 | stmp = gfc_class_vptr_get (ctmp); |
56b070e3 PT |
2188 | dtmp = gfc_class_vptr_get (ctree); |
2189 | stmp = fold_convert (TREE_TYPE (dtmp), stmp); | |
2190 | gfc_add_modify (&se.pre, dtmp, stmp); | |
2191 | if (UNLIMITED_POLY (sym)) | |
2192 | { | |
3fd46d85 | 2193 | stmp = gfc_class_len_get (ctmp); |
56b070e3 PT |
2194 | dtmp = gfc_class_len_get (ctree); |
2195 | stmp = fold_convert (TREE_TYPE (dtmp), stmp); | |
2196 | gfc_add_modify (&se.pre, dtmp, stmp); | |
577223ae | 2197 | need_len_assign = false; |
56b070e3 PT |
2198 | } |
2199 | se.expr = ctree; | |
2200 | } | |
75cdd535 | 2201 | tmp = gfc_build_addr_expr (tmp, se.expr); |
707905d0 PT |
2202 | } |
2203 | ||
6312ef45 | 2204 | gfc_add_modify (&se.pre, sym->backend_decl, tmp); |
8b704316 | 2205 | |
6312ef45 JW |
2206 | gfc_add_init_cleanup (block, gfc_finish_block( &se.pre), |
2207 | gfc_finish_block (&se.post)); | |
2208 | } | |
2209 | ||
2210 | /* Do a simple assignment. This is for scalar expressions, where we | |
2211 | can simply use expression assignment. */ | |
2212 | else | |
2213 | { | |
2214 | gfc_expr *lhs; | |
0b627b58 | 2215 | tree res; |
a8399af8 | 2216 | gfc_se se; |
d7caf313 | 2217 | stmtblock_t final_block; |
a8399af8 PT |
2218 | |
2219 | gfc_init_se (&se, NULL); | |
2220 | ||
e53b6e56 | 2221 | /* resolve.cc converts some associate names to allocatable so that |
a8399af8 PT |
2222 | allocation can take place automatically in gfc_trans_assignment. |
2223 | The frontend prevents them from being either allocated, | |
2224 | deallocated or reallocated. */ | |
d7caf313 PT |
2225 | if (sym->ts.type == BT_DERIVED |
2226 | && sym->ts.u.derived->attr.alloc_comp) | |
2227 | { | |
2228 | tmp = sym->backend_decl; | |
2229 | tmp = gfc_nullify_alloc_comp (sym->ts.u.derived, tmp, | |
2230 | sym->attr.dimension ? sym->as->rank : 0); | |
2231 | gfc_add_expr_to_block (&se.pre, tmp); | |
2232 | } | |
2233 | ||
a8399af8 PT |
2234 | if (sym->attr.allocatable) |
2235 | { | |
2236 | tmp = sym->backend_decl; | |
2237 | if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp))) | |
2238 | tmp = gfc_conv_descriptor_data_get (tmp); | |
2239 | gfc_add_modify (&se.pre, tmp, fold_convert (TREE_TYPE (tmp), | |
2240 | null_pointer_node)); | |
2241 | } | |
6312ef45 JW |
2242 | |
2243 | lhs = gfc_lval_expr_from_sym (sym); | |
d7caf313 | 2244 | lhs->must_finalize = 0; |
0b627b58 | 2245 | res = gfc_trans_assignment (lhs, e, false, true); |
a8399af8 | 2246 | gfc_add_expr_to_block (&se.pre, res); |
0b627b58 | 2247 | |
d7caf313 PT |
2248 | gfc_init_block (&final_block); |
2249 | ||
2250 | if (sym->attr.associate_var | |
2251 | && sym->ts.type == BT_DERIVED | |
2252 | && sym->ts.u.derived->attr.defined_assign_comp | |
2253 | && gfc_may_be_finalized (sym->ts) | |
2254 | && e->expr_type == EXPR_FUNCTION) | |
2255 | { | |
2256 | gfc_expr *ef; | |
2257 | ef = gfc_lval_expr_from_sym (sym); | |
2258 | gfc_add_finalizer_call (&final_block, ef); | |
2259 | gfc_free_expr (ef); | |
2260 | } | |
2261 | ||
2262 | if (sym->ts.type == BT_DERIVED | |
2263 | && sym->ts.u.derived->attr.alloc_comp) | |
2264 | { | |
2265 | tmp = sym->backend_decl; | |
2266 | tmp = gfc_deallocate_alloc_comp (sym->ts.u.derived, | |
2267 | tmp, 0); | |
2268 | gfc_add_expr_to_block (&final_block, tmp); | |
2269 | } | |
2270 | ||
0b627b58 PT |
2271 | tmp = sym->backend_decl; |
2272 | if (e->expr_type == EXPR_FUNCTION | |
2273 | && sym->ts.type == BT_DERIVED | |
2274 | && sym->ts.u.derived | |
2275 | && sym->ts.u.derived->attr.pdt_type) | |
2276 | { | |
2277 | tmp = gfc_deallocate_pdt_comp (sym->ts.u.derived, tmp, | |
2278 | 0); | |
2279 | } | |
2280 | else if (e->expr_type == EXPR_FUNCTION | |
2281 | && sym->ts.type == BT_CLASS | |
2282 | && CLASS_DATA (sym)->ts.u.derived | |
2283 | && CLASS_DATA (sym)->ts.u.derived->attr.pdt_type) | |
2284 | { | |
2285 | tmp = gfc_class_data_get (tmp); | |
2286 | tmp = gfc_deallocate_pdt_comp (CLASS_DATA (sym)->ts.u.derived, | |
2287 | tmp, 0); | |
2288 | } | |
a8399af8 PT |
2289 | else if (sym->attr.allocatable) |
2290 | { | |
2291 | tmp = sym->backend_decl; | |
2292 | ||
2293 | if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp))) | |
2294 | tmp = gfc_conv_descriptor_data_get (tmp); | |
2295 | ||
2296 | /* A simple call to free suffices here. */ | |
2297 | tmp = gfc_call_free (tmp); | |
2298 | ||
2299 | /* Make sure that reallocation on assignment cannot occur. */ | |
2300 | sym->attr.allocatable = 0; | |
2301 | } | |
2302 | else | |
2303 | tmp = NULL_TREE; | |
0b627b58 | 2304 | |
d7caf313 PT |
2305 | gfc_add_expr_to_block (&final_block, tmp); |
2306 | tmp = gfc_finish_block (&final_block); | |
a8399af8 | 2307 | res = gfc_finish_block (&se.pre); |
0b627b58 | 2308 | gfc_add_init_cleanup (block, res, tmp); |
a8399af8 | 2309 | gfc_free_expr (lhs); |
6312ef45 | 2310 | } |
8b704316 | 2311 | |
5b384b3d PT |
2312 | /* Set the stringlength, when needed. */ |
2313 | if (need_len_assign) | |
8b704316 | 2314 | { |
8b704316 PT |
2315 | gfc_se se; |
2316 | gfc_init_se (&se, NULL); | |
5b384b3d PT |
2317 | if (e->symtree->n.sym->ts.type == BT_CHARACTER) |
2318 | { | |
7ebd4a1d | 2319 | /* Deferred strings are dealt with in the preceding. */ |
5b384b3d PT |
2320 | gcc_assert (!e->symtree->n.sym->ts.deferred); |
2321 | tmp = e->symtree->n.sym->ts.u.cl->backend_decl; | |
2322 | } | |
6017b8f0 | 2323 | else if (e->symtree->n.sym->attr.function |
a7d3cd40 | 2324 | && e->symtree->n.sym == e->symtree->n.sym->result) |
6017b8f0 PT |
2325 | { |
2326 | tmp = gfc_get_fake_result_decl (e->symtree->n.sym, 0); | |
2327 | tmp = gfc_class_len_get (tmp); | |
2328 | } | |
5b384b3d PT |
2329 | else |
2330 | tmp = gfc_class_len_get (gfc_get_symbol_decl (e->symtree->n.sym)); | |
8b704316 | 2331 | gfc_get_symbol_decl (sym); |
5b384b3d PT |
2332 | charlen = sym->ts.type == BT_CHARACTER ? sym->ts.u.cl->backend_decl |
2333 | : gfc_class_len_get (sym->backend_decl); | |
2334 | /* Prevent adding a noop len= len. */ | |
2335 | if (tmp != charlen) | |
2336 | { | |
2337 | gfc_add_modify (&se.pre, charlen, | |
2338 | fold_convert (TREE_TYPE (charlen), tmp)); | |
2339 | gfc_add_init_cleanup (block, gfc_finish_block (&se.pre), | |
2340 | gfc_finish_block (&se.post)); | |
2341 | } | |
8b704316 | 2342 | } |
6312ef45 JW |
2343 | } |
2344 | ||
2345 | ||
9abe5e56 DK |
2346 | /* Translate a BLOCK construct. This is basically what we would do for a |
2347 | procedure body. */ | |
2348 | ||
2349 | tree | |
2350 | gfc_trans_block_construct (gfc_code* code) | |
2351 | { | |
2352 | gfc_namespace* ns; | |
2353 | gfc_symbol* sym; | |
e5ca9693 DK |
2354 | gfc_wrapped_block block; |
2355 | tree exit_label; | |
2356 | stmtblock_t body; | |
6312ef45 | 2357 | gfc_association_list *ass; |
b7c4a12a | 2358 | tree translated_body; |
9abe5e56 | 2359 | |
03af1e4c | 2360 | ns = code->ext.block.ns; |
9abe5e56 DK |
2361 | gcc_assert (ns); |
2362 | sym = ns->proc_name; | |
2363 | gcc_assert (sym); | |
2364 | ||
e5ca9693 | 2365 | /* Process local variables. */ |
9abe5e56 DK |
2366 | gcc_assert (!sym->tlink); |
2367 | sym->tlink = sym; | |
6312ef45 | 2368 | gfc_process_block_locals (ns); |
9abe5e56 | 2369 | |
e5ca9693 DK |
2370 | /* Generate code including exit-label. */ |
2371 | gfc_init_block (&body); | |
2372 | exit_label = gfc_build_label_decl (NULL_TREE); | |
2373 | code->exit_label = exit_label; | |
41dbbb37 | 2374 | |
dc7a8b4b | 2375 | finish_oacc_declare (ns, sym, true); |
41dbbb37 | 2376 | |
b7c4a12a SL |
2377 | translated_body = gfc_trans_code (ns->code); |
2378 | if (ns->omp_structured_block) | |
2379 | translated_body = build1 (OMP_STRUCTURED_BLOCK, void_type_node, | |
2380 | translated_body); | |
2381 | gfc_add_expr_to_block (&body, translated_body); | |
e5ca9693 DK |
2382 | gfc_add_expr_to_block (&body, build1_v (LABEL_EXPR, exit_label)); |
2383 | ||
2384 | /* Finish everything. */ | |
2385 | gfc_start_wrapped_block (&block, gfc_finish_block (&body)); | |
2386 | gfc_trans_deferred_vars (sym, &block); | |
6312ef45 JW |
2387 | for (ass = code->ext.block.assoc; ass; ass = ass->next) |
2388 | trans_associate_var (ass->st->n.sym, &block); | |
8b704316 | 2389 | |
e5ca9693 | 2390 | return gfc_finish_wrapped_block (&block); |
9abe5e56 DK |
2391 | } |
2392 | ||
1c122092 ML |
2393 | /* Translate the simple DO construct in a C-style manner. |
2394 | This is where the loop variable has integer type and step +-1. | |
2395 | Following code will generate infinite loop in case where TO is INT_MAX | |
2396 | (for +1 step) or INT_MIN (for -1 step) | |
9abe5e56 | 2397 | |
fbdad37d PB |
2398 | We translate a do loop from: |
2399 | ||
2400 | DO dovar = from, to, step | |
2401 | body | |
2402 | END DO | |
2403 | ||
2404 | to: | |
2405 | ||
2406 | [Evaluate loop bounds and step] | |
1c122092 ML |
2407 | dovar = from; |
2408 | for (;;) | |
2409 | { | |
2410 | if (dovar > to) | |
2411 | goto end_label; | |
2412 | body; | |
2413 | cycle_label: | |
2414 | dovar += step; | |
fbdad37d | 2415 | } |
1c122092 | 2416 | end_label: |
fbdad37d | 2417 | |
1c122092 ML |
2418 | This helps the optimizers by avoiding the extra pre-header condition and |
2419 | we save a register as we just compare the updated IV (not a value in | |
2420 | previous step). */ | |
fbdad37d PB |
2421 | |
2422 | static tree | |
2423 | gfc_trans_simple_do (gfc_code * code, stmtblock_t *pblock, tree dovar, | |
bc51e726 | 2424 | tree from, tree to, tree step, tree exit_cond) |
fbdad37d PB |
2425 | { |
2426 | stmtblock_t body; | |
2427 | tree type; | |
2428 | tree cond; | |
2429 | tree tmp; | |
33abc845 | 2430 | tree saved_dovar = NULL; |
fbdad37d PB |
2431 | tree cycle_label; |
2432 | tree exit_label; | |
55bd9c35 | 2433 | location_t loc; |
fbdad37d | 2434 | type = TREE_TYPE (dovar); |
1c122092 | 2435 | bool is_step_positive = tree_int_cst_sgn (step) > 0; |
fbdad37d | 2436 | |
9c81750c | 2437 | loc = gfc_get_location (&code->ext.iterator->start->where); |
55bd9c35 | 2438 | |
fbdad37d | 2439 | /* Initialize the DO variable: dovar = from. */ |
8594f636 | 2440 | gfc_add_modify_loc (loc, pblock, dovar, |
1c122092 | 2441 | fold_convert (TREE_TYPE (dovar), from)); |
8b704316 | 2442 | |
1cc0e193 | 2443 | /* Save value for do-tinkering checking. */ |
33abc845 TB |
2444 | if (gfc_option.rtcheck & GFC_RTCHECK_DO) |
2445 | { | |
2446 | saved_dovar = gfc_create_var (type, ".saved_dovar"); | |
55bd9c35 | 2447 | gfc_add_modify_loc (loc, pblock, saved_dovar, dovar); |
33abc845 | 2448 | } |
fbdad37d PB |
2449 | |
2450 | /* Cycle and exit statements are implemented with gotos. */ | |
2451 | cycle_label = gfc_build_label_decl (NULL_TREE); | |
2452 | exit_label = gfc_build_label_decl (NULL_TREE); | |
2453 | ||
1c122092 | 2454 | /* Put the labels where they can be found later. See gfc_trans_do(). */ |
e5ca9693 DK |
2455 | code->cycle_label = cycle_label; |
2456 | code->exit_label = exit_label; | |
fbdad37d PB |
2457 | |
2458 | /* Loop body. */ | |
2459 | gfc_start_block (&body); | |
2460 | ||
1c122092 ML |
2461 | /* Exit the loop if there is an I/O result condition or error. */ |
2462 | if (exit_cond) | |
2463 | { | |
2464 | tmp = build1_v (GOTO_EXPR, exit_label); | |
2465 | tmp = fold_build3_loc (loc, COND_EXPR, void_type_node, | |
2466 | exit_cond, tmp, | |
2467 | build_empty_stmt (loc)); | |
2468 | gfc_add_expr_to_block (&body, tmp); | |
2469 | } | |
2470 | ||
2471 | /* Evaluate the loop condition. */ | |
2472 | if (is_step_positive) | |
63ee5404 | 2473 | cond = fold_build2_loc (loc, GT_EXPR, logical_type_node, dovar, |
1c122092 ML |
2474 | fold_convert (type, to)); |
2475 | else | |
63ee5404 | 2476 | cond = fold_build2_loc (loc, LT_EXPR, logical_type_node, dovar, |
1c122092 ML |
2477 | fold_convert (type, to)); |
2478 | ||
2479 | cond = gfc_evaluate_now_loc (loc, cond, &body); | |
9935667a | 2480 | if (code->ext.iterator->annot.unroll && cond != error_mark_node) |
170a8bd6 EB |
2481 | cond |
2482 | = build3 (ANNOTATE_EXPR, TREE_TYPE (cond), cond, | |
2483 | build_int_cst (integer_type_node, annot_expr_unroll_kind), | |
9935667a HA |
2484 | build_int_cst (integer_type_node, |
2485 | code->ext.iterator->annot.unroll)); | |
1c122092 | 2486 | |
9935667a | 2487 | if (code->ext.iterator->annot.ivdep && cond != error_mark_node) |
2bd86b95 HA |
2488 | cond = build3 (ANNOTATE_EXPR, TREE_TYPE (cond), cond, |
2489 | build_int_cst (integer_type_node, annot_expr_ivdep_kind), | |
2490 | integer_zero_node); | |
9935667a | 2491 | if (code->ext.iterator->annot.vector && cond != error_mark_node) |
2bd86b95 HA |
2492 | cond = build3 (ANNOTATE_EXPR, TREE_TYPE (cond), cond, |
2493 | build_int_cst (integer_type_node, annot_expr_vector_kind), | |
2494 | integer_zero_node); | |
9935667a | 2495 | if (code->ext.iterator->annot.novector && cond != error_mark_node) |
2bd86b95 HA |
2496 | cond = build3 (ANNOTATE_EXPR, TREE_TYPE (cond), cond, |
2497 | build_int_cst (integer_type_node, annot_expr_no_vector_kind), | |
2498 | integer_zero_node); | |
2499 | ||
1c122092 ML |
2500 | /* The loop exit. */ |
2501 | tmp = fold_build1_loc (loc, GOTO_EXPR, void_type_node, exit_label); | |
2502 | TREE_USED (exit_label) = 1; | |
2503 | tmp = fold_build3_loc (loc, COND_EXPR, void_type_node, | |
2504 | cond, tmp, build_empty_stmt (loc)); | |
2505 | gfc_add_expr_to_block (&body, tmp); | |
2506 | ||
2507 | /* Check whether the induction variable is equal to INT_MAX | |
2508 | (respectively to INT_MIN). */ | |
2509 | if (gfc_option.rtcheck & GFC_RTCHECK_DO) | |
2510 | { | |
2511 | tree boundary = is_step_positive ? TYPE_MAX_VALUE (type) | |
2512 | : TYPE_MIN_VALUE (type); | |
2513 | ||
63ee5404 | 2514 | tmp = fold_build2_loc (loc, EQ_EXPR, logical_type_node, |
1c122092 ML |
2515 | dovar, boundary); |
2516 | gfc_trans_runtime_check (true, false, tmp, &body, &code->loc, | |
2517 | "Loop iterates infinitely"); | |
2518 | } | |
2519 | ||
fbdad37d | 2520 | /* Main loop body. */ |
bc51e726 | 2521 | tmp = gfc_trans_code_cond (code->block->next, exit_cond); |
fbdad37d PB |
2522 | gfc_add_expr_to_block (&body, tmp); |
2523 | ||
2524 | /* Label for cycle statements (if needed). */ | |
2525 | if (TREE_USED (cycle_label)) | |
2526 | { | |
2527 | tmp = build1_v (LABEL_EXPR, cycle_label); | |
2528 | gfc_add_expr_to_block (&body, tmp); | |
2529 | } | |
2530 | ||
1cc0e193 | 2531 | /* Check whether someone has modified the loop variable. */ |
33abc845 TB |
2532 | if (gfc_option.rtcheck & GFC_RTCHECK_DO) |
2533 | { | |
63ee5404 | 2534 | tmp = fold_build2_loc (loc, NE_EXPR, logical_type_node, |
bc98ed60 | 2535 | dovar, saved_dovar); |
33abc845 TB |
2536 | gfc_trans_runtime_check (true, false, tmp, &body, &code->loc, |
2537 | "Loop variable has been modified"); | |
2538 | } | |
2539 | ||
fbdad37d | 2540 | /* Increment the loop variable. */ |
55bd9c35 TB |
2541 | tmp = fold_build2_loc (loc, PLUS_EXPR, type, dovar, step); |
2542 | gfc_add_modify_loc (loc, &body, dovar, tmp); | |
fbdad37d | 2543 | |
33abc845 | 2544 | if (gfc_option.rtcheck & GFC_RTCHECK_DO) |
55bd9c35 | 2545 | gfc_add_modify_loc (loc, &body, saved_dovar, dovar); |
33abc845 | 2546 | |
fbdad37d PB |
2547 | /* Finish the loop body. */ |
2548 | tmp = gfc_finish_block (&body); | |
55bd9c35 | 2549 | tmp = fold_build1_loc (loc, LOOP_EXPR, void_type_node, tmp); |
fbdad37d | 2550 | |
fbdad37d PB |
2551 | gfc_add_expr_to_block (pblock, tmp); |
2552 | ||
2553 | /* Add the exit label. */ | |
2554 | tmp = build1_v (LABEL_EXPR, exit_label); | |
2555 | gfc_add_expr_to_block (pblock, tmp); | |
2556 | ||
2557 | return gfc_finish_block (pblock); | |
2558 | } | |
2559 | ||
6de9cd9a DN |
2560 | /* Translate the DO construct. This obviously is one of the most |
2561 | important ones to get right with any compiler, but especially | |
2562 | so for Fortran. | |
2563 | ||
fbdad37d PB |
2564 | We special case some loop forms as described in gfc_trans_simple_do. |
2565 | For other cases we implement them with a separate loop count, | |
2566 | as described in the standard. | |
6de9cd9a DN |
2567 | |
2568 | We translate a do loop from: | |
2569 | ||
2570 | DO dovar = from, to, step | |
2571 | body | |
2572 | END DO | |
2573 | ||
2574 | to: | |
2575 | ||
fbdad37d | 2576 | [evaluate loop bounds and step] |
5d148c08 FXC |
2577 | empty = (step > 0 ? to < from : to > from); |
2578 | countm1 = (to - from) / step; | |
fbdad37d | 2579 | dovar = from; |
5d148c08 | 2580 | if (empty) goto exit_label; |
fbdad37d | 2581 | for (;;) |
6de9cd9a DN |
2582 | { |
2583 | body; | |
2584 | cycle_label: | |
fbdad37d | 2585 | dovar += step |
8c01de7f | 2586 | countm1t = countm1; |
76dac339 | 2587 | countm1--; |
8c01de7f | 2588 | if (countm1t == 0) goto exit_label; |
6de9cd9a DN |
2589 | } |
2590 | exit_label: | |
2591 | ||
5d148c08 FXC |
2592 | countm1 is an unsigned integer. It is equal to the loop count minus one, |
2593 | because the loop count itself can overflow. */ | |
6de9cd9a DN |
2594 | |
2595 | tree | |
bc51e726 | 2596 | gfc_trans_do (gfc_code * code, tree exit_cond) |
6de9cd9a DN |
2597 | { |
2598 | gfc_se se; | |
2599 | tree dovar; | |
33abc845 | 2600 | tree saved_dovar = NULL; |
6de9cd9a DN |
2601 | tree from; |
2602 | tree to; | |
2603 | tree step; | |
5d148c08 | 2604 | tree countm1; |
6de9cd9a | 2605 | tree type; |
5d148c08 | 2606 | tree utype; |
6de9cd9a DN |
2607 | tree cond; |
2608 | tree cycle_label; | |
2609 | tree exit_label; | |
2610 | tree tmp; | |
2611 | stmtblock_t block; | |
2612 | stmtblock_t body; | |
55bd9c35 | 2613 | location_t loc; |
6de9cd9a DN |
2614 | |
2615 | gfc_start_block (&block); | |
2616 | ||
9c81750c | 2617 | loc = gfc_get_location (&code->ext.iterator->start->where); |
55bd9c35 | 2618 | |
fbdad37d | 2619 | /* Evaluate all the expressions in the iterator. */ |
6de9cd9a DN |
2620 | gfc_init_se (&se, NULL); |
2621 | gfc_conv_expr_lhs (&se, code->ext.iterator->var); | |
2622 | gfc_add_block_to_block (&block, &se.pre); | |
2623 | dovar = se.expr; | |
2624 | type = TREE_TYPE (dovar); | |
2625 | ||
2626 | gfc_init_se (&se, NULL); | |
8d5cfa27 | 2627 | gfc_conv_expr_val (&se, code->ext.iterator->start); |
6de9cd9a | 2628 | gfc_add_block_to_block (&block, &se.pre); |
fbdad37d | 2629 | from = gfc_evaluate_now (se.expr, &block); |
6de9cd9a DN |
2630 | |
2631 | gfc_init_se (&se, NULL); | |
8d5cfa27 | 2632 | gfc_conv_expr_val (&se, code->ext.iterator->end); |
6de9cd9a | 2633 | gfc_add_block_to_block (&block, &se.pre); |
fbdad37d | 2634 | to = gfc_evaluate_now (se.expr, &block); |
6de9cd9a DN |
2635 | |
2636 | gfc_init_se (&se, NULL); | |
8d5cfa27 | 2637 | gfc_conv_expr_val (&se, code->ext.iterator->step); |
6de9cd9a | 2638 | gfc_add_block_to_block (&block, &se.pre); |
fbdad37d PB |
2639 | step = gfc_evaluate_now (se.expr, &block); |
2640 | ||
33abc845 TB |
2641 | if (gfc_option.rtcheck & GFC_RTCHECK_DO) |
2642 | { | |
63ee5404 | 2643 | tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, step, |
e8160c9a | 2644 | build_zero_cst (type)); |
33abc845 TB |
2645 | gfc_trans_runtime_check (true, false, tmp, &block, &code->loc, |
2646 | "DO step value is zero"); | |
2647 | } | |
2648 | ||
fbdad37d PB |
2649 | /* Special case simple loops. */ |
2650 | if (TREE_CODE (type) == INTEGER_TYPE | |
2651 | && (integer_onep (step) | |
2652 | || tree_int_cst_equal (step, integer_minus_one_node))) | |
1c122092 ML |
2653 | return gfc_trans_simple_do (code, &block, dovar, from, to, step, |
2654 | exit_cond); | |
6de9cd9a | 2655 | |
8d5cfa27 | 2656 | if (TREE_CODE (type) == INTEGER_TYPE) |
c0b29099 JJ |
2657 | utype = unsigned_type_for (type); |
2658 | else | |
2659 | utype = unsigned_type_for (gfc_array_index_type); | |
2660 | countm1 = gfc_create_var (utype, "countm1"); | |
5d148c08 | 2661 | |
c0b29099 JJ |
2662 | /* Cycle and exit statements are implemented with gotos. */ |
2663 | cycle_label = gfc_build_label_decl (NULL_TREE); | |
2664 | exit_label = gfc_build_label_decl (NULL_TREE); | |
2665 | TREE_USED (exit_label) = 1; | |
2666 | ||
e5ca9693 DK |
2667 | /* Put these labels where they can be found later. */ |
2668 | code->cycle_label = cycle_label; | |
2669 | code->exit_label = exit_label; | |
2670 | ||
c0b29099 JJ |
2671 | /* Initialize the DO variable: dovar = from. */ |
2672 | gfc_add_modify (&block, dovar, from); | |
2673 | ||
1cc0e193 | 2674 | /* Save value for do-tinkering checking. */ |
33abc845 TB |
2675 | if (gfc_option.rtcheck & GFC_RTCHECK_DO) |
2676 | { | |
2677 | saved_dovar = gfc_create_var (type, ".saved_dovar"); | |
55bd9c35 | 2678 | gfc_add_modify_loc (loc, &block, saved_dovar, dovar); |
33abc845 TB |
2679 | } |
2680 | ||
c0b29099 JJ |
2681 | /* Initialize loop count and jump to exit label if the loop is empty. |
2682 | This code is executed before we enter the loop body. We generate: | |
2683 | if (step > 0) | |
2684 | { | |
d17271de | 2685 | countm1 = (to - from) / step; |
8146bb58 TK |
2686 | if (to < from) |
2687 | goto exit_label; | |
c0b29099 JJ |
2688 | } |
2689 | else | |
2690 | { | |
d17271de | 2691 | countm1 = (from - to) / -step; |
8146bb58 TK |
2692 | if (to > from) |
2693 | goto exit_label; | |
2694 | } | |
c5e7e996 | 2695 | */ |
8146bb58 | 2696 | |
c0b29099 JJ |
2697 | if (TREE_CODE (type) == INTEGER_TYPE) |
2698 | { | |
c5e7e996 | 2699 | tree pos, neg, tou, fromu, stepu, tmp2; |
8146bb58 | 2700 | |
c5e7e996 RB |
2701 | /* The distance from FROM to TO cannot always be represented in a signed |
2702 | type, thus use unsigned arithmetic, also to avoid any undefined | |
2703 | overflow issues. */ | |
2704 | tou = fold_convert (utype, to); | |
2705 | fromu = fold_convert (utype, from); | |
2706 | stepu = fold_convert (utype, step); | |
5d148c08 | 2707 | |
c5e7e996 RB |
2708 | /* For a positive step, when to < from, exit, otherwise compute |
2709 | countm1 = ((unsigned)to - (unsigned)from) / (unsigned)step */ | |
63ee5404 | 2710 | tmp = fold_build2_loc (loc, LT_EXPR, logical_type_node, to, from); |
c5e7e996 RB |
2711 | tmp2 = fold_build2_loc (loc, TRUNC_DIV_EXPR, utype, |
2712 | fold_build2_loc (loc, MINUS_EXPR, utype, | |
2713 | tou, fromu), | |
2714 | stepu); | |
d17271de RB |
2715 | pos = build2 (COMPOUND_EXPR, void_type_node, |
2716 | fold_build2 (MODIFY_EXPR, void_type_node, | |
2717 | countm1, tmp2), | |
7119f1b1 ML |
2718 | build3_loc (loc, COND_EXPR, void_type_node, |
2719 | gfc_unlikely (tmp, PRED_FORTRAN_LOOP_PREHEADER), | |
d17271de RB |
2720 | build1_loc (loc, GOTO_EXPR, void_type_node, |
2721 | exit_label), NULL_TREE)); | |
c5e7e996 RB |
2722 | |
2723 | /* For a negative step, when to > from, exit, otherwise compute | |
2724 | countm1 = ((unsigned)from - (unsigned)to) / -(unsigned)step */ | |
63ee5404 | 2725 | tmp = fold_build2_loc (loc, GT_EXPR, logical_type_node, to, from); |
c5e7e996 RB |
2726 | tmp2 = fold_build2_loc (loc, TRUNC_DIV_EXPR, utype, |
2727 | fold_build2_loc (loc, MINUS_EXPR, utype, | |
2728 | fromu, tou), | |
2729 | fold_build1_loc (loc, NEGATE_EXPR, utype, stepu)); | |
d17271de RB |
2730 | neg = build2 (COMPOUND_EXPR, void_type_node, |
2731 | fold_build2 (MODIFY_EXPR, void_type_node, | |
2732 | countm1, tmp2), | |
7119f1b1 ML |
2733 | build3_loc (loc, COND_EXPR, void_type_node, |
2734 | gfc_unlikely (tmp, PRED_FORTRAN_LOOP_PREHEADER), | |
d17271de RB |
2735 | build1_loc (loc, GOTO_EXPR, void_type_node, |
2736 | exit_label), NULL_TREE)); | |
8146bb58 | 2737 | |
63ee5404 | 2738 | tmp = fold_build2_loc (loc, LT_EXPR, logical_type_node, step, |
c5e7e996 RB |
2739 | build_int_cst (TREE_TYPE (step), 0)); |
2740 | tmp = fold_build3_loc (loc, COND_EXPR, void_type_node, tmp, neg, pos); | |
8146bb58 | 2741 | |
c0b29099 | 2742 | gfc_add_expr_to_block (&block, tmp); |
8d5cfa27 SK |
2743 | } |
2744 | else | |
2745 | { | |
c5e7e996 RB |
2746 | tree pos_step; |
2747 | ||
8d5cfa27 SK |
2748 | /* TODO: We could use the same width as the real type. |
2749 | This would probably cause more problems that it solves | |
2750 | when we implement "long double" types. */ | |
c0b29099 | 2751 | |
55bd9c35 TB |
2752 | tmp = fold_build2_loc (loc, MINUS_EXPR, type, to, from); |
2753 | tmp = fold_build2_loc (loc, RDIV_EXPR, type, tmp, step); | |
2754 | tmp = fold_build1_loc (loc, FIX_TRUNC_EXPR, utype, tmp); | |
c0b29099 JJ |
2755 | gfc_add_modify (&block, countm1, tmp); |
2756 | ||
2757 | /* We need a special check for empty loops: | |
2758 | empty = (step > 0 ? to < from : to > from); */ | |
63ee5404 | 2759 | pos_step = fold_build2_loc (loc, GT_EXPR, logical_type_node, step, |
c5e7e996 | 2760 | build_zero_cst (type)); |
63ee5404 | 2761 | tmp = fold_build3_loc (loc, COND_EXPR, logical_type_node, pos_step, |
55bd9c35 | 2762 | fold_build2_loc (loc, LT_EXPR, |
63ee5404 | 2763 | logical_type_node, to, from), |
55bd9c35 | 2764 | fold_build2_loc (loc, GT_EXPR, |
63ee5404 | 2765 | logical_type_node, to, from)); |
c0b29099 | 2766 | /* If the loop is empty, go directly to the exit label. */ |
55bd9c35 | 2767 | tmp = fold_build3_loc (loc, COND_EXPR, void_type_node, tmp, |
c0b29099 | 2768 | build1_v (GOTO_EXPR, exit_label), |
c2255bc4 | 2769 | build_empty_stmt (input_location)); |
c0b29099 | 2770 | gfc_add_expr_to_block (&block, tmp); |
8d5cfa27 | 2771 | } |
5d148c08 | 2772 | |
6de9cd9a DN |
2773 | /* Loop body. */ |
2774 | gfc_start_block (&body); | |
2775 | ||
6de9cd9a | 2776 | /* Main loop body. */ |
bc51e726 | 2777 | tmp = gfc_trans_code_cond (code->block->next, exit_cond); |
6de9cd9a DN |
2778 | gfc_add_expr_to_block (&body, tmp); |
2779 | ||
2780 | /* Label for cycle statements (if needed). */ | |
2781 | if (TREE_USED (cycle_label)) | |
2782 | { | |
2783 | tmp = build1_v (LABEL_EXPR, cycle_label); | |
2784 | gfc_add_expr_to_block (&body, tmp); | |
2785 | } | |
2786 | ||
1cc0e193 | 2787 | /* Check whether someone has modified the loop variable. */ |
33abc845 TB |
2788 | if (gfc_option.rtcheck & GFC_RTCHECK_DO) |
2789 | { | |
63ee5404 | 2790 | tmp = fold_build2_loc (loc, NE_EXPR, logical_type_node, dovar, |
bc98ed60 | 2791 | saved_dovar); |
33abc845 TB |
2792 | gfc_trans_runtime_check (true, false, tmp, &body, &code->loc, |
2793 | "Loop variable has been modified"); | |
2794 | } | |
2795 | ||
bc51e726 JD |
2796 | /* Exit the loop if there is an I/O result condition or error. */ |
2797 | if (exit_cond) | |
2798 | { | |
2799 | tmp = build1_v (GOTO_EXPR, exit_label); | |
55bd9c35 | 2800 | tmp = fold_build3_loc (loc, COND_EXPR, void_type_node, |
bc98ed60 TB |
2801 | exit_cond, tmp, |
2802 | build_empty_stmt (input_location)); | |
bc51e726 JD |
2803 | gfc_add_expr_to_block (&body, tmp); |
2804 | } | |
2805 | ||
244974bd | 2806 | /* Increment the loop variable. */ |
55bd9c35 TB |
2807 | tmp = fold_build2_loc (loc, PLUS_EXPR, type, dovar, step); |
2808 | gfc_add_modify_loc (loc, &body, dovar, tmp); | |
244974bd | 2809 | |
33abc845 | 2810 | if (gfc_option.rtcheck & GFC_RTCHECK_DO) |
55bd9c35 | 2811 | gfc_add_modify_loc (loc, &body, saved_dovar, dovar); |
33abc845 | 2812 | |
8c01de7f JJ |
2813 | /* Initialize countm1t. */ |
2814 | tree countm1t = gfc_create_var (utype, "countm1t"); | |
2815 | gfc_add_modify_loc (loc, &body, countm1t, countm1); | |
5d148c08 | 2816 | |
6de9cd9a | 2817 | /* Decrement the loop count. */ |
55bd9c35 | 2818 | tmp = fold_build2_loc (loc, MINUS_EXPR, utype, countm1, |
bc98ed60 | 2819 | build_int_cst (utype, 1)); |
55bd9c35 | 2820 | gfc_add_modify_loc (loc, &body, countm1, tmp); |
6de9cd9a | 2821 | |
8c01de7f | 2822 | /* End with the loop condition. Loop until countm1t == 0. */ |
63ee5404 | 2823 | cond = fold_build2_loc (loc, EQ_EXPR, logical_type_node, countm1t, |
8c01de7f | 2824 | build_int_cst (utype, 0)); |
9935667a | 2825 | if (code->ext.iterator->annot.unroll && cond != error_mark_node) |
170a8bd6 EB |
2826 | cond |
2827 | = build3 (ANNOTATE_EXPR, TREE_TYPE (cond), cond, | |
2828 | build_int_cst (integer_type_node, annot_expr_unroll_kind), | |
9935667a HA |
2829 | build_int_cst (integer_type_node, |
2830 | code->ext.iterator->annot.unroll)); | |
2bd86b95 | 2831 | |
9935667a | 2832 | if (code->ext.iterator->annot.ivdep && cond != error_mark_node) |
2bd86b95 HA |
2833 | cond = build3 (ANNOTATE_EXPR, TREE_TYPE (cond), cond, |
2834 | build_int_cst (integer_type_node, annot_expr_ivdep_kind), | |
2835 | integer_zero_node); | |
9935667a | 2836 | if (code->ext.iterator->annot.vector && cond != error_mark_node) |
2bd86b95 HA |
2837 | cond = build3 (ANNOTATE_EXPR, TREE_TYPE (cond), cond, |
2838 | build_int_cst (integer_type_node, annot_expr_vector_kind), | |
2839 | integer_zero_node); | |
9935667a | 2840 | if (code->ext.iterator->annot.novector && cond != error_mark_node) |
2bd86b95 HA |
2841 | cond = build3 (ANNOTATE_EXPR, TREE_TYPE (cond), cond, |
2842 | build_int_cst (integer_type_node, annot_expr_no_vector_kind), | |
2843 | integer_zero_node); | |
2844 | ||
8c01de7f JJ |
2845 | tmp = fold_build1_loc (loc, GOTO_EXPR, void_type_node, exit_label); |
2846 | tmp = fold_build3_loc (loc, COND_EXPR, void_type_node, | |
2847 | cond, tmp, build_empty_stmt (loc)); | |
2848 | gfc_add_expr_to_block (&body, tmp); | |
2849 | ||
6de9cd9a DN |
2850 | /* End of loop body. */ |
2851 | tmp = gfc_finish_block (&body); | |
2852 | ||
2853 | /* The for loop itself. */ | |
55bd9c35 | 2854 | tmp = fold_build1_loc (loc, LOOP_EXPR, void_type_node, tmp); |
6de9cd9a DN |
2855 | gfc_add_expr_to_block (&block, tmp); |
2856 | ||
2857 | /* Add the exit label. */ | |
2858 | tmp = build1_v (LABEL_EXPR, exit_label); | |
2859 | gfc_add_expr_to_block (&block, tmp); | |
2860 | ||
2861 | return gfc_finish_block (&block); | |
2862 | } | |
2863 | ||
2864 | ||
2865 | /* Translate the DO WHILE construct. | |
2866 | ||
2867 | We translate | |
2868 | ||
2869 | DO WHILE (cond) | |
2870 | body | |
2871 | END DO | |
2872 | ||
2873 | to: | |
2874 | ||
2875 | for ( ; ; ) | |
2876 | { | |
2877 | pre_cond; | |
2878 | if (! cond) goto exit_label; | |
2879 | body; | |
2880 | cycle_label: | |
2881 | } | |
2882 | exit_label: | |
2883 | ||
2884 | Because the evaluation of the exit condition `cond' may have side | |
2885 | effects, we can't do much for empty loop bodies. The backend optimizers | |
2886 | should be smart enough to eliminate any dead loops. */ | |
2887 | ||
2888 | tree | |
2889 | gfc_trans_do_while (gfc_code * code) | |
2890 | { | |
2891 | gfc_se cond; | |
2892 | tree tmp; | |
2893 | tree cycle_label; | |
2894 | tree exit_label; | |
2895 | stmtblock_t block; | |
2896 | ||
2897 | /* Everything we build here is part of the loop body. */ | |
2898 | gfc_start_block (&block); | |
2899 | ||
2900 | /* Cycle and exit statements are implemented with gotos. */ | |
2901 | cycle_label = gfc_build_label_decl (NULL_TREE); | |
2902 | exit_label = gfc_build_label_decl (NULL_TREE); | |
2903 | ||
2904 | /* Put the labels where they can be found later. See gfc_trans_do(). */ | |
e5ca9693 DK |
2905 | code->cycle_label = cycle_label; |
2906 | code->exit_label = exit_label; | |
6de9cd9a DN |
2907 | |
2908 | /* Create a GIMPLE version of the exit condition. */ | |
2909 | gfc_init_se (&cond, NULL); | |
a513927a | 2910 | gfc_conv_expr_val (&cond, code->expr1); |
6de9cd9a | 2911 | gfc_add_block_to_block (&block, &cond.pre); |
9c81750c TB |
2912 | cond.expr = fold_build1_loc (gfc_get_location (&code->expr1->where), |
2913 | TRUTH_NOT_EXPR, TREE_TYPE (cond.expr), | |
2914 | cond.expr); | |
6de9cd9a DN |
2915 | |
2916 | /* Build "IF (! cond) GOTO exit_label". */ | |
2917 | tmp = build1_v (GOTO_EXPR, exit_label); | |
2918 | TREE_USED (exit_label) = 1; | |
9c81750c | 2919 | tmp = fold_build3_loc (gfc_get_location (&code->expr1->where), COND_EXPR, |
55bd9c35 | 2920 | void_type_node, cond.expr, tmp, |
9c81750c TB |
2921 | build_empty_stmt (gfc_get_location ( |
2922 | &code->expr1->where))); | |
6de9cd9a DN |
2923 | gfc_add_expr_to_block (&block, tmp); |
2924 | ||
2925 | /* The main body of the loop. */ | |
2926 | tmp = gfc_trans_code (code->block->next); | |
2927 | gfc_add_expr_to_block (&block, tmp); | |
2928 | ||
2929 | /* Label for cycle statements (if needed). */ | |
2930 | if (TREE_USED (cycle_label)) | |
2931 | { | |
2932 | tmp = build1_v (LABEL_EXPR, cycle_label); | |
2933 | gfc_add_expr_to_block (&block, tmp); | |
2934 | } | |
2935 | ||
2936 | /* End of loop body. */ | |
2937 | tmp = gfc_finish_block (&block); | |
2938 | ||
2939 | gfc_init_block (&block); | |
2940 | /* Build the loop. */ | |
9c81750c | 2941 | tmp = fold_build1_loc (gfc_get_location (&code->expr1->where), LOOP_EXPR, |
55bd9c35 | 2942 | void_type_node, tmp); |
6de9cd9a DN |
2943 | gfc_add_expr_to_block (&block, tmp); |
2944 | ||
2945 | /* Add the exit label. */ | |
2946 | tmp = build1_v (LABEL_EXPR, exit_label); | |
2947 | gfc_add_expr_to_block (&block, tmp); | |
2948 | ||
2949 | return gfc_finish_block (&block); | |
2950 | } | |
2951 | ||
2952 | ||
dfd6231e PT |
2953 | /* Deal with the particular case of SELECT_TYPE, where the vtable |
2954 | addresses are used for the selection. Since these are not sorted, | |
2955 | the selection has to be made by a series of if statements. */ | |
2956 | ||
2957 | static tree | |
2958 | gfc_trans_select_type_cases (gfc_code * code) | |
2959 | { | |
2960 | gfc_code *c; | |
2961 | gfc_case *cp; | |
2962 | tree tmp; | |
2963 | tree cond; | |
2964 | tree low; | |
2965 | tree high; | |
2966 | gfc_se se; | |
2967 | gfc_se cse; | |
2968 | stmtblock_t block; | |
2969 | stmtblock_t body; | |
2970 | bool def = false; | |
2971 | gfc_expr *e; | |
2972 | gfc_start_block (&block); | |
2973 | ||
2974 | /* Calculate the switch expression. */ | |
2975 | gfc_init_se (&se, NULL); | |
2976 | gfc_conv_expr_val (&se, code->expr1); | |
2977 | gfc_add_block_to_block (&block, &se.pre); | |
2978 | ||
2979 | /* Generate an expression for the selector hash value, for | |
2980 | use to resolve character cases. */ | |
2981 | e = gfc_copy_expr (code->expr1->value.function.actual->expr); | |
2982 | gfc_add_hash_component (e); | |
2983 | ||
2984 | TREE_USED (code->exit_label) = 0; | |
2985 | ||
2986 | repeat: | |
2987 | for (c = code->block; c; c = c->block) | |
2988 | { | |
2989 | cp = c->ext.block.case_list; | |
2990 | ||
2991 | /* Assume it's the default case. */ | |
2992 | low = NULL_TREE; | |
2993 | high = NULL_TREE; | |
2994 | tmp = NULL_TREE; | |
2995 | ||
2996 | /* Put the default case at the end. */ | |
2997 | if ((!def && !cp->low) || (def && cp->low)) | |
2998 | continue; | |
2999 | ||
3000 | if (cp->low && (cp->ts.type == BT_CLASS | |
3001 | || cp->ts.type == BT_DERIVED)) | |
3002 | { | |
3003 | gfc_init_se (&cse, NULL); | |
3004 | gfc_conv_expr_val (&cse, cp->low); | |
3005 | gfc_add_block_to_block (&block, &cse.pre); | |
3006 | low = cse.expr; | |
3007 | } | |
3008 | else if (cp->ts.type != BT_UNKNOWN) | |
3009 | { | |
3010 | gcc_assert (cp->high); | |
3011 | gfc_init_se (&cse, NULL); | |
3012 | gfc_conv_expr_val (&cse, cp->high); | |
3013 | gfc_add_block_to_block (&block, &cse.pre); | |
3014 | high = cse.expr; | |
3015 | } | |
3016 | ||
3017 | gfc_init_block (&body); | |
3018 | ||
3019 | /* Add the statements for this case. */ | |
3020 | tmp = gfc_trans_code (c->next); | |
3021 | gfc_add_expr_to_block (&body, tmp); | |
3022 | ||
3023 | /* Break to the end of the SELECT TYPE construct. The default | |
3024 | case just falls through. */ | |
3025 | if (!def) | |
3026 | { | |
3027 | TREE_USED (code->exit_label) = 1; | |
3028 | tmp = build1_v (GOTO_EXPR, code->exit_label); | |
3029 | gfc_add_expr_to_block (&body, tmp); | |
3030 | } | |
3031 | ||
3032 | tmp = gfc_finish_block (&body); | |
3033 | ||
3034 | if (low != NULL_TREE) | |
3035 | { | |
3036 | /* Compare vtable pointers. */ | |
3037 | cond = fold_build2_loc (input_location, EQ_EXPR, | |
3038 | TREE_TYPE (se.expr), se.expr, low); | |
3039 | tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, | |
3040 | cond, tmp, | |
3041 | build_empty_stmt (input_location)); | |
3042 | } | |
3043 | else if (high != NULL_TREE) | |
3044 | { | |
3045 | /* Compare hash values for character cases. */ | |
3046 | gfc_init_se (&cse, NULL); | |
3047 | gfc_conv_expr_val (&cse, e); | |
3048 | gfc_add_block_to_block (&block, &cse.pre); | |
3049 | ||
3050 | cond = fold_build2_loc (input_location, EQ_EXPR, | |
3051 | TREE_TYPE (se.expr), high, cse.expr); | |
3052 | tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, | |
3053 | cond, tmp, | |
3054 | build_empty_stmt (input_location)); | |
3055 | } | |
3056 | ||
3057 | gfc_add_expr_to_block (&block, tmp); | |
3058 | } | |
3059 | ||
3060 | if (!def) | |
3061 | { | |
3062 | def = true; | |
3063 | goto repeat; | |
3064 | } | |
3065 | ||
3066 | gfc_free_expr (e); | |
3067 | ||
3068 | return gfc_finish_block (&block); | |
3069 | } | |
3070 | ||
3071 | ||
6de9cd9a DN |
3072 | /* Translate the SELECT CASE construct for INTEGER case expressions, |
3073 | without killing all potential optimizations. The problem is that | |
3074 | Fortran allows unbounded cases, but the back-end does not, so we | |
3075 | need to intercept those before we enter the equivalent SWITCH_EXPR | |
3076 | we can build. | |
3077 | ||
3078 | For example, we translate this, | |
3079 | ||
3080 | SELECT CASE (expr) | |
3081 | CASE (:100,101,105:115) | |
3082 | block_1 | |
3083 | CASE (190:199,200:) | |
3084 | block_2 | |
3085 | CASE (300) | |
3086 | block_3 | |
3087 | CASE DEFAULT | |
3088 | block_4 | |
3089 | END SELECT | |
3090 | ||
3091 | to the GENERIC equivalent, | |
3092 | ||
3093 | switch (expr) | |
3094 | { | |
3095 | case (minimum value for typeof(expr) ... 100: | |
3096 | case 101: | |
3097 | case 105 ... 114: | |
3098 | block1: | |
3099 | goto end_label; | |
3100 | ||
3101 | case 200 ... (maximum value for typeof(expr): | |
3102 | case 190 ... 199: | |
3103 | block2; | |
3104 | goto end_label; | |
3105 | ||
3106 | case 300: | |
3107 | block_3; | |
3108 | goto end_label; | |
3109 | ||
3110 | default: | |
3111 | block_4; | |
3112 | goto end_label; | |
3113 | } | |
3114 | ||
3115 | end_label: */ | |
3116 | ||
3117 | static tree | |
3118 | gfc_trans_integer_select (gfc_code * code) | |
3119 | { | |
3120 | gfc_code *c; | |
3121 | gfc_case *cp; | |
3122 | tree end_label; | |
3123 | tree tmp; | |
3124 | gfc_se se; | |
3125 | stmtblock_t block; | |
3126 | stmtblock_t body; | |
3127 | ||
3128 | gfc_start_block (&block); | |
3129 | ||
3130 | /* Calculate the switch expression. */ | |
3131 | gfc_init_se (&se, NULL); | |
a513927a | 3132 | gfc_conv_expr_val (&se, code->expr1); |
6de9cd9a DN |
3133 | gfc_add_block_to_block (&block, &se.pre); |
3134 | ||
3135 | end_label = gfc_build_label_decl (NULL_TREE); | |
3136 | ||
3137 | gfc_init_block (&body); | |
3138 | ||
3139 | for (c = code->block; c; c = c->block) | |
3140 | { | |
29a63d67 | 3141 | for (cp = c->ext.block.case_list; cp; cp = cp->next) |
6de9cd9a DN |
3142 | { |
3143 | tree low, high; | |
3144 | tree label; | |
3145 | ||
3146 | /* Assume it's the default case. */ | |
3147 | low = high = NULL_TREE; | |
3148 | ||
3149 | if (cp->low) | |
3150 | { | |
20585ad6 BM |
3151 | low = gfc_conv_mpz_to_tree (cp->low->value.integer, |
3152 | cp->low->ts.kind); | |
6de9cd9a DN |
3153 | |
3154 | /* If there's only a lower bound, set the high bound to the | |
3155 | maximum value of the case expression. */ | |
3156 | if (!cp->high) | |
3157 | high = TYPE_MAX_VALUE (TREE_TYPE (se.expr)); | |
3158 | } | |
3159 | ||
3160 | if (cp->high) | |
3161 | { | |
3162 | /* Three cases are possible here: | |
3163 | ||
3164 | 1) There is no lower bound, e.g. CASE (:N). | |
3165 | 2) There is a lower bound .NE. high bound, that is | |
3166 | a case range, e.g. CASE (N:M) where M>N (we make | |
3167 | sure that M>N during type resolution). | |
3168 | 3) There is a lower bound, and it has the same value | |
3169 | as the high bound, e.g. CASE (N:N). This is our | |
3170 | internal representation of CASE(N). | |
3171 | ||
3172 | In the first and second case, we need to set a value for | |
e2ae1407 | 3173 | high. In the third case, we don't because the GCC middle |
6de9cd9a DN |
3174 | end represents a single case value by just letting high be |
3175 | a NULL_TREE. We can't do that because we need to be able | |
3176 | to represent unbounded cases. */ | |
3177 | ||
3178 | if (!cp->low | |
b2954e12 SK |
3179 | || (mpz_cmp (cp->low->value.integer, |
3180 | cp->high->value.integer) != 0)) | |
20585ad6 BM |
3181 | high = gfc_conv_mpz_to_tree (cp->high->value.integer, |
3182 | cp->high->ts.kind); | |
6de9cd9a DN |
3183 | |
3184 | /* Unbounded case. */ | |
3185 | if (!cp->low) | |
3186 | low = TYPE_MIN_VALUE (TREE_TYPE (se.expr)); | |
3187 | } | |
3188 | ||
3189 | /* Build a label. */ | |
c006df4e | 3190 | label = gfc_build_label_decl (NULL_TREE); |
6de9cd9a DN |
3191 | |
3192 | /* Add this case label. | |
3193 | Add parameter 'label', make it match GCC backend. */ | |
3d528853 | 3194 | tmp = build_case_label (low, high, label); |
6de9cd9a DN |
3195 | gfc_add_expr_to_block (&body, tmp); |
3196 | } | |
3197 | ||
3198 | /* Add the statements for this case. */ | |
3199 | tmp = gfc_trans_code (c->next); | |
3200 | gfc_add_expr_to_block (&body, tmp); | |
3201 | ||
3202 | /* Break to the end of the construct. */ | |
3203 | tmp = build1_v (GOTO_EXPR, end_label); | |
3204 | gfc_add_expr_to_block (&body, tmp); | |
3205 | } | |
3206 | ||
3207 | tmp = gfc_finish_block (&body); | |
9e851845 | 3208 | tmp = fold_build2_loc (input_location, SWITCH_EXPR, NULL_TREE, se.expr, tmp); |
6de9cd9a DN |
3209 | gfc_add_expr_to_block (&block, tmp); |
3210 | ||
3211 | tmp = build1_v (LABEL_EXPR, end_label); | |
3212 | gfc_add_expr_to_block (&block, tmp); | |
3213 | ||
3214 | return gfc_finish_block (&block); | |
3215 | } | |
3216 | ||
3217 | ||
3218 | /* Translate the SELECT CASE construct for LOGICAL case expressions. | |
3219 | ||
3220 | There are only two cases possible here, even though the standard | |
3221 | does allow three cases in a LOGICAL SELECT CASE construct: .TRUE., | |
3222 | .FALSE., and DEFAULT. | |
3223 | ||
3224 | We never generate more than two blocks here. Instead, we always | |
3225 | try to eliminate the DEFAULT case. This way, we can translate this | |
3226 | kind of SELECT construct to a simple | |
3227 | ||
3228 | if {} else {}; | |
3229 | ||
3230 | expression in GENERIC. */ | |
3231 | ||
3232 | static tree | |
3233 | gfc_trans_logical_select (gfc_code * code) | |
3234 | { | |
3235 | gfc_code *c; | |
3236 | gfc_code *t, *f, *d; | |
3237 | gfc_case *cp; | |
3238 | gfc_se se; | |
3239 | stmtblock_t block; | |
3240 | ||
3241 | /* Assume we don't have any cases at all. */ | |
3242 | t = f = d = NULL; | |
3243 | ||
3244 | /* Now see which ones we actually do have. We can have at most two | |
3245 | cases in a single case list: one for .TRUE. and one for .FALSE. | |
3246 | The default case is always separate. If the cases for .TRUE. and | |
3247 | .FALSE. are in the same case list, the block for that case list | |
3248 | always executed, and we don't generate code a COND_EXPR. */ | |
3249 | for (c = code->block; c; c = c->block) | |
3250 | { | |
29a63d67 | 3251 | for (cp = c->ext.block.case_list; cp; cp = cp->next) |
6de9cd9a DN |
3252 | { |
3253 | if (cp->low) | |
3254 | { | |
3255 | if (cp->low->value.logical == 0) /* .FALSE. */ | |
3256 | f = c; | |
3257 | else /* if (cp->value.logical != 0), thus .TRUE. */ | |
3258 | t = c; | |
3259 | } | |
3260 | else | |
3261 | d = c; | |
3262 | } | |
3263 | } | |
3264 | ||
3265 | /* Start a new block. */ | |
3266 | gfc_start_block (&block); | |
3267 | ||
3268 | /* Calculate the switch expression. We always need to do this | |
3269 | because it may have side effects. */ | |
3270 | gfc_init_se (&se, NULL); | |
a513927a | 3271 | gfc_conv_expr_val (&se, code->expr1); |
6de9cd9a DN |
3272 | gfc_add_block_to_block (&block, &se.pre); |
3273 | ||
3274 | if (t == f && t != NULL) | |
3275 | { | |
3276 | /* Cases for .TRUE. and .FALSE. are in the same block. Just | |
3277 | translate the code for these cases, append it to the current | |
3278 | block. */ | |
3279 | gfc_add_expr_to_block (&block, gfc_trans_code (t->next)); | |
3280 | } | |
3281 | else | |
3282 | { | |
61ead135 | 3283 | tree true_tree, false_tree, stmt; |
6de9cd9a | 3284 | |
c2255bc4 AH |
3285 | true_tree = build_empty_stmt (input_location); |
3286 | false_tree = build_empty_stmt (input_location); | |
6de9cd9a DN |
3287 | |
3288 | /* If we have a case for .TRUE. and for .FALSE., discard the default case. | |
3289 | Otherwise, if .TRUE. or .FALSE. is missing and there is a default case, | |
3290 | make the missing case the default case. */ | |
3291 | if (t != NULL && f != NULL) | |
3292 | d = NULL; | |
3293 | else if (d != NULL) | |
3294 | { | |
3295 | if (t == NULL) | |
3296 | t = d; | |
3297 | else | |
3298 | f = d; | |
3299 | } | |
3300 | ||
3301 | /* Translate the code for each of these blocks, and append it to | |
3302 | the current block. */ | |
3303 | if (t != NULL) | |
3304 | true_tree = gfc_trans_code (t->next); | |
3305 | ||
3306 | if (f != NULL) | |
3307 | false_tree = gfc_trans_code (f->next); | |
3308 | ||
bc98ed60 TB |
3309 | stmt = fold_build3_loc (input_location, COND_EXPR, void_type_node, |
3310 | se.expr, true_tree, false_tree); | |
61ead135 | 3311 | gfc_add_expr_to_block (&block, stmt); |
6de9cd9a DN |
3312 | } |
3313 | ||
3314 | return gfc_finish_block (&block); | |
3315 | } | |
3316 | ||
3317 | ||
d2886bc7 JJ |
3318 | /* The jump table types are stored in static variables to avoid |
3319 | constructing them from scratch every single time. */ | |
3320 | static GTY(()) tree select_struct[2]; | |
3321 | ||
6de9cd9a DN |
3322 | /* Translate the SELECT CASE construct for CHARACTER case expressions. |
3323 | Instead of generating compares and jumps, it is far simpler to | |
3324 | generate a data structure describing the cases in order and call a | |
3325 | library subroutine that locates the right case. | |
3326 | This is particularly true because this is the only case where we | |
3327 | might have to dispose of a temporary. | |
3328 | The library subroutine returns a pointer to jump to or NULL if no | |
3329 | branches are to be taken. */ | |
3330 | ||
3331 | static tree | |
3332 | gfc_trans_character_select (gfc_code *code) | |
3333 | { | |
8748ad99 | 3334 | tree init, end_label, tmp, type, case_num, label, fndecl; |
6de9cd9a DN |
3335 | stmtblock_t block, body; |
3336 | gfc_case *cp, *d; | |
3337 | gfc_code *c; | |
d2886bc7 | 3338 | gfc_se se, expr1se; |
d393bbd7 | 3339 | int n, k; |
9771b263 | 3340 | vec<constructor_elt, va_gc> *inits = NULL; |
d393bbd7 | 3341 | |
d2886bc7 JJ |
3342 | tree pchartype = gfc_get_pchar_type (code->expr1->ts.kind); |
3343 | ||
d393bbd7 FXC |
3344 | /* The jump table types are stored in static variables to avoid |
3345 | constructing them from scratch every single time. */ | |
d393bbd7 FXC |
3346 | static tree ss_string1[2], ss_string1_len[2]; |
3347 | static tree ss_string2[2], ss_string2_len[2]; | |
3348 | static tree ss_target[2]; | |
3349 | ||
29a63d67 | 3350 | cp = code->block->ext.block.case_list; |
d2886bc7 JJ |
3351 | while (cp->left != NULL) |
3352 | cp = cp->left; | |
3353 | ||
3354 | /* Generate the body */ | |
3355 | gfc_start_block (&block); | |
3356 | gfc_init_se (&expr1se, NULL); | |
3357 | gfc_conv_expr_reference (&expr1se, code->expr1); | |
3358 | ||
3359 | gfc_add_block_to_block (&block, &expr1se.pre); | |
3360 | ||
3361 | end_label = gfc_build_label_decl (NULL_TREE); | |
3362 | ||
3363 | gfc_init_block (&body); | |
3364 | ||
3365 | /* Attempt to optimize length 1 selects. */ | |
86e033e2 | 3366 | if (integer_onep (expr1se.string_length)) |
d2886bc7 JJ |
3367 | { |
3368 | for (d = cp; d; d = d->right) | |
3369 | { | |
f622221a | 3370 | gfc_charlen_t i; |
d2886bc7 JJ |
3371 | if (d->low) |
3372 | { | |
3373 | gcc_assert (d->low->expr_type == EXPR_CONSTANT | |
3374 | && d->low->ts.type == BT_CHARACTER); | |
3375 | if (d->low->value.character.length > 1) | |
3376 | { | |
3377 | for (i = 1; i < d->low->value.character.length; i++) | |
3378 | if (d->low->value.character.string[i] != ' ') | |
3379 | break; | |
3380 | if (i != d->low->value.character.length) | |
3381 | { | |
3382 | if (optimize && d->high && i == 1) | |
3383 | { | |
3384 | gcc_assert (d->high->expr_type == EXPR_CONSTANT | |
3385 | && d->high->ts.type == BT_CHARACTER); | |
3386 | if (d->high->value.character.length > 1 | |
3387 | && (d->low->value.character.string[0] | |
3388 | == d->high->value.character.string[0]) | |
3389 | && d->high->value.character.string[1] != ' ' | |
3390 | && ((d->low->value.character.string[1] < ' ') | |
3391 | == (d->high->value.character.string[1] | |
3392 | < ' '))) | |
3393 | continue; | |
3394 | } | |
3395 | break; | |
3396 | } | |
3397 | } | |
3398 | } | |
3399 | if (d->high) | |
3400 | { | |
3401 | gcc_assert (d->high->expr_type == EXPR_CONSTANT | |
3402 | && d->high->ts.type == BT_CHARACTER); | |
3403 | if (d->high->value.character.length > 1) | |
3404 | { | |
3405 | for (i = 1; i < d->high->value.character.length; i++) | |
3406 | if (d->high->value.character.string[i] != ' ') | |
3407 | break; | |
3408 | if (i != d->high->value.character.length) | |
3409 | break; | |
3410 | } | |
3411 | } | |
3412 | } | |
3413 | if (d == NULL) | |
3414 | { | |
3415 | tree ctype = gfc_get_char_type (code->expr1->ts.kind); | |
3416 | ||
3417 | for (c = code->block; c; c = c->block) | |
3418 | { | |
29a63d67 | 3419 | for (cp = c->ext.block.case_list; cp; cp = cp->next) |
d2886bc7 JJ |
3420 | { |
3421 | tree low, high; | |
3422 | tree label; | |
3423 | gfc_char_t r; | |
3424 | ||
3425 | /* Assume it's the default case. */ | |
3426 | low = high = NULL_TREE; | |
3427 | ||
3428 | if (cp->low) | |
3429 | { | |
3430 | /* CASE ('ab') or CASE ('ab':'az') will never match | |
3431 | any length 1 character. */ | |
3432 | if (cp->low->value.character.length > 1 | |
3433 | && cp->low->value.character.string[1] != ' ') | |
3434 | continue; | |
3435 | ||
3436 | if (cp->low->value.character.length > 0) | |
3437 | r = cp->low->value.character.string[0]; | |
3438 | else | |
3439 | r = ' '; | |
3440 | low = build_int_cst (ctype, r); | |
3441 | ||
3442 | /* If there's only a lower bound, set the high bound | |
3443 | to the maximum value of the case expression. */ | |
3444 | if (!cp->high) | |
3445 | high = TYPE_MAX_VALUE (ctype); | |
3446 | } | |
3447 | ||
3448 | if (cp->high) | |
3449 | { | |
3450 | if (!cp->low | |
3451 | || (cp->low->value.character.string[0] | |
3452 | != cp->high->value.character.string[0])) | |
3453 | { | |
3454 | if (cp->high->value.character.length > 0) | |
3455 | r = cp->high->value.character.string[0]; | |
3456 | else | |
3457 | r = ' '; | |
3458 | high = build_int_cst (ctype, r); | |
3459 | } | |
3460 | ||
3461 | /* Unbounded case. */ | |
3462 | if (!cp->low) | |
3463 | low = TYPE_MIN_VALUE (ctype); | |
3464 | } | |
3465 | ||
3466 | /* Build a label. */ | |
3467 | label = gfc_build_label_decl (NULL_TREE); | |
3468 | ||
3469 | /* Add this case label. | |
3470 | Add parameter 'label', make it match GCC backend. */ | |
3d528853 | 3471 | tmp = build_case_label (low, high, label); |
d2886bc7 JJ |
3472 | gfc_add_expr_to_block (&body, tmp); |
3473 | } | |
3474 | ||
3475 | /* Add the statements for this case. */ | |
3476 | tmp = gfc_trans_code (c->next); | |
3477 | gfc_add_expr_to_block (&body, tmp); | |
3478 | ||
3479 | /* Break to the end of the construct. */ | |
3480 | tmp = build1_v (GOTO_EXPR, end_label); | |
3481 | gfc_add_expr_to_block (&body, tmp); | |
3482 | } | |
3483 | ||
3484 | tmp = gfc_string_to_single_character (expr1se.string_length, | |
3485 | expr1se.expr, | |
3486 | code->expr1->ts.kind); | |
3487 | case_num = gfc_create_var (ctype, "case_num"); | |
3488 | gfc_add_modify (&block, case_num, tmp); | |
3489 | ||
3490 | gfc_add_block_to_block (&block, &expr1se.post); | |
3491 | ||
3492 | tmp = gfc_finish_block (&body); | |
9e851845 JJ |
3493 | tmp = fold_build2_loc (input_location, SWITCH_EXPR, NULL_TREE, |
3494 | case_num, tmp); | |
d2886bc7 JJ |
3495 | gfc_add_expr_to_block (&block, tmp); |
3496 | ||
3497 | tmp = build1_v (LABEL_EXPR, end_label); | |
3498 | gfc_add_expr_to_block (&block, tmp); | |
3499 | ||
3500 | return gfc_finish_block (&block); | |
3501 | } | |
3502 | } | |
6de9cd9a | 3503 | |
a513927a | 3504 | if (code->expr1->ts.kind == 1) |
d393bbd7 | 3505 | k = 0; |
a513927a | 3506 | else if (code->expr1->ts.kind == 4) |
d393bbd7 FXC |
3507 | k = 1; |
3508 | else | |
3509 | gcc_unreachable (); | |
6de9cd9a | 3510 | |
d393bbd7 | 3511 | if (select_struct[k] == NULL) |
6de9cd9a | 3512 | { |
dfd6ece2 | 3513 | tree *chain = NULL; |
d393bbd7 | 3514 | select_struct[k] = make_node (RECORD_TYPE); |
e2cad04b | 3515 | |
a513927a | 3516 | if (code->expr1->ts.kind == 1) |
d393bbd7 | 3517 | TYPE_NAME (select_struct[k]) = get_identifier ("_jump_struct_char1"); |
a513927a | 3518 | else if (code->expr1->ts.kind == 4) |
d393bbd7 FXC |
3519 | TYPE_NAME (select_struct[k]) = get_identifier ("_jump_struct_char4"); |
3520 | else | |
3521 | gcc_unreachable (); | |
6de9cd9a DN |
3522 | |
3523 | #undef ADD_FIELD | |
35151cd5 MM |
3524 | #define ADD_FIELD(NAME, TYPE) \ |
3525 | ss_##NAME[k] = gfc_add_field_to_struct (select_struct[k], \ | |
3526 | get_identifier (stringize(NAME)), \ | |
3527 | TYPE, \ | |
3528 | &chain) | |
6de9cd9a | 3529 | |
d393bbd7 FXC |
3530 | ADD_FIELD (string1, pchartype); |
3531 | ADD_FIELD (string1_len, gfc_charlen_type_node); | |
6de9cd9a | 3532 | |
d393bbd7 FXC |
3533 | ADD_FIELD (string2, pchartype); |
3534 | ADD_FIELD (string2_len, gfc_charlen_type_node); | |
6de9cd9a | 3535 | |
dd52ecb0 | 3536 | ADD_FIELD (target, integer_type_node); |
6de9cd9a DN |
3537 | #undef ADD_FIELD |
3538 | ||
d393bbd7 | 3539 | gfc_finish_type (select_struct[k]); |
6de9cd9a DN |
3540 | } |
3541 | ||
6de9cd9a DN |
3542 | n = 0; |
3543 | for (d = cp; d; d = d->right) | |
3544 | d->n = n++; | |
3545 | ||
6de9cd9a DN |
3546 | for (c = code->block; c; c = c->block) |
3547 | { | |
29a63d67 | 3548 | for (d = c->ext.block.case_list; d; d = d->next) |
6de9cd9a | 3549 | { |
2b8327ce | 3550 | label = gfc_build_label_decl (NULL_TREE); |
3d528853 NF |
3551 | tmp = build_case_label ((d->low == NULL && d->high == NULL) |
3552 | ? NULL | |
3553 | : build_int_cst (integer_type_node, d->n), | |
3554 | NULL, label); | |
6de9cd9a DN |
3555 | gfc_add_expr_to_block (&body, tmp); |
3556 | } | |
3557 | ||
3558 | tmp = gfc_trans_code (c->next); | |
3559 | gfc_add_expr_to_block (&body, tmp); | |
3560 | ||
923ab88c | 3561 | tmp = build1_v (GOTO_EXPR, end_label); |
6de9cd9a DN |
3562 | gfc_add_expr_to_block (&body, tmp); |
3563 | } | |
3564 | ||
3565 | /* Generate the structure describing the branches */ | |
d2886bc7 | 3566 | for (d = cp; d; d = d->right) |
6de9cd9a | 3567 | { |
9771b263 | 3568 | vec<constructor_elt, va_gc> *node = NULL; |
6de9cd9a DN |
3569 | |
3570 | gfc_init_se (&se, NULL); | |
3571 | ||
3572 | if (d->low == NULL) | |
3573 | { | |
8748ad99 | 3574 | CONSTRUCTOR_APPEND_ELT (node, ss_string1[k], null_pointer_node); |
f622221a | 3575 | CONSTRUCTOR_APPEND_ELT (node, ss_string1_len[k], build_zero_cst (gfc_charlen_type_node)); |
6de9cd9a DN |
3576 | } |
3577 | else | |
3578 | { | |
3579 | gfc_conv_expr_reference (&se, d->low); | |
3580 | ||
8748ad99 NF |
3581 | CONSTRUCTOR_APPEND_ELT (node, ss_string1[k], se.expr); |
3582 | CONSTRUCTOR_APPEND_ELT (node, ss_string1_len[k], se.string_length); | |
6de9cd9a DN |
3583 | } |
3584 | ||
3585 | if (d->high == NULL) | |
3586 | { | |
8748ad99 | 3587 | CONSTRUCTOR_APPEND_ELT (node, ss_string2[k], null_pointer_node); |
f622221a | 3588 | CONSTRUCTOR_APPEND_ELT (node, ss_string2_len[k], build_zero_cst (gfc_charlen_type_node)); |
6de9cd9a DN |
3589 | } |
3590 | else | |
3591 | { | |
3592 | gfc_init_se (&se, NULL); | |
3593 | gfc_conv_expr_reference (&se, d->high); | |
3594 | ||
8748ad99 NF |
3595 | CONSTRUCTOR_APPEND_ELT (node, ss_string2[k], se.expr); |
3596 | CONSTRUCTOR_APPEND_ELT (node, ss_string2_len[k], se.string_length); | |
6de9cd9a DN |
3597 | } |
3598 | ||
8748ad99 NF |
3599 | CONSTRUCTOR_APPEND_ELT (node, ss_target[k], |
3600 | build_int_cst (integer_type_node, d->n)); | |
6de9cd9a | 3601 | |
8748ad99 NF |
3602 | tmp = build_constructor (select_struct[k], node); |
3603 | CONSTRUCTOR_APPEND_ELT (inits, NULL_TREE, tmp); | |
6de9cd9a DN |
3604 | } |
3605 | ||
d393bbd7 | 3606 | type = build_array_type (select_struct[k], |
df09d1d5 | 3607 | build_index_type (size_int (n-1))); |
6de9cd9a | 3608 | |
8748ad99 | 3609 | init = build_constructor (type, inits); |
6de9cd9a | 3610 | TREE_CONSTANT (init) = 1; |
6de9cd9a DN |
3611 | TREE_STATIC (init) = 1; |
3612 | /* Create a static variable to hold the jump table. */ | |
3613 | tmp = gfc_create_var (type, "jumptable"); | |
3614 | TREE_CONSTANT (tmp) = 1; | |
6de9cd9a | 3615 | TREE_STATIC (tmp) = 1; |
0f0707d1 | 3616 | TREE_READONLY (tmp) = 1; |
6de9cd9a DN |
3617 | DECL_INITIAL (tmp) = init; |
3618 | init = tmp; | |
3619 | ||
5039610b | 3620 | /* Build the library call */ |
6de9cd9a | 3621 | init = gfc_build_addr_expr (pvoid_type_node, init); |
6de9cd9a | 3622 | |
a513927a | 3623 | if (code->expr1->ts.kind == 1) |
d393bbd7 | 3624 | fndecl = gfor_fndecl_select_string; |
a513927a | 3625 | else if (code->expr1->ts.kind == 4) |
d393bbd7 FXC |
3626 | fndecl = gfor_fndecl_select_string_char4; |
3627 | else | |
3628 | gcc_unreachable (); | |
3629 | ||
db3927fb | 3630 | tmp = build_call_expr_loc (input_location, |
df09d1d5 RG |
3631 | fndecl, 4, init, |
3632 | build_int_cst (gfc_charlen_type_node, n), | |
d2886bc7 | 3633 | expr1se.expr, expr1se.string_length); |
dd52ecb0 | 3634 | case_num = gfc_create_var (integer_type_node, "case_num"); |
726a989a | 3635 | gfc_add_modify (&block, case_num, tmp); |
dc6c7714 | 3636 | |
d2886bc7 | 3637 | gfc_add_block_to_block (&block, &expr1se.post); |
dc6c7714 | 3638 | |
6de9cd9a | 3639 | tmp = gfc_finish_block (&body); |
9e851845 JJ |
3640 | tmp = fold_build2_loc (input_location, SWITCH_EXPR, NULL_TREE, |
3641 | case_num, tmp); | |
6de9cd9a | 3642 | gfc_add_expr_to_block (&block, tmp); |
2b8327ce | 3643 | |
923ab88c | 3644 | tmp = build1_v (LABEL_EXPR, end_label); |
6de9cd9a DN |
3645 | gfc_add_expr_to_block (&block, tmp); |
3646 | ||
6de9cd9a DN |
3647 | return gfc_finish_block (&block); |
3648 | } | |
3649 | ||
3650 | ||
3651 | /* Translate the three variants of the SELECT CASE construct. | |
3652 | ||
3653 | SELECT CASEs with INTEGER case expressions can be translated to an | |
3654 | equivalent GENERIC switch statement, and for LOGICAL case | |
3655 | expressions we build one or two if-else compares. | |
3656 | ||
3657 | SELECT CASEs with CHARACTER case expressions are a whole different | |
3658 | story, because they don't exist in GENERIC. So we sort them and | |
3659 | do a binary search at runtime. | |
3660 | ||
3661 | Fortran has no BREAK statement, and it does not allow jumps from | |
3662 | one case block to another. That makes things a lot easier for | |
3663 | the optimizers. */ | |
3664 | ||
3665 | tree | |
3666 | gfc_trans_select (gfc_code * code) | |
3667 | { | |
e5ca9693 DK |
3668 | stmtblock_t block; |
3669 | tree body; | |
3670 | tree exit_label; | |
3671 | ||
a513927a | 3672 | gcc_assert (code && code->expr1); |
e5ca9693 DK |
3673 | gfc_init_block (&block); |
3674 | ||
3675 | /* Build the exit label and hang it in. */ | |
3676 | exit_label = gfc_build_label_decl (NULL_TREE); | |
3677 | code->exit_label = exit_label; | |
6de9cd9a DN |
3678 | |
3679 | /* Empty SELECT constructs are legal. */ | |
3680 | if (code->block == NULL) | |
e5ca9693 | 3681 | body = build_empty_stmt (input_location); |
6de9cd9a DN |
3682 | |
3683 | /* Select the correct translation function. */ | |
e5ca9693 DK |
3684 | else |
3685 | switch (code->expr1->ts.type) | |
3686 | { | |
3687 | case BT_LOGICAL: | |
3688 | body = gfc_trans_logical_select (code); | |
3689 | break; | |
3690 | ||
3691 | case BT_INTEGER: | |
3692 | body = gfc_trans_integer_select (code); | |
3693 | break; | |
3694 | ||
3695 | case BT_CHARACTER: | |
3696 | body = gfc_trans_character_select (code); | |
3697 | break; | |
3698 | ||
3699 | default: | |
3700 | gfc_internal_error ("gfc_trans_select(): Bad type for case expr."); | |
3701 | /* Not reached */ | |
3702 | } | |
3703 | ||
3704 | /* Build everything together. */ | |
3705 | gfc_add_expr_to_block (&block, body); | |
3706 | gfc_add_expr_to_block (&block, build1_v (LABEL_EXPR, exit_label)); | |
3707 | ||
dfd6231e PT |
3708 | return gfc_finish_block (&block); |
3709 | } | |
3710 | ||
3711 | tree | |
3712 | gfc_trans_select_type (gfc_code * code) | |
3713 | { | |
3714 | stmtblock_t block; | |
3715 | tree body; | |
3716 | tree exit_label; | |
3717 | ||
3718 | gcc_assert (code && code->expr1); | |
3719 | gfc_init_block (&block); | |
3720 | ||
3721 | /* Build the exit label and hang it in. */ | |
3722 | exit_label = gfc_build_label_decl (NULL_TREE); | |
3723 | code->exit_label = exit_label; | |
3724 | ||
3725 | /* Empty SELECT constructs are legal. */ | |
3726 | if (code->block == NULL) | |
3727 | body = build_empty_stmt (input_location); | |
3728 | else | |
3729 | body = gfc_trans_select_type_cases (code); | |
3730 | ||
3731 | /* Build everything together. */ | |
3732 | gfc_add_expr_to_block (&block, body); | |
3733 | ||
3734 | if (TREE_USED (exit_label)) | |
3735 | gfc_add_expr_to_block (&block, build1_v (LABEL_EXPR, exit_label)); | |
3736 | ||
e5ca9693 | 3737 | return gfc_finish_block (&block); |
6de9cd9a DN |
3738 | } |
3739 | ||
3740 | ||
70570ec1 PT |
3741 | static tree |
3742 | gfc_trans_select_rank_cases (gfc_code * code) | |
3743 | { | |
3744 | gfc_code *c; | |
3745 | gfc_case *cp; | |
3746 | tree tmp; | |
3747 | tree cond; | |
3748 | tree low; | |
70570ec1 | 3749 | tree rank; |
70570ec1 PT |
3750 | gfc_se se; |
3751 | gfc_se cse; | |
3752 | stmtblock_t block; | |
3753 | stmtblock_t body; | |
3754 | bool def = false; | |
3755 | ||
3756 | gfc_start_block (&block); | |
3757 | ||
3758 | /* Calculate the switch expression. */ | |
3759 | gfc_init_se (&se, NULL); | |
3760 | gfc_conv_expr_descriptor (&se, code->expr1); | |
3761 | rank = gfc_conv_descriptor_rank (se.expr); | |
3762 | rank = gfc_evaluate_now (rank, &block); | |
64f96237 | 3763 | symbol_attribute attr = gfc_expr_attr (code->expr1); |
7f899b23 | 3764 | if (!attr.pointer && !attr.allocatable) |
64f96237 TB |
3765 | { |
3766 | /* Special case for assumed-rank ('rank(*)', internally -1): | |
3767 | rank = (rank == 0 || ubound[rank-1] != -1) ? rank : -1. */ | |
3768 | cond = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, | |
3769 | rank, build_int_cst (TREE_TYPE (rank), 0)); | |
3770 | tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, | |
3771 | fold_convert (gfc_array_index_type, rank), | |
3772 | gfc_index_one_node); | |
3773 | tmp = gfc_conv_descriptor_ubound_get (se.expr, tmp); | |
3774 | tmp = fold_build2_loc (input_location, NE_EXPR, logical_type_node, | |
3775 | tmp, build_int_cst (TREE_TYPE (tmp), -1)); | |
3776 | cond = fold_build2_loc (input_location, TRUTH_ORIF_EXPR, | |
3777 | logical_type_node, cond, tmp); | |
3778 | tmp = fold_build3_loc (input_location, COND_EXPR, TREE_TYPE (rank), | |
3779 | cond, rank, build_int_cst (TREE_TYPE (rank), -1)); | |
3780 | rank = gfc_evaluate_now (tmp, &block); | |
3781 | } | |
70570ec1 PT |
3782 | TREE_USED (code->exit_label) = 0; |
3783 | ||
3784 | repeat: | |
3785 | for (c = code->block; c; c = c->block) | |
3786 | { | |
3787 | cp = c->ext.block.case_list; | |
3788 | ||
3789 | /* Assume it's the default case. */ | |
3790 | low = NULL_TREE; | |
3791 | tmp = NULL_TREE; | |
3792 | ||
3793 | /* Put the default case at the end. */ | |
3794 | if ((!def && !cp->low) || (def && cp->low)) | |
3795 | continue; | |
3796 | ||
3797 | if (cp->low) | |
3798 | { | |
3799 | gfc_init_se (&cse, NULL); | |
3800 | gfc_conv_expr_val (&cse, cp->low); | |
3801 | gfc_add_block_to_block (&block, &cse.pre); | |
3802 | low = cse.expr; | |
3803 | } | |
3804 | ||
3805 | gfc_init_block (&body); | |
3806 | ||
3807 | /* Add the statements for this case. */ | |
3808 | tmp = gfc_trans_code (c->next); | |
3809 | gfc_add_expr_to_block (&body, tmp); | |
3810 | ||
3811 | /* Break to the end of the SELECT RANK construct. The default | |
3812 | case just falls through. */ | |
3813 | if (!def) | |
3814 | { | |
3815 | TREE_USED (code->exit_label) = 1; | |
3816 | tmp = build1_v (GOTO_EXPR, code->exit_label); | |
3817 | gfc_add_expr_to_block (&body, tmp); | |
3818 | } | |
3819 | ||
3820 | tmp = gfc_finish_block (&body); | |
3821 | ||
3822 | if (low != NULL_TREE) | |
3823 | { | |
3824 | cond = fold_build2_loc (input_location, EQ_EXPR, | |
64f96237 TB |
3825 | TREE_TYPE (rank), rank, |
3826 | fold_convert (TREE_TYPE (rank), low)); | |
70570ec1 PT |
3827 | tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, |
3828 | cond, tmp, | |
3829 | build_empty_stmt (input_location)); | |
3830 | } | |
3831 | ||
3832 | gfc_add_expr_to_block (&block, tmp); | |
3833 | } | |
3834 | ||
3835 | if (!def) | |
3836 | { | |
3837 | def = true; | |
3838 | goto repeat; | |
3839 | } | |
3840 | ||
3841 | return gfc_finish_block (&block); | |
3842 | } | |
3843 | ||
3844 | ||
3845 | tree | |
3846 | gfc_trans_select_rank (gfc_code * code) | |
3847 | { | |
3848 | stmtblock_t block; | |
3849 | tree body; | |
3850 | tree exit_label; | |
3851 | ||
3852 | gcc_assert (code && code->expr1); | |
3853 | gfc_init_block (&block); | |
3854 | ||
3855 | /* Build the exit label and hang it in. */ | |
3856 | exit_label = gfc_build_label_decl (NULL_TREE); | |
3857 | code->exit_label = exit_label; | |
3858 | ||
3859 | /* Empty SELECT constructs are legal. */ | |
3860 | if (code->block == NULL) | |
3861 | body = build_empty_stmt (input_location); | |
3862 | else | |
3863 | body = gfc_trans_select_rank_cases (code); | |
3864 | ||
3865 | /* Build everything together. */ | |
3866 | gfc_add_expr_to_block (&block, body); | |
3867 | ||
3868 | if (TREE_USED (exit_label)) | |
3869 | gfc_add_expr_to_block (&block, build1_v (LABEL_EXPR, exit_label)); | |
3870 | ||
3871 | return gfc_finish_block (&block); | |
3872 | } | |
3873 | ||
3874 | ||
640670c7 PT |
3875 | /* Traversal function to substitute a replacement symtree if the symbol |
3876 | in the expression is the same as that passed. f == 2 signals that | |
3877 | that variable itself is not to be checked - only the references. | |
3878 | This group of functions is used when the variable expression in a | |
3879 | FORALL assignment has internal references. For example: | |
3880 | FORALL (i = 1:4) p(p(i)) = i | |
3881 | The only recourse here is to store a copy of 'p' for the index | |
3882 | expression. */ | |
3883 | ||
3884 | static gfc_symtree *new_symtree; | |
3885 | static gfc_symtree *old_symtree; | |
3886 | ||
3887 | static bool | |
3888 | forall_replace (gfc_expr *expr, gfc_symbol *sym, int *f) | |
3889 | { | |
908a2235 PT |
3890 | if (expr->expr_type != EXPR_VARIABLE) |
3891 | return false; | |
640670c7 PT |
3892 | |
3893 | if (*f == 2) | |
3894 | *f = 1; | |
3895 | else if (expr->symtree->n.sym == sym) | |
3896 | expr->symtree = new_symtree; | |
3897 | ||
3898 | return false; | |
3899 | } | |
3900 | ||
3901 | static void | |
3902 | forall_replace_symtree (gfc_expr *e, gfc_symbol *sym, int f) | |
3903 | { | |
3904 | gfc_traverse_expr (e, sym, forall_replace, f); | |
3905 | } | |
3906 | ||
3907 | static bool | |
3908 | forall_restore (gfc_expr *expr, | |
3909 | gfc_symbol *sym ATTRIBUTE_UNUSED, | |
3910 | int *f ATTRIBUTE_UNUSED) | |
3911 | { | |
908a2235 PT |
3912 | if (expr->expr_type != EXPR_VARIABLE) |
3913 | return false; | |
640670c7 PT |
3914 | |
3915 | if (expr->symtree == new_symtree) | |
3916 | expr->symtree = old_symtree; | |
3917 | ||
3918 | return false; | |
3919 | } | |
3920 | ||
3921 | static void | |
3922 | forall_restore_symtree (gfc_expr *e) | |
3923 | { | |
3924 | gfc_traverse_expr (e, NULL, forall_restore, 0); | |
3925 | } | |
3926 | ||
3927 | static void | |
3928 | forall_make_variable_temp (gfc_code *c, stmtblock_t *pre, stmtblock_t *post) | |
3929 | { | |
3930 | gfc_se tse; | |
3931 | gfc_se rse; | |
3932 | gfc_expr *e; | |
3933 | gfc_symbol *new_sym; | |
3934 | gfc_symbol *old_sym; | |
3935 | gfc_symtree *root; | |
3936 | tree tmp; | |
3937 | ||
3938 | /* Build a copy of the lvalue. */ | |
a513927a | 3939 | old_symtree = c->expr1->symtree; |
640670c7 PT |
3940 | old_sym = old_symtree->n.sym; |
3941 | e = gfc_lval_expr_from_sym (old_sym); | |
3942 | if (old_sym->attr.dimension) | |
3943 | { | |
3944 | gfc_init_se (&tse, NULL); | |
430f2d1f | 3945 | gfc_conv_subref_array_arg (&tse, e, 0, INTENT_IN, false); |
640670c7 PT |
3946 | gfc_add_block_to_block (pre, &tse.pre); |
3947 | gfc_add_block_to_block (post, &tse.post); | |
db3927fb | 3948 | tse.expr = build_fold_indirect_ref_loc (input_location, tse.expr); |
640670c7 | 3949 | |
7bd5dad2 | 3950 | if (c->expr1->ref->u.ar.type != AR_SECTION) |
640670c7 PT |
3951 | { |
3952 | /* Use the variable offset for the temporary. */ | |
568e8e1e PT |
3953 | tmp = gfc_conv_array_offset (old_sym->backend_decl); |
3954 | gfc_conv_descriptor_offset_set (pre, tse.expr, tmp); | |
640670c7 PT |
3955 | } |
3956 | } | |
3957 | else | |
3958 | { | |
3959 | gfc_init_se (&tse, NULL); | |
3960 | gfc_init_se (&rse, NULL); | |
3961 | gfc_conv_expr (&rse, e); | |
3962 | if (e->ts.type == BT_CHARACTER) | |
3963 | { | |
3964 | tse.string_length = rse.string_length; | |
3965 | tmp = gfc_get_character_type_len (gfc_default_character_kind, | |
3966 | tse.string_length); | |
3967 | tse.expr = gfc_conv_string_tmp (&tse, build_pointer_type (tmp), | |
3968 | rse.string_length); | |
3969 | gfc_add_block_to_block (pre, &tse.pre); | |
3970 | gfc_add_block_to_block (post, &tse.post); | |
3971 | } | |
3972 | else | |
3973 | { | |
3974 | tmp = gfc_typenode_for_spec (&e->ts); | |
3975 | tse.expr = gfc_create_var (tmp, "temp"); | |
3976 | } | |
3977 | ||
ed673c00 MM |
3978 | tmp = gfc_trans_scalar_assign (&tse, &rse, e->ts, |
3979 | e->expr_type == EXPR_VARIABLE, false); | |
640670c7 PT |
3980 | gfc_add_expr_to_block (pre, tmp); |
3981 | } | |
3982 | gfc_free_expr (e); | |
3983 | ||
3984 | /* Create a new symbol to represent the lvalue. */ | |
3985 | new_sym = gfc_new_symbol (old_sym->name, NULL); | |
3986 | new_sym->ts = old_sym->ts; | |
3987 | new_sym->attr.referenced = 1; | |
59e36b72 | 3988 | new_sym->attr.temporary = 1; |
640670c7 PT |
3989 | new_sym->attr.dimension = old_sym->attr.dimension; |
3990 | new_sym->attr.flavor = old_sym->attr.flavor; | |
3991 | ||
3992 | /* Use the temporary as the backend_decl. */ | |
3993 | new_sym->backend_decl = tse.expr; | |
3994 | ||
3995 | /* Create a fake symtree for it. */ | |
3996 | root = NULL; | |
3997 | new_symtree = gfc_new_symtree (&root, old_sym->name); | |
3998 | new_symtree->n.sym = new_sym; | |
3999 | gcc_assert (new_symtree == root); | |
4000 | ||
4001 | /* Go through the expression reference replacing the old_symtree | |
4002 | with the new. */ | |
a513927a | 4003 | forall_replace_symtree (c->expr1, old_sym, 2); |
640670c7 PT |
4004 | |
4005 | /* Now we have made this temporary, we might as well use it for | |
4006 | the right hand side. */ | |
4007 | forall_replace_symtree (c->expr2, old_sym, 1); | |
4008 | } | |
4009 | ||
4010 | ||
4011 | /* Handles dependencies in forall assignments. */ | |
4012 | static int | |
4013 | check_forall_dependencies (gfc_code *c, stmtblock_t *pre, stmtblock_t *post) | |
4014 | { | |
4015 | gfc_ref *lref; | |
4016 | gfc_ref *rref; | |
4017 | int need_temp; | |
4018 | gfc_symbol *lsym; | |
4019 | ||
a513927a SK |
4020 | lsym = c->expr1->symtree->n.sym; |
4021 | need_temp = gfc_check_dependency (c->expr1, c->expr2, 0); | |
640670c7 PT |
4022 | |
4023 | /* Now check for dependencies within the 'variable' | |
4024 | expression itself. These are treated by making a complete | |
4025 | copy of variable and changing all the references to it | |
4026 | point to the copy instead. Note that the shallow copy of | |
4027 | the variable will not suffice for derived types with | |
4028 | pointer components. We therefore leave these to their | |
c09deceb | 4029 | own devices. Likewise for allocatable components. */ |
640670c7 | 4030 | if (lsym->ts.type == BT_DERIVED |
c09deceb HA |
4031 | && (lsym->ts.u.derived->attr.pointer_comp |
4032 | || lsym->ts.u.derived->attr.alloc_comp)) | |
640670c7 PT |
4033 | return need_temp; |
4034 | ||
4035 | new_symtree = NULL; | |
524af0d6 | 4036 | if (find_forall_index (c->expr1, lsym, 2)) |
640670c7 PT |
4037 | { |
4038 | forall_make_variable_temp (c, pre, post); | |
4039 | need_temp = 0; | |
4040 | } | |
4041 | ||
4042 | /* Substrings with dependencies are treated in the same | |
4043 | way. */ | |
a513927a SK |
4044 | if (c->expr1->ts.type == BT_CHARACTER |
4045 | && c->expr1->ref | |
640670c7 PT |
4046 | && c->expr2->expr_type == EXPR_VARIABLE |
4047 | && lsym == c->expr2->symtree->n.sym) | |
4048 | { | |
a513927a | 4049 | for (lref = c->expr1->ref; lref; lref = lref->next) |
640670c7 PT |
4050 | if (lref->type == REF_SUBSTRING) |
4051 | break; | |
4052 | for (rref = c->expr2->ref; rref; rref = rref->next) | |
4053 | if (rref->type == REF_SUBSTRING) | |
4054 | break; | |
4055 | ||
4056 | if (rref && lref | |
4057 | && gfc_dep_compare_expr (rref->u.ss.start, lref->u.ss.start) < 0) | |
4058 | { | |
4059 | forall_make_variable_temp (c, pre, post); | |
4060 | need_temp = 0; | |
4061 | } | |
4062 | } | |
4063 | return need_temp; | |
4064 | } | |
4065 | ||
4066 | ||
4067 | static void | |
4068 | cleanup_forall_symtrees (gfc_code *c) | |
4069 | { | |
a513927a | 4070 | forall_restore_symtree (c->expr1); |
640670c7 | 4071 | forall_restore_symtree (c->expr2); |
cede9502 JM |
4072 | free (new_symtree->n.sym); |
4073 | free (new_symtree); | |
640670c7 PT |
4074 | } |
4075 | ||
4076 | ||
bfcabc6c RS |
4077 | /* Generate the loops for a FORALL block, specified by FORALL_TMP. BODY |
4078 | is the contents of the FORALL block/stmt to be iterated. MASK_FLAG | |
4079 | indicates whether we should generate code to test the FORALLs mask | |
4080 | array. OUTER is the loop header to be used for initializing mask | |
4081 | indices. | |
4082 | ||
4083 | The generated loop format is: | |
6de9cd9a DN |
4084 | count = (end - start + step) / step |
4085 | loopvar = start | |
4086 | while (1) | |
4087 | { | |
4088 | if (count <=0 ) | |
4089 | goto end_of_loop | |
4090 | <body> | |
4091 | loopvar += step | |
4092 | count -- | |
4093 | } | |
4094 | end_of_loop: */ | |
4095 | ||
4096 | static tree | |
bfcabc6c RS |
4097 | gfc_trans_forall_loop (forall_info *forall_tmp, tree body, |
4098 | int mask_flag, stmtblock_t *outer) | |
6de9cd9a | 4099 | { |
bfcabc6c | 4100 | int n, nvar; |
6de9cd9a DN |
4101 | tree tmp; |
4102 | tree cond; | |
4103 | stmtblock_t block; | |
4104 | tree exit_label; | |
4105 | tree count; | |
fcf3be37 | 4106 | tree var, start, end, step; |
6de9cd9a DN |
4107 | iter_info *iter; |
4108 | ||
bfcabc6c RS |
4109 | /* Initialize the mask index outside the FORALL nest. */ |
4110 | if (mask_flag && forall_tmp->mask) | |
726a989a | 4111 | gfc_add_modify (outer, forall_tmp->maskindex, gfc_index_zero_node); |
bfcabc6c | 4112 | |
6de9cd9a | 4113 | iter = forall_tmp->this_loop; |
bfcabc6c | 4114 | nvar = forall_tmp->nvar; |
6de9cd9a DN |
4115 | for (n = 0; n < nvar; n++) |
4116 | { | |
4117 | var = iter->var; | |
4118 | start = iter->start; | |
4119 | end = iter->end; | |
4120 | step = iter->step; | |
4121 | ||
4122 | exit_label = gfc_build_label_decl (NULL_TREE); | |
4123 | TREE_USED (exit_label) = 1; | |
4124 | ||
4125 | /* The loop counter. */ | |
4126 | count = gfc_create_var (TREE_TYPE (var), "count"); | |
4127 | ||
4128 | /* The body of the loop. */ | |
4129 | gfc_init_block (&block); | |
4130 | ||
4131 | /* The exit condition. */ | |
63ee5404 | 4132 | cond = fold_build2_loc (input_location, LE_EXPR, logical_type_node, |
bc98ed60 | 4133 | count, build_int_cst (TREE_TYPE (count), 0)); |
f0caea48 | 4134 | |
bc436e10 | 4135 | /* PR 83064 means that we cannot use annot_expr_parallel_kind until |
7ebd4a1d | 4136 | the autoparallelizer can handle this. */ |
9935667a | 4137 | if (forall_tmp->do_concurrent || iter->annot.ivdep) |
ac9effed | 4138 | cond = build3 (ANNOTATE_EXPR, TREE_TYPE (cond), cond, |
2ca4e2c2 | 4139 | build_int_cst (integer_type_node, |
bc436e10 | 4140 | annot_expr_ivdep_kind), |
ac9effed | 4141 | integer_zero_node); |
2ca4e2c2 | 4142 | |
9935667a HA |
4143 | if (iter->annot.unroll && cond != error_mark_node) |
4144 | cond = build3 (ANNOTATE_EXPR, TREE_TYPE (cond), cond, | |
4145 | build_int_cst (integer_type_node, | |
4146 | annot_expr_unroll_kind), | |
4147 | build_int_cst (integer_type_node, iter->annot.unroll)); | |
4148 | ||
4149 | if (iter->annot.vector && cond != error_mark_node) | |
4150 | cond = build3 (ANNOTATE_EXPR, TREE_TYPE (cond), cond, | |
4151 | build_int_cst (integer_type_node, | |
4152 | annot_expr_vector_kind), | |
4153 | integer_zero_node); | |
4154 | ||
4155 | if (iter->annot.novector && cond != error_mark_node) | |
4156 | cond = build3 (ANNOTATE_EXPR, TREE_TYPE (cond), cond, | |
4157 | build_int_cst (integer_type_node, | |
4158 | annot_expr_no_vector_kind), | |
4159 | integer_zero_node); | |
4160 | ||
6de9cd9a | 4161 | tmp = build1_v (GOTO_EXPR, exit_label); |
bc98ed60 TB |
4162 | tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, |
4163 | cond, tmp, build_empty_stmt (input_location)); | |
6de9cd9a DN |
4164 | gfc_add_expr_to_block (&block, tmp); |
4165 | ||
4166 | /* The main loop body. */ | |
4167 | gfc_add_expr_to_block (&block, body); | |
4168 | ||
4169 | /* Increment the loop variable. */ | |
bc98ed60 TB |
4170 | tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (var), var, |
4171 | step); | |
726a989a | 4172 | gfc_add_modify (&block, var, tmp); |
6de9cd9a | 4173 | |
a8e12e4d TS |
4174 | /* Advance to the next mask element. Only do this for the |
4175 | innermost loop. */ | |
fcf3be37 JJ |
4176 | if (n == 0 && mask_flag && forall_tmp->mask) |
4177 | { | |
4178 | tree maskindex = forall_tmp->maskindex; | |
bc98ed60 TB |
4179 | tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, |
4180 | maskindex, gfc_index_one_node); | |
726a989a | 4181 | gfc_add_modify (&block, maskindex, tmp); |
fcf3be37 JJ |
4182 | } |
4183 | ||
6de9cd9a | 4184 | /* Decrement the loop counter. */ |
bc98ed60 TB |
4185 | tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (var), count, |
4186 | build_int_cst (TREE_TYPE (var), 1)); | |
726a989a | 4187 | gfc_add_modify (&block, count, tmp); |
6de9cd9a DN |
4188 | |
4189 | body = gfc_finish_block (&block); | |
4190 | ||
4191 | /* Loop var initialization. */ | |
4192 | gfc_init_block (&block); | |
726a989a | 4193 | gfc_add_modify (&block, var, start); |
6de9cd9a | 4194 | |
fcf3be37 | 4195 | |
6de9cd9a | 4196 | /* Initialize the loop counter. */ |
bc98ed60 TB |
4197 | tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (var), step, |
4198 | start); | |
4199 | tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (var), end, | |
4200 | tmp); | |
4201 | tmp = fold_build2_loc (input_location, TRUNC_DIV_EXPR, TREE_TYPE (var), | |
4202 | tmp, step); | |
726a989a | 4203 | gfc_add_modify (&block, count, tmp); |
6de9cd9a DN |
4204 | |
4205 | /* The loop expression. */ | |
923ab88c | 4206 | tmp = build1_v (LOOP_EXPR, body); |
6de9cd9a DN |
4207 | gfc_add_expr_to_block (&block, tmp); |
4208 | ||
4209 | /* The exit label. */ | |
4210 | tmp = build1_v (LABEL_EXPR, exit_label); | |
4211 | gfc_add_expr_to_block (&block, tmp); | |
4212 | ||
4213 | body = gfc_finish_block (&block); | |
4214 | iter = iter->next; | |
4215 | } | |
4216 | return body; | |
4217 | } | |
4218 | ||
4219 | ||
bfcabc6c RS |
4220 | /* Generate the body and loops according to MASK_FLAG. If MASK_FLAG |
4221 | is nonzero, the body is controlled by all masks in the forall nest. | |
4222 | Otherwise, the innermost loop is not controlled by it's mask. This | |
4223 | is used for initializing that mask. */ | |
6de9cd9a DN |
4224 | |
4225 | static tree | |
4226 | gfc_trans_nested_forall_loop (forall_info * nested_forall_info, tree body, | |
bfcabc6c | 4227 | int mask_flag) |
6de9cd9a DN |
4228 | { |
4229 | tree tmp; | |
bfcabc6c | 4230 | stmtblock_t header; |
6de9cd9a | 4231 | forall_info *forall_tmp; |
bfcabc6c RS |
4232 | tree mask, maskindex; |
4233 | ||
4234 | gfc_start_block (&header); | |
6de9cd9a DN |
4235 | |
4236 | forall_tmp = nested_forall_info; | |
bfcabc6c | 4237 | while (forall_tmp != NULL) |
6de9cd9a | 4238 | { |
bfcabc6c RS |
4239 | /* Generate body with masks' control. */ |
4240 | if (mask_flag) | |
6de9cd9a | 4241 | { |
bfcabc6c RS |
4242 | mask = forall_tmp->mask; |
4243 | maskindex = forall_tmp->maskindex; | |
6de9cd9a | 4244 | |
bfcabc6c RS |
4245 | /* If a mask was specified make the assignment conditional. */ |
4246 | if (mask) | |
4247 | { | |
1d6b7f39 | 4248 | tmp = gfc_build_array_ref (mask, maskindex, NULL); |
c2255bc4 AH |
4249 | body = build3_v (COND_EXPR, tmp, body, |
4250 | build_empty_stmt (input_location)); | |
6de9cd9a | 4251 | } |
6de9cd9a | 4252 | } |
bfcabc6c | 4253 | body = gfc_trans_forall_loop (forall_tmp, body, mask_flag, &header); |
e8d366ec | 4254 | forall_tmp = forall_tmp->prev_nest; |
bfcabc6c | 4255 | mask_flag = 1; |
6de9cd9a DN |
4256 | } |
4257 | ||
bfcabc6c RS |
4258 | gfc_add_expr_to_block (&header, body); |
4259 | return gfc_finish_block (&header); | |
6de9cd9a DN |
4260 | } |
4261 | ||
4262 | ||
4263 | /* Allocate data for holding a temporary array. Returns either a local | |
4264 | temporary array or a pointer variable. */ | |
4265 | ||
4266 | static tree | |
4267 | gfc_do_allocate (tree bytesize, tree size, tree * pdata, stmtblock_t * pblock, | |
4268 | tree elem_type) | |
4269 | { | |
4270 | tree tmpvar; | |
4271 | tree type; | |
4272 | tree tmp; | |
6de9cd9a DN |
4273 | |
4274 | if (INTEGER_CST_P (size)) | |
bc98ed60 TB |
4275 | tmp = fold_build2_loc (input_location, MINUS_EXPR, gfc_array_index_type, |
4276 | size, gfc_index_one_node); | |
6de9cd9a DN |
4277 | else |
4278 | tmp = NULL_TREE; | |
4279 | ||
7ab92584 | 4280 | type = build_range_type (gfc_array_index_type, gfc_index_zero_node, tmp); |
6de9cd9a | 4281 | type = build_array_type (elem_type, type); |
55250ed7 | 4282 | if (gfc_can_put_var_on_stack (bytesize) && INTEGER_CST_P (size)) |
6de9cd9a | 4283 | { |
6de9cd9a DN |
4284 | tmpvar = gfc_create_var (type, "temp"); |
4285 | *pdata = NULL_TREE; | |
4286 | } | |
4287 | else | |
4288 | { | |
4289 | tmpvar = gfc_create_var (build_pointer_type (type), "temp"); | |
4290 | *pdata = convert (pvoid_type_node, tmpvar); | |
4291 | ||
1529b8d9 | 4292 | tmp = gfc_call_malloc (pblock, TREE_TYPE (tmpvar), bytesize); |
726a989a | 4293 | gfc_add_modify (pblock, tmpvar, tmp); |
6de9cd9a DN |
4294 | } |
4295 | return tmpvar; | |
4296 | } | |
4297 | ||
4298 | ||
4299 | /* Generate codes to copy the temporary to the actual lhs. */ | |
4300 | ||
4301 | static tree | |
8de1f441 | 4302 | generate_loop_for_temp_to_lhs (gfc_expr *expr, tree tmp1, tree count3, |
7bd5dad2 LK |
4303 | tree count1, |
4304 | gfc_ss *lss, gfc_ss *rss, | |
4305 | tree wheremask, bool invert) | |
6de9cd9a | 4306 | { |
7bd5dad2 LK |
4307 | stmtblock_t block, body1; |
4308 | gfc_loopinfo loop; | |
4309 | gfc_se lse; | |
4310 | gfc_se rse; | |
011daa76 | 4311 | tree tmp; |
6de9cd9a DN |
4312 | tree wheremaskexpr; |
4313 | ||
7bd5dad2 | 4314 | (void) rss; /* TODO: unused. */ |
6de9cd9a | 4315 | |
7bd5dad2 | 4316 | gfc_start_block (&block); |
6de9cd9a | 4317 | |
7bd5dad2 LK |
4318 | gfc_init_se (&rse, NULL); |
4319 | gfc_init_se (&lse, NULL); | |
6de9cd9a | 4320 | |
7bd5dad2 LK |
4321 | if (lss == gfc_ss_terminator) |
4322 | { | |
4323 | gfc_init_block (&body1); | |
6de9cd9a | 4324 | gfc_conv_expr (&lse, expr); |
7bd5dad2 | 4325 | rse.expr = gfc_build_array_ref (tmp1, count1, NULL); |
6de9cd9a DN |
4326 | } |
4327 | else | |
4328 | { | |
7bd5dad2 LK |
4329 | /* Initialize the loop. */ |
4330 | gfc_init_loopinfo (&loop); | |
6de9cd9a | 4331 | |
7bd5dad2 LK |
4332 | /* We may need LSS to determine the shape of the expression. */ |
4333 | gfc_add_ss_to_loop (&loop, lss); | |
6de9cd9a | 4334 | |
7bd5dad2 LK |
4335 | gfc_conv_ss_startstride (&loop); |
4336 | gfc_conv_loop_setup (&loop, &expr->where); | |
6de9cd9a DN |
4337 | |
4338 | gfc_mark_ss_chain_used (lss, 1); | |
7bd5dad2 LK |
4339 | /* Start the loop body. */ |
4340 | gfc_start_scalarized_body (&loop, &body1); | |
6de9cd9a | 4341 | |
7bd5dad2 LK |
4342 | /* Translate the expression. */ |
4343 | gfc_copy_loopinfo_to_se (&lse, &loop); | |
6de9cd9a | 4344 | lse.ss = lss; |
7bd5dad2 | 4345 | gfc_conv_expr (&lse, expr); |
6de9cd9a DN |
4346 | |
4347 | /* Form the expression of the temporary. */ | |
7bd5dad2 LK |
4348 | rse.expr = gfc_build_array_ref (tmp1, count1, NULL); |
4349 | } | |
6de9cd9a | 4350 | |
7bd5dad2 LK |
4351 | /* Use the scalar assignment. */ |
4352 | rse.string_length = lse.string_length; | |
4353 | tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, | |
4354 | expr->expr_type == EXPR_VARIABLE, false); | |
6de9cd9a | 4355 | |
7bd5dad2 LK |
4356 | /* Form the mask expression according to the mask tree list. */ |
4357 | if (wheremask) | |
4358 | { | |
4359 | wheremaskexpr = gfc_build_array_ref (wheremask, count3, NULL); | |
4360 | if (invert) | |
4361 | wheremaskexpr = fold_build1_loc (input_location, TRUTH_NOT_EXPR, | |
4362 | TREE_TYPE (wheremaskexpr), | |
4363 | wheremaskexpr); | |
4364 | tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, | |
4365 | wheremaskexpr, tmp, | |
4366 | build_empty_stmt (input_location)); | |
4367 | } | |
6de9cd9a | 4368 | |
7bd5dad2 | 4369 | gfc_add_expr_to_block (&body1, tmp); |
6de9cd9a | 4370 | |
7bd5dad2 LK |
4371 | tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (count1), |
4372 | count1, gfc_index_one_node); | |
4373 | gfc_add_modify (&body1, count1, tmp); | |
6de9cd9a | 4374 | |
7bd5dad2 LK |
4375 | if (lss == gfc_ss_terminator) |
4376 | gfc_add_block_to_block (&block, &body1); | |
4377 | else | |
4378 | { | |
6de9cd9a DN |
4379 | /* Increment count3. */ |
4380 | if (count3) | |
8de1f441 | 4381 | { |
bc98ed60 | 4382 | tmp = fold_build2_loc (input_location, PLUS_EXPR, |
7bd5dad2 LK |
4383 | gfc_array_index_type, |
4384 | count3, gfc_index_one_node); | |
4385 | gfc_add_modify (&body1, count3, tmp); | |
8de1f441 | 4386 | } |
6de9cd9a DN |
4387 | |
4388 | /* Generate the copying loops. */ | |
7bd5dad2 LK |
4389 | gfc_trans_scalarizing_loops (&loop, &body1); |
4390 | ||
4391 | gfc_add_block_to_block (&block, &loop.pre); | |
4392 | gfc_add_block_to_block (&block, &loop.post); | |
6de9cd9a | 4393 | |
7bd5dad2 LK |
4394 | gfc_cleanup_loop (&loop); |
4395 | /* TODO: Reuse lss and rss when copying temp->lhs. Need to be careful | |
4396 | as tree nodes in SS may not be valid in different scope. */ | |
6de9cd9a | 4397 | } |
7bd5dad2 LK |
4398 | |
4399 | tmp = gfc_finish_block (&block); | |
6de9cd9a DN |
4400 | return tmp; |
4401 | } | |
4402 | ||
4403 | ||
011daa76 RS |
4404 | /* Generate codes to copy rhs to the temporary. TMP1 is the address of |
4405 | temporary, LSS and RSS are formed in function compute_inner_temp_size(), | |
4406 | and should not be freed. WHEREMASK is the conditional execution mask | |
4407 | whose sense may be inverted by INVERT. */ | |
6de9cd9a DN |
4408 | |
4409 | static tree | |
8de1f441 JJ |
4410 | generate_loop_for_rhs_to_temp (gfc_expr *expr2, tree tmp1, tree count3, |
4411 | tree count1, gfc_ss *lss, gfc_ss *rss, | |
011daa76 | 4412 | tree wheremask, bool invert) |
6de9cd9a DN |
4413 | { |
4414 | stmtblock_t block, body1; | |
4415 | gfc_loopinfo loop; | |
4416 | gfc_se lse; | |
4417 | gfc_se rse; | |
011daa76 | 4418 | tree tmp; |
6de9cd9a DN |
4419 | tree wheremaskexpr; |
4420 | ||
4421 | gfc_start_block (&block); | |
4422 | ||
4423 | gfc_init_se (&rse, NULL); | |
4424 | gfc_init_se (&lse, NULL); | |
4425 | ||
4426 | if (lss == gfc_ss_terminator) | |
4427 | { | |
4428 | gfc_init_block (&body1); | |
4429 | gfc_conv_expr (&rse, expr2); | |
1d6b7f39 | 4430 | lse.expr = gfc_build_array_ref (tmp1, count1, NULL); |
6de9cd9a DN |
4431 | } |
4432 | else | |
4433 | { | |
1f2959f0 | 4434 | /* Initialize the loop. */ |
6de9cd9a DN |
4435 | gfc_init_loopinfo (&loop); |
4436 | ||
4437 | /* We may need LSS to determine the shape of the expression. */ | |
4438 | gfc_add_ss_to_loop (&loop, lss); | |
4439 | gfc_add_ss_to_loop (&loop, rss); | |
4440 | ||
4441 | gfc_conv_ss_startstride (&loop); | |
bdfd2ff0 | 4442 | gfc_conv_loop_setup (&loop, &expr2->where); |
6de9cd9a DN |
4443 | |
4444 | gfc_mark_ss_chain_used (rss, 1); | |
4445 | /* Start the loop body. */ | |
4446 | gfc_start_scalarized_body (&loop, &body1); | |
4447 | ||
4448 | /* Translate the expression. */ | |
4449 | gfc_copy_loopinfo_to_se (&rse, &loop); | |
4450 | rse.ss = rss; | |
4451 | gfc_conv_expr (&rse, expr2); | |
4452 | ||
4453 | /* Form the expression of the temporary. */ | |
1d6b7f39 | 4454 | lse.expr = gfc_build_array_ref (tmp1, count1, NULL); |
6de9cd9a DN |
4455 | } |
4456 | ||
4457 | /* Use the scalar assignment. */ | |
5046aff5 | 4458 | lse.string_length = rse.string_length; |
ed673c00 MM |
4459 | tmp = gfc_trans_scalar_assign (&lse, &rse, expr2->ts, |
4460 | expr2->expr_type == EXPR_VARIABLE, false); | |
6de9cd9a DN |
4461 | |
4462 | /* Form the mask expression according to the mask tree list. */ | |
4463 | if (wheremask) | |
4464 | { | |
1d6b7f39 | 4465 | wheremaskexpr = gfc_build_array_ref (wheremask, count3, NULL); |
011daa76 | 4466 | if (invert) |
bc98ed60 TB |
4467 | wheremaskexpr = fold_build1_loc (input_location, TRUTH_NOT_EXPR, |
4468 | TREE_TYPE (wheremaskexpr), | |
4469 | wheremaskexpr); | |
4470 | tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, | |
4471 | wheremaskexpr, tmp, | |
4472 | build_empty_stmt (input_location)); | |
6de9cd9a DN |
4473 | } |
4474 | ||
4475 | gfc_add_expr_to_block (&body1, tmp); | |
4476 | ||
4477 | if (lss == gfc_ss_terminator) | |
4478 | { | |
4479 | gfc_add_block_to_block (&block, &body1); | |
8de1f441 JJ |
4480 | |
4481 | /* Increment count1. */ | |
bc98ed60 TB |
4482 | tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (count1), |
4483 | count1, gfc_index_one_node); | |
726a989a | 4484 | gfc_add_modify (&block, count1, tmp); |
6de9cd9a DN |
4485 | } |
4486 | else | |
4487 | { | |
8de1f441 | 4488 | /* Increment count1. */ |
bc98ed60 TB |
4489 | tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, |
4490 | count1, gfc_index_one_node); | |
726a989a | 4491 | gfc_add_modify (&body1, count1, tmp); |
6de9cd9a DN |
4492 | |
4493 | /* Increment count3. */ | |
4494 | if (count3) | |
8de1f441 | 4495 | { |
bc98ed60 TB |
4496 | tmp = fold_build2_loc (input_location, PLUS_EXPR, |
4497 | gfc_array_index_type, | |
4498 | count3, gfc_index_one_node); | |
726a989a | 4499 | gfc_add_modify (&body1, count3, tmp); |
8de1f441 | 4500 | } |
6de9cd9a DN |
4501 | |
4502 | /* Generate the copying loops. */ | |
4503 | gfc_trans_scalarizing_loops (&loop, &body1); | |
4504 | ||
4505 | gfc_add_block_to_block (&block, &loop.pre); | |
4506 | gfc_add_block_to_block (&block, &loop.post); | |
4507 | ||
4508 | gfc_cleanup_loop (&loop); | |
4509 | /* TODO: Reuse lss and rss when copying temp->lhs. Need to be careful | |
8de1f441 | 4510 | as tree nodes in SS may not be valid in different scope. */ |
6de9cd9a | 4511 | } |
6de9cd9a DN |
4512 | |
4513 | tmp = gfc_finish_block (&block); | |
4514 | return tmp; | |
4515 | } | |
4516 | ||
4517 | ||
4518 | /* Calculate the size of temporary needed in the assignment inside forall. | |
4519 | LSS and RSS are filled in this function. */ | |
4520 | ||
4521 | static tree | |
4522 | compute_inner_temp_size (gfc_expr *expr1, gfc_expr *expr2, | |
4523 | stmtblock_t * pblock, | |
4524 | gfc_ss **lss, gfc_ss **rss) | |
4525 | { | |
4526 | gfc_loopinfo loop; | |
4527 | tree size; | |
4528 | int i; | |
ca86ddcc | 4529 | int save_flag; |
6de9cd9a DN |
4530 | tree tmp; |
4531 | ||
4532 | *lss = gfc_walk_expr (expr1); | |
4533 | *rss = NULL; | |
4534 | ||
7ab92584 | 4535 | size = gfc_index_one_node; |
6de9cd9a DN |
4536 | if (*lss != gfc_ss_terminator) |
4537 | { | |
4538 | gfc_init_loopinfo (&loop); | |
4539 | ||
4540 | /* Walk the RHS of the expression. */ | |
4541 | *rss = gfc_walk_expr (expr2); | |
4542 | if (*rss == gfc_ss_terminator) | |
26f77530 MM |
4543 | /* The rhs is scalar. Add a ss for the expression. */ |
4544 | *rss = gfc_get_scalar_ss (gfc_ss_terminator, expr2); | |
6de9cd9a DN |
4545 | |
4546 | /* Associate the SS with the loop. */ | |
4547 | gfc_add_ss_to_loop (&loop, *lss); | |
4548 | /* We don't actually need to add the rhs at this point, but it might | |
4549 | make guessing the loop bounds a bit easier. */ | |
4550 | gfc_add_ss_to_loop (&loop, *rss); | |
4551 | ||
4552 | /* We only want the shape of the expression, not rest of the junk | |
4553 | generated by the scalarizer. */ | |
4554 | loop.array_parameter = 1; | |
4555 | ||
4556 | /* Calculate the bounds of the scalarization. */ | |
d3d3011f | 4557 | save_flag = gfc_option.rtcheck; |
c3fb8214 | 4558 | gfc_option.rtcheck &= ~GFC_RTCHECK_BOUNDS; |
6de9cd9a | 4559 | gfc_conv_ss_startstride (&loop); |
d3d3011f | 4560 | gfc_option.rtcheck = save_flag; |
bdfd2ff0 | 4561 | gfc_conv_loop_setup (&loop, &expr2->where); |
6de9cd9a DN |
4562 | |
4563 | /* Figure out how many elements we need. */ | |
4564 | for (i = 0; i < loop.dimen; i++) | |
4565 | { | |
bc98ed60 TB |
4566 | tmp = fold_build2_loc (input_location, MINUS_EXPR, |
4567 | gfc_array_index_type, | |
4568 | gfc_index_one_node, loop.from[i]); | |
4569 | tmp = fold_build2_loc (input_location, PLUS_EXPR, | |
4570 | gfc_array_index_type, tmp, loop.to[i]); | |
4571 | size = fold_build2_loc (input_location, MULT_EXPR, | |
4572 | gfc_array_index_type, size, tmp); | |
6de9cd9a DN |
4573 | } |
4574 | gfc_add_block_to_block (pblock, &loop.pre); | |
4575 | size = gfc_evaluate_now (size, pblock); | |
4576 | gfc_add_block_to_block (pblock, &loop.post); | |
4577 | ||
4578 | /* TODO: write a function that cleans up a loopinfo without freeing | |
4579 | the SS chains. Currently a NOP. */ | |
4580 | } | |
4581 | ||
4582 | return size; | |
4583 | } | |
4584 | ||
4585 | ||
2ad62c9b RS |
4586 | /* Calculate the overall iterator number of the nested forall construct. |
4587 | This routine actually calculates the number of times the body of the | |
4588 | nested forall specified by NESTED_FORALL_INFO is executed and multiplies | |
4589 | that by the expression INNER_SIZE. The BLOCK argument specifies the | |
4590 | block in which to calculate the result, and the optional INNER_SIZE_BODY | |
4591 | argument contains any statements that need to executed (inside the loop) | |
4592 | to initialize or calculate INNER_SIZE. */ | |
6de9cd9a DN |
4593 | |
4594 | static tree | |
4595 | compute_overall_iter_number (forall_info *nested_forall_info, tree inner_size, | |
8de1f441 | 4596 | stmtblock_t *inner_size_body, stmtblock_t *block) |
6de9cd9a | 4597 | { |
2ad62c9b | 4598 | forall_info *forall_tmp = nested_forall_info; |
6de9cd9a DN |
4599 | tree tmp, number; |
4600 | stmtblock_t body; | |
4601 | ||
2ad62c9b RS |
4602 | /* We can eliminate the innermost unconditional loops with constant |
4603 | array bounds. */ | |
3bf783b7 RS |
4604 | if (INTEGER_CST_P (inner_size)) |
4605 | { | |
2ad62c9b | 4606 | while (forall_tmp |
8b704316 | 4607 | && !forall_tmp->mask |
2ad62c9b | 4608 | && INTEGER_CST_P (forall_tmp->size)) |
3bf783b7 | 4609 | { |
bc98ed60 TB |
4610 | inner_size = fold_build2_loc (input_location, MULT_EXPR, |
4611 | gfc_array_index_type, | |
4612 | inner_size, forall_tmp->size); | |
2ad62c9b | 4613 | forall_tmp = forall_tmp->prev_nest; |
3bf783b7 | 4614 | } |
2ad62c9b RS |
4615 | |
4616 | /* If there are no loops left, we have our constant result. */ | |
4617 | if (!forall_tmp) | |
4618 | return inner_size; | |
3bf783b7 | 4619 | } |
2ad62c9b RS |
4620 | |
4621 | /* Otherwise, create a temporary variable to compute the result. */ | |
6de9cd9a | 4622 | number = gfc_create_var (gfc_array_index_type, "num"); |
726a989a | 4623 | gfc_add_modify (block, number, gfc_index_zero_node); |
6de9cd9a DN |
4624 | |
4625 | gfc_start_block (&body); | |
8de1f441 JJ |
4626 | if (inner_size_body) |
4627 | gfc_add_block_to_block (&body, inner_size_body); | |
2ad62c9b | 4628 | if (forall_tmp) |
bc98ed60 TB |
4629 | tmp = fold_build2_loc (input_location, PLUS_EXPR, |
4630 | gfc_array_index_type, number, inner_size); | |
6de9cd9a DN |
4631 | else |
4632 | tmp = inner_size; | |
726a989a | 4633 | gfc_add_modify (&body, number, tmp); |
6de9cd9a DN |
4634 | tmp = gfc_finish_block (&body); |
4635 | ||
4636 | /* Generate loops. */ | |
2ad62c9b RS |
4637 | if (forall_tmp != NULL) |
4638 | tmp = gfc_trans_nested_forall_loop (forall_tmp, tmp, 1); | |
6de9cd9a DN |
4639 | |
4640 | gfc_add_expr_to_block (block, tmp); | |
4641 | ||
4642 | return number; | |
4643 | } | |
4644 | ||
4645 | ||
8de1f441 JJ |
4646 | /* Allocate temporary for forall construct. SIZE is the size of temporary |
4647 | needed. PTEMP1 is returned for space free. */ | |
6de9cd9a DN |
4648 | |
4649 | static tree | |
8de1f441 JJ |
4650 | allocate_temp_for_forall_nest_1 (tree type, tree size, stmtblock_t * block, |
4651 | tree * ptemp1) | |
6de9cd9a | 4652 | { |
bfcabc6c | 4653 | tree bytesize; |
6de9cd9a | 4654 | tree unit; |
6de9cd9a | 4655 | tree tmp; |
6de9cd9a | 4656 | |
7c57b2f1 | 4657 | unit = fold_convert (gfc_array_index_type, TYPE_SIZE_UNIT (type)); |
bfcabc6c | 4658 | if (!integer_onep (unit)) |
bc98ed60 TB |
4659 | bytesize = fold_build2_loc (input_location, MULT_EXPR, |
4660 | gfc_array_index_type, size, unit); | |
bfcabc6c RS |
4661 | else |
4662 | bytesize = size; | |
6de9cd9a DN |
4663 | |
4664 | *ptemp1 = NULL; | |
bfcabc6c | 4665 | tmp = gfc_do_allocate (bytesize, size, ptemp1, block, type); |
6de9cd9a DN |
4666 | |
4667 | if (*ptemp1) | |
db3927fb | 4668 | tmp = build_fold_indirect_ref_loc (input_location, tmp); |
6de9cd9a DN |
4669 | return tmp; |
4670 | } | |
4671 | ||
4672 | ||
8de1f441 JJ |
4673 | /* Allocate temporary for forall construct according to the information in |
4674 | nested_forall_info. INNER_SIZE is the size of temporary needed in the | |
4675 | assignment inside forall. PTEMP1 is returned for space free. */ | |
4676 | ||
4677 | static tree | |
4678 | allocate_temp_for_forall_nest (forall_info * nested_forall_info, tree type, | |
4679 | tree inner_size, stmtblock_t * inner_size_body, | |
4680 | stmtblock_t * block, tree * ptemp1) | |
4681 | { | |
4682 | tree size; | |
4683 | ||
4684 | /* Calculate the total size of temporary needed in forall construct. */ | |
4685 | size = compute_overall_iter_number (nested_forall_info, inner_size, | |
4686 | inner_size_body, block); | |
4687 | ||
4688 | return allocate_temp_for_forall_nest_1 (type, size, block, ptemp1); | |
4689 | } | |
4690 | ||
4691 | ||
4692 | /* Handle assignments inside forall which need temporary. | |
4693 | ||
4694 | forall (i=start:end:stride; maskexpr) | |
4695 | e<i> = f<i> | |
4696 | end forall | |
4697 | (where e,f<i> are arbitrary expressions possibly involving i | |
4698 | and there is a dependency between e<i> and f<i>) | |
4699 | Translates to: | |
4700 | masktmp(:) = maskexpr(:) | |
4701 | ||
4702 | maskindex = 0; | |
4703 | count1 = 0; | |
4704 | num = 0; | |
4705 | for (i = start; i <= end; i += stride) | |
4706 | num += SIZE (f<i>) | |
4707 | count1 = 0; | |
4708 | ALLOCATE (tmp(num)) | |
4709 | for (i = start; i <= end; i += stride) | |
4710 | { | |
4711 | if (masktmp[maskindex++]) | |
4712 | tmp[count1++] = f<i> | |
4713 | } | |
4714 | maskindex = 0; | |
4715 | count1 = 0; | |
4716 | for (i = start; i <= end; i += stride) | |
4717 | { | |
4718 | if (masktmp[maskindex++]) | |
4719 | e<i> = tmp[count1++] | |
4720 | } | |
4721 | DEALLOCATE (tmp) | |
4722 | */ | |
6de9cd9a | 4723 | static void |
011daa76 RS |
4724 | gfc_trans_assign_need_temp (gfc_expr * expr1, gfc_expr * expr2, |
4725 | tree wheremask, bool invert, | |
6de9cd9a DN |
4726 | forall_info * nested_forall_info, |
4727 | stmtblock_t * block) | |
4728 | { | |
4729 | tree type; | |
4730 | tree inner_size; | |
4731 | gfc_ss *lss, *rss; | |
8de1f441 | 4732 | tree count, count1; |
6de9cd9a DN |
4733 | tree tmp, tmp1; |
4734 | tree ptemp1; | |
8de1f441 | 4735 | stmtblock_t inner_size_body; |
6de9cd9a | 4736 | |
8de1f441 JJ |
4737 | /* Create vars. count1 is the current iterator number of the nested |
4738 | forall. */ | |
6de9cd9a | 4739 | count1 = gfc_create_var (gfc_array_index_type, "count1"); |
6de9cd9a DN |
4740 | |
4741 | /* Count is the wheremask index. */ | |
4742 | if (wheremask) | |
4743 | { | |
4744 | count = gfc_create_var (gfc_array_index_type, "count"); | |
726a989a | 4745 | gfc_add_modify (block, count, gfc_index_zero_node); |
6de9cd9a DN |
4746 | } |
4747 | else | |
4748 | count = NULL; | |
4749 | ||
4750 | /* Initialize count1. */ | |
726a989a | 4751 | gfc_add_modify (block, count1, gfc_index_zero_node); |
6de9cd9a DN |
4752 | |
4753 | /* Calculate the size of temporary needed in the assignment. Return loop, lss | |
4754 | and rss which are used in function generate_loop_for_rhs_to_temp(). */ | |
6de9cd9a | 4755 | /* The type of LHS. Used in function allocate_temp_for_forall_nest */ |
7bd5dad2 | 4756 | if (expr1->ts.type == BT_CHARACTER) |
640670c7 | 4757 | { |
7bd5dad2 LK |
4758 | type = NULL; |
4759 | if (expr1->ref && expr1->ref->type == REF_SUBSTRING) | |
640670c7 | 4760 | { |
7bd5dad2 LK |
4761 | gfc_se ssse; |
4762 | gfc_init_se (&ssse, NULL); | |
4763 | gfc_conv_expr (&ssse, expr1); | |
4764 | type = gfc_get_character_type_len (gfc_default_character_kind, | |
4765 | ssse.string_length); | |
4766 | } | |
4767 | else | |
4768 | { | |
4769 | if (!expr1->ts.u.cl->backend_decl) | |
4770 | { | |
4771 | gfc_se tse; | |
4772 | gcc_assert (expr1->ts.u.cl->length); | |
4773 | gfc_init_se (&tse, NULL); | |
4774 | gfc_conv_expr (&tse, expr1->ts.u.cl->length); | |
4775 | expr1->ts.u.cl->backend_decl = tse.expr; | |
4776 | } | |
4777 | type = gfc_get_character_type_len (gfc_default_character_kind, | |
4778 | expr1->ts.u.cl->backend_decl); | |
640670c7 | 4779 | } |
640670c7 PT |
4780 | } |
4781 | else | |
4782 | type = gfc_typenode_for_spec (&expr1->ts); | |
6de9cd9a | 4783 | |
7bd5dad2 LK |
4784 | gfc_init_block (&inner_size_body); |
4785 | inner_size = compute_inner_temp_size (expr1, expr2, &inner_size_body, | |
4786 | &lss, &rss); | |
4787 | ||
6de9cd9a | 4788 | /* Allocate temporary for nested forall construct according to the |
f7b529fa | 4789 | information in nested_forall_info and inner_size. */ |
8de1f441 JJ |
4790 | tmp1 = allocate_temp_for_forall_nest (nested_forall_info, type, inner_size, |
4791 | &inner_size_body, block, &ptemp1); | |
6de9cd9a | 4792 | |
6de9cd9a | 4793 | /* Generate codes to copy rhs to the temporary . */ |
8de1f441 | 4794 | tmp = generate_loop_for_rhs_to_temp (expr2, tmp1, count, count1, lss, rss, |
011daa76 | 4795 | wheremask, invert); |
6de9cd9a | 4796 | |
1f2959f0 | 4797 | /* Generate body and loops according to the information in |
6de9cd9a | 4798 | nested_forall_info. */ |
bfcabc6c | 4799 | tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1); |
6de9cd9a DN |
4800 | gfc_add_expr_to_block (block, tmp); |
4801 | ||
4802 | /* Reset count1. */ | |
726a989a | 4803 | gfc_add_modify (block, count1, gfc_index_zero_node); |
6de9cd9a | 4804 | |
6de9cd9a DN |
4805 | /* Reset count. */ |
4806 | if (wheremask) | |
726a989a | 4807 | gfc_add_modify (block, count, gfc_index_zero_node); |
6de9cd9a | 4808 | |
7bd5dad2 LK |
4809 | /* TODO: Second call to compute_inner_temp_size to initialize lss and |
4810 | rss; there must be a better way. */ | |
4811 | inner_size = compute_inner_temp_size (expr1, expr2, &inner_size_body, | |
4812 | &lss, &rss); | |
4813 | ||
6de9cd9a | 4814 | /* Generate codes to copy the temporary to lhs. */ |
011daa76 | 4815 | tmp = generate_loop_for_temp_to_lhs (expr1, tmp1, count, count1, |
7bd5dad2 | 4816 | lss, rss, |
011daa76 | 4817 | wheremask, invert); |
6de9cd9a | 4818 | |
1f2959f0 | 4819 | /* Generate body and loops according to the information in |
6de9cd9a | 4820 | nested_forall_info. */ |
bfcabc6c | 4821 | tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1); |
6de9cd9a DN |
4822 | gfc_add_expr_to_block (block, tmp); |
4823 | ||
4824 | if (ptemp1) | |
4825 | { | |
4826 | /* Free the temporary. */ | |
1529b8d9 | 4827 | tmp = gfc_call_free (ptemp1); |
6de9cd9a DN |
4828 | gfc_add_expr_to_block (block, tmp); |
4829 | } | |
4830 | } | |
4831 | ||
4832 | ||
4833 | /* Translate pointer assignment inside FORALL which need temporary. */ | |
4834 | ||
4835 | static void | |
4836 | gfc_trans_pointer_assign_need_temp (gfc_expr * expr1, gfc_expr * expr2, | |
4837 | forall_info * nested_forall_info, | |
4838 | stmtblock_t * block) | |
4839 | { | |
4840 | tree type; | |
4841 | tree inner_size; | |
4842 | gfc_ss *lss, *rss; | |
4843 | gfc_se lse; | |
4844 | gfc_se rse; | |
6d63e468 | 4845 | gfc_array_info *info; |
6de9cd9a DN |
4846 | gfc_loopinfo loop; |
4847 | tree desc; | |
4848 | tree parm; | |
4849 | tree parmtype; | |
4850 | stmtblock_t body; | |
4851 | tree count; | |
4852 | tree tmp, tmp1, ptemp1; | |
6de9cd9a DN |
4853 | |
4854 | count = gfc_create_var (gfc_array_index_type, "count"); | |
726a989a | 4855 | gfc_add_modify (block, count, gfc_index_zero_node); |
6de9cd9a | 4856 | |
932ebb94 | 4857 | inner_size = gfc_index_one_node; |
6de9cd9a DN |
4858 | lss = gfc_walk_expr (expr1); |
4859 | rss = gfc_walk_expr (expr2); | |
4860 | if (lss == gfc_ss_terminator) | |
4861 | { | |
4862 | type = gfc_typenode_for_spec (&expr1->ts); | |
4863 | type = build_pointer_type (type); | |
4864 | ||
4865 | /* Allocate temporary for nested forall construct according to the | |
4866 | information in nested_forall_info and inner_size. */ | |
8de1f441 JJ |
4867 | tmp1 = allocate_temp_for_forall_nest (nested_forall_info, type, |
4868 | inner_size, NULL, block, &ptemp1); | |
6de9cd9a DN |
4869 | gfc_start_block (&body); |
4870 | gfc_init_se (&lse, NULL); | |
1d6b7f39 | 4871 | lse.expr = gfc_build_array_ref (tmp1, count, NULL); |
6de9cd9a DN |
4872 | gfc_init_se (&rse, NULL); |
4873 | rse.want_pointer = 1; | |
4874 | gfc_conv_expr (&rse, expr2); | |
4875 | gfc_add_block_to_block (&body, &rse.pre); | |
726a989a | 4876 | gfc_add_modify (&body, lse.expr, |
cc2804f1 | 4877 | fold_convert (TREE_TYPE (lse.expr), rse.expr)); |
6de9cd9a DN |
4878 | gfc_add_block_to_block (&body, &rse.post); |
4879 | ||
4880 | /* Increment count. */ | |
bc98ed60 TB |
4881 | tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, |
4882 | count, gfc_index_one_node); | |
726a989a | 4883 | gfc_add_modify (&body, count, tmp); |
6de9cd9a DN |
4884 | |
4885 | tmp = gfc_finish_block (&body); | |
4886 | ||
1f2959f0 | 4887 | /* Generate body and loops according to the information in |
6de9cd9a | 4888 | nested_forall_info. */ |
bfcabc6c | 4889 | tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1); |
6de9cd9a DN |
4890 | gfc_add_expr_to_block (block, tmp); |
4891 | ||
4892 | /* Reset count. */ | |
726a989a | 4893 | gfc_add_modify (block, count, gfc_index_zero_node); |
6de9cd9a | 4894 | |
6de9cd9a DN |
4895 | gfc_start_block (&body); |
4896 | gfc_init_se (&lse, NULL); | |
4897 | gfc_init_se (&rse, NULL); | |
1d6b7f39 | 4898 | rse.expr = gfc_build_array_ref (tmp1, count, NULL); |
6de9cd9a DN |
4899 | lse.want_pointer = 1; |
4900 | gfc_conv_expr (&lse, expr1); | |
4901 | gfc_add_block_to_block (&body, &lse.pre); | |
726a989a | 4902 | gfc_add_modify (&body, lse.expr, rse.expr); |
6de9cd9a DN |
4903 | gfc_add_block_to_block (&body, &lse.post); |
4904 | /* Increment count. */ | |
bc98ed60 TB |
4905 | tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, |
4906 | count, gfc_index_one_node); | |
726a989a | 4907 | gfc_add_modify (&body, count, tmp); |
6de9cd9a DN |
4908 | tmp = gfc_finish_block (&body); |
4909 | ||
1f2959f0 | 4910 | /* Generate body and loops according to the information in |
6de9cd9a | 4911 | nested_forall_info. */ |
bfcabc6c | 4912 | tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1); |
6de9cd9a DN |
4913 | gfc_add_expr_to_block (block, tmp); |
4914 | } | |
4915 | else | |
4916 | { | |
4917 | gfc_init_loopinfo (&loop); | |
4918 | ||
4919 | /* Associate the SS with the loop. */ | |
4920 | gfc_add_ss_to_loop (&loop, rss); | |
4921 | ||
4922 | /* Setup the scalarizing loops and bounds. */ | |
4923 | gfc_conv_ss_startstride (&loop); | |
4924 | ||
bdfd2ff0 | 4925 | gfc_conv_loop_setup (&loop, &expr2->where); |
6de9cd9a | 4926 | |
1838afec | 4927 | info = &rss->info->data.array; |
6de9cd9a DN |
4928 | desc = info->descriptor; |
4929 | ||
4930 | /* Make a new descriptor. */ | |
4931 | parmtype = gfc_get_element_type (TREE_TYPE (desc)); | |
f33beee9 | 4932 | parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen, 0, |
fad0afd7 | 4933 | loop.from, loop.to, 1, |
10174ddf | 4934 | GFC_ARRAY_UNKNOWN, true); |
6de9cd9a DN |
4935 | |
4936 | /* Allocate temporary for nested forall construct. */ | |
4937 | tmp1 = allocate_temp_for_forall_nest (nested_forall_info, parmtype, | |
8de1f441 | 4938 | inner_size, NULL, block, &ptemp1); |
6de9cd9a DN |
4939 | gfc_start_block (&body); |
4940 | gfc_init_se (&lse, NULL); | |
1d6b7f39 | 4941 | lse.expr = gfc_build_array_ref (tmp1, count, NULL); |
6de9cd9a | 4942 | lse.direct_byref = 1; |
2960a368 | 4943 | gfc_conv_expr_descriptor (&lse, expr2); |
6de9cd9a DN |
4944 | |
4945 | gfc_add_block_to_block (&body, &lse.pre); | |
4946 | gfc_add_block_to_block (&body, &lse.post); | |
4947 | ||
4948 | /* Increment count. */ | |
bc98ed60 TB |
4949 | tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, |
4950 | count, gfc_index_one_node); | |
726a989a | 4951 | gfc_add_modify (&body, count, tmp); |
6de9cd9a DN |
4952 | |
4953 | tmp = gfc_finish_block (&body); | |
4954 | ||
1f2959f0 | 4955 | /* Generate body and loops according to the information in |
6de9cd9a | 4956 | nested_forall_info. */ |
bfcabc6c | 4957 | tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1); |
6de9cd9a DN |
4958 | gfc_add_expr_to_block (block, tmp); |
4959 | ||
4960 | /* Reset count. */ | |
726a989a | 4961 | gfc_add_modify (block, count, gfc_index_zero_node); |
6de9cd9a | 4962 | |
1d6b7f39 | 4963 | parm = gfc_build_array_ref (tmp1, count, NULL); |
6de9cd9a | 4964 | gfc_init_se (&lse, NULL); |
2960a368 | 4965 | gfc_conv_expr_descriptor (&lse, expr1); |
726a989a | 4966 | gfc_add_modify (&lse.pre, lse.expr, parm); |
6de9cd9a DN |
4967 | gfc_start_block (&body); |
4968 | gfc_add_block_to_block (&body, &lse.pre); | |
4969 | gfc_add_block_to_block (&body, &lse.post); | |
4970 | ||
4971 | /* Increment count. */ | |
bc98ed60 TB |
4972 | tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, |
4973 | count, gfc_index_one_node); | |
726a989a | 4974 | gfc_add_modify (&body, count, tmp); |
6de9cd9a DN |
4975 | |
4976 | tmp = gfc_finish_block (&body); | |
4977 | ||
bfcabc6c | 4978 | tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1); |
6de9cd9a DN |
4979 | gfc_add_expr_to_block (block, tmp); |
4980 | } | |
4981 | /* Free the temporary. */ | |
4982 | if (ptemp1) | |
4983 | { | |
1529b8d9 | 4984 | tmp = gfc_call_free (ptemp1); |
6de9cd9a DN |
4985 | gfc_add_expr_to_block (block, tmp); |
4986 | } | |
4987 | } | |
4988 | ||
4989 | ||
4990 | /* FORALL and WHERE statements are really nasty, especially when you nest | |
4991 | them. All the rhs of a forall assignment must be evaluated before the | |
4992 | actual assignments are performed. Presumably this also applies to all the | |
4993 | assignments in an inner where statement. */ | |
4994 | ||
4995 | /* Generate code for a FORALL statement. Any temporaries are allocated as a | |
4996 | linear array, relying on the fact that we process in the same order in all | |
4997 | loops. | |
4998 | ||
4999 | forall (i=start:end:stride; maskexpr) | |
5000 | e<i> = f<i> | |
5001 | g<i> = h<i> | |
5002 | end forall | |
e7dc5b4f | 5003 | (where e,f,g,h<i> are arbitrary expressions possibly involving i) |
6de9cd9a | 5004 | Translates to: |
8de1f441 | 5005 | count = ((end + 1 - start) / stride) |
6de9cd9a DN |
5006 | masktmp(:) = maskexpr(:) |
5007 | ||
5008 | maskindex = 0; | |
5009 | for (i = start; i <= end; i += stride) | |
5010 | { | |
5011 | if (masktmp[maskindex++]) | |
5012 | e<i> = f<i> | |
5013 | } | |
5014 | maskindex = 0; | |
5015 | for (i = start; i <= end; i += stride) | |
5016 | { | |
5017 | if (masktmp[maskindex++]) | |
cafa34aa | 5018 | g<i> = h<i> |
6de9cd9a DN |
5019 | } |
5020 | ||
5021 | Note that this code only works when there are no dependencies. | |
5022 | Forall loop with array assignments and data dependencies are a real pain, | |
5023 | because the size of the temporary cannot always be determined before the | |
1f2959f0 | 5024 | loop is executed. This problem is compounded by the presence of nested |
6de9cd9a DN |
5025 | FORALL constructs. |
5026 | */ | |
5027 | ||
5028 | static tree | |
5029 | gfc_trans_forall_1 (gfc_code * code, forall_info * nested_forall_info) | |
5030 | { | |
640670c7 PT |
5031 | stmtblock_t pre; |
5032 | stmtblock_t post; | |
6de9cd9a DN |
5033 | stmtblock_t block; |
5034 | stmtblock_t body; | |
5035 | tree *var; | |
5036 | tree *start; | |
5037 | tree *end; | |
5038 | tree *step; | |
5039 | gfc_expr **varexpr; | |
5040 | tree tmp; | |
5041 | tree assign; | |
5042 | tree size; | |
6de9cd9a DN |
5043 | tree maskindex; |
5044 | tree mask; | |
5045 | tree pmask; | |
8c6a85e3 | 5046 | tree cycle_label = NULL_TREE; |
6de9cd9a DN |
5047 | int n; |
5048 | int nvar; | |
5049 | int need_temp; | |
5050 | gfc_forall_iterator *fa; | |
5051 | gfc_se se; | |
5052 | gfc_code *c; | |
7b5b57b7 | 5053 | gfc_saved_var *saved_vars; |
bfcabc6c RS |
5054 | iter_info *this_forall; |
5055 | forall_info *info; | |
e35a0e64 RS |
5056 | bool need_mask; |
5057 | ||
5058 | /* Do nothing if the mask is false. */ | |
a513927a SK |
5059 | if (code->expr1 |
5060 | && code->expr1->expr_type == EXPR_CONSTANT | |
5061 | && !code->expr1->value.logical) | |
c2255bc4 | 5062 | return build_empty_stmt (input_location); |
6de9cd9a DN |
5063 | |
5064 | n = 0; | |
5065 | /* Count the FORALL index number. */ | |
5066 | for (fa = code->ext.forall_iterator; fa; fa = fa->next) | |
5067 | n++; | |
5068 | nvar = n; | |
5069 | ||
5070 | /* Allocate the space for var, start, end, step, varexpr. */ | |
93acb62c JB |
5071 | var = XCNEWVEC (tree, nvar); |
5072 | start = XCNEWVEC (tree, nvar); | |
5073 | end = XCNEWVEC (tree, nvar); | |
5074 | step = XCNEWVEC (tree, nvar); | |
5075 | varexpr = XCNEWVEC (gfc_expr *, nvar); | |
5076 | saved_vars = XCNEWVEC (gfc_saved_var, nvar); | |
6de9cd9a DN |
5077 | |
5078 | /* Allocate the space for info. */ | |
93acb62c | 5079 | info = XCNEW (forall_info); |
bfcabc6c | 5080 | |
640670c7 PT |
5081 | gfc_start_block (&pre); |
5082 | gfc_init_block (&post); | |
5083 | gfc_init_block (&block); | |
bfcabc6c | 5084 | |
6de9cd9a DN |
5085 | n = 0; |
5086 | for (fa = code->ext.forall_iterator; fa; fa = fa->next) | |
5087 | { | |
5088 | gfc_symbol *sym = fa->var->symtree->n.sym; | |
5089 | ||
bfcabc6c | 5090 | /* Allocate space for this_forall. */ |
93acb62c | 5091 | this_forall = XCNEW (iter_info); |
6de9cd9a | 5092 | |
6de9cd9a DN |
5093 | /* Create a temporary variable for the FORALL index. */ |
5094 | tmp = gfc_typenode_for_spec (&sym->ts); | |
5095 | var[n] = gfc_create_var (tmp, sym->name); | |
7b5b57b7 PB |
5096 | gfc_shadow_sym (sym, var[n], &saved_vars[n]); |
5097 | ||
6de9cd9a DN |
5098 | /* Record it in this_forall. */ |
5099 | this_forall->var = var[n]; | |
5100 | ||
5101 | /* Replace the index symbol's backend_decl with the temporary decl. */ | |
5102 | sym->backend_decl = var[n]; | |
5103 | ||
5104 | /* Work out the start, end and stride for the loop. */ | |
5105 | gfc_init_se (&se, NULL); | |
5106 | gfc_conv_expr_val (&se, fa->start); | |
5107 | /* Record it in this_forall. */ | |
5108 | this_forall->start = se.expr; | |
5109 | gfc_add_block_to_block (&block, &se.pre); | |
5110 | start[n] = se.expr; | |
5111 | ||
5112 | gfc_init_se (&se, NULL); | |
5113 | gfc_conv_expr_val (&se, fa->end); | |
5114 | /* Record it in this_forall. */ | |
5115 | this_forall->end = se.expr; | |
5116 | gfc_make_safe_expr (&se); | |
5117 | gfc_add_block_to_block (&block, &se.pre); | |
5118 | end[n] = se.expr; | |
5119 | ||
5120 | gfc_init_se (&se, NULL); | |
5121 | gfc_conv_expr_val (&se, fa->stride); | |
5122 | /* Record it in this_forall. */ | |
5123 | this_forall->step = se.expr; | |
5124 | gfc_make_safe_expr (&se); | |
5125 | gfc_add_block_to_block (&block, &se.pre); | |
5126 | step[n] = se.expr; | |
5127 | ||
9935667a HA |
5128 | /* Copy loop annotations. */ |
5129 | this_forall->annot = fa->annot; | |
5130 | ||
6de9cd9a DN |
5131 | /* Set the NEXT field of this_forall to NULL. */ |
5132 | this_forall->next = NULL; | |
5133 | /* Link this_forall to the info construct. */ | |
bfcabc6c | 5134 | if (info->this_loop) |
6de9cd9a | 5135 | { |
bfcabc6c | 5136 | iter_info *iter_tmp = info->this_loop; |
6de9cd9a DN |
5137 | while (iter_tmp->next != NULL) |
5138 | iter_tmp = iter_tmp->next; | |
5139 | iter_tmp->next = this_forall; | |
5140 | } | |
bfcabc6c RS |
5141 | else |
5142 | info->this_loop = this_forall; | |
6de9cd9a DN |
5143 | |
5144 | n++; | |
5145 | } | |
5146 | nvar = n; | |
5147 | ||
bfcabc6c | 5148 | /* Calculate the size needed for the current forall level. */ |
7ab92584 | 5149 | size = gfc_index_one_node; |
6de9cd9a DN |
5150 | for (n = 0; n < nvar; n++) |
5151 | { | |
6de9cd9a | 5152 | /* size = (end + step - start) / step. */ |
8b704316 | 5153 | tmp = fold_build2_loc (input_location, MINUS_EXPR, TREE_TYPE (start[n]), |
bc98ed60 TB |
5154 | step[n], start[n]); |
5155 | tmp = fold_build2_loc (input_location, PLUS_EXPR, TREE_TYPE (end[n]), | |
5156 | end[n], tmp); | |
5157 | tmp = fold_build2_loc (input_location, FLOOR_DIV_EXPR, TREE_TYPE (tmp), | |
5158 | tmp, step[n]); | |
6de9cd9a DN |
5159 | tmp = convert (gfc_array_index_type, tmp); |
5160 | ||
bc98ed60 TB |
5161 | size = fold_build2_loc (input_location, MULT_EXPR, gfc_array_index_type, |
5162 | size, tmp); | |
6de9cd9a DN |
5163 | } |
5164 | ||
5165 | /* Record the nvar and size of current forall level. */ | |
5166 | info->nvar = nvar; | |
5167 | info->size = size; | |
5168 | ||
a513927a | 5169 | if (code->expr1) |
e35a0e64 RS |
5170 | { |
5171 | /* If the mask is .true., consider the FORALL unconditional. */ | |
a513927a SK |
5172 | if (code->expr1->expr_type == EXPR_CONSTANT |
5173 | && code->expr1->value.logical) | |
e35a0e64 RS |
5174 | need_mask = false; |
5175 | else | |
5176 | need_mask = true; | |
5177 | } | |
5178 | else | |
5179 | need_mask = false; | |
5180 | ||
5181 | /* First we need to allocate the mask. */ | |
5182 | if (need_mask) | |
bfcabc6c RS |
5183 | { |
5184 | /* As the mask array can be very big, prefer compact boolean types. */ | |
5185 | tree mask_type = gfc_get_logical_type (gfc_logical_kinds[0].kind); | |
5186 | mask = allocate_temp_for_forall_nest (nested_forall_info, mask_type, | |
5187 | size, NULL, &block, &pmask); | |
5188 | maskindex = gfc_create_var_np (gfc_array_index_type, "mi"); | |
5189 | ||
5190 | /* Record them in the info structure. */ | |
5191 | info->maskindex = maskindex; | |
5192 | info->mask = mask; | |
5193 | } | |
6de9cd9a DN |
5194 | else |
5195 | { | |
bfcabc6c RS |
5196 | /* No mask was specified. */ |
5197 | maskindex = NULL_TREE; | |
5198 | mask = pmask = NULL_TREE; | |
5199 | } | |
5200 | ||
5201 | /* Link the current forall level to nested_forall_info. */ | |
e8d366ec RS |
5202 | info->prev_nest = nested_forall_info; |
5203 | nested_forall_info = info; | |
6de9cd9a DN |
5204 | |
5205 | /* Copy the mask into a temporary variable if required. | |
f7b529fa | 5206 | For now we assume a mask temporary is needed. */ |
e35a0e64 | 5207 | if (need_mask) |
6de9cd9a | 5208 | { |
bfcabc6c RS |
5209 | /* As the mask array can be very big, prefer compact boolean types. */ |
5210 | tree mask_type = gfc_get_logical_type (gfc_logical_kinds[0].kind); | |
6de9cd9a | 5211 | |
726a989a | 5212 | gfc_add_modify (&block, maskindex, gfc_index_zero_node); |
6de9cd9a DN |
5213 | |
5214 | /* Start of mask assignment loop body. */ | |
5215 | gfc_start_block (&body); | |
5216 | ||
5217 | /* Evaluate the mask expression. */ | |
5218 | gfc_init_se (&se, NULL); | |
a513927a | 5219 | gfc_conv_expr_val (&se, code->expr1); |
6de9cd9a DN |
5220 | gfc_add_block_to_block (&body, &se.pre); |
5221 | ||
5222 | /* Store the mask. */ | |
bfcabc6c | 5223 | se.expr = convert (mask_type, se.expr); |
6de9cd9a | 5224 | |
1d6b7f39 | 5225 | tmp = gfc_build_array_ref (mask, maskindex, NULL); |
726a989a | 5226 | gfc_add_modify (&body, tmp, se.expr); |
6de9cd9a DN |
5227 | |
5228 | /* Advance to the next mask element. */ | |
bc98ed60 TB |
5229 | tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, |
5230 | maskindex, gfc_index_one_node); | |
726a989a | 5231 | gfc_add_modify (&body, maskindex, tmp); |
6de9cd9a DN |
5232 | |
5233 | /* Generate the loops. */ | |
5234 | tmp = gfc_finish_block (&body); | |
bfcabc6c | 5235 | tmp = gfc_trans_nested_forall_loop (info, tmp, 0); |
6de9cd9a DN |
5236 | gfc_add_expr_to_block (&block, tmp); |
5237 | } | |
6de9cd9a | 5238 | |
8c6a85e3 TB |
5239 | if (code->op == EXEC_DO_CONCURRENT) |
5240 | { | |
5241 | gfc_init_block (&body); | |
5242 | cycle_label = gfc_build_label_decl (NULL_TREE); | |
5243 | code->cycle_label = cycle_label; | |
5244 | tmp = gfc_trans_code (code->block->next); | |
5245 | gfc_add_expr_to_block (&body, tmp); | |
5246 | ||
5247 | if (TREE_USED (cycle_label)) | |
5248 | { | |
5249 | tmp = build1_v (LABEL_EXPR, cycle_label); | |
5250 | gfc_add_expr_to_block (&body, tmp); | |
5251 | } | |
5252 | ||
5253 | tmp = gfc_finish_block (&body); | |
2ca4e2c2 | 5254 | nested_forall_info->do_concurrent = true; |
8c6a85e3 TB |
5255 | tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1); |
5256 | gfc_add_expr_to_block (&block, tmp); | |
5257 | goto done; | |
5258 | } | |
5259 | ||
6de9cd9a DN |
5260 | c = code->block->next; |
5261 | ||
5262 | /* TODO: loop merging in FORALL statements. */ | |
5263 | /* Now that we've got a copy of the mask, generate the assignment loops. */ | |
5264 | while (c) | |
5265 | { | |
5266 | switch (c->op) | |
5267 | { | |
5268 | case EXEC_ASSIGN: | |
640670c7 PT |
5269 | /* A scalar or array assignment. DO the simple check for |
5270 | lhs to rhs dependencies. These make a temporary for the | |
5271 | rhs and form a second forall block to copy to variable. */ | |
5272 | need_temp = check_forall_dependencies(c, &pre, &post); | |
5273 | ||
69de3b83 | 5274 | /* Temporaries due to array assignment data dependencies introduce |
6de9cd9a | 5275 | no end of problems. */ |
7bd5dad2 LK |
5276 | if (need_temp || flag_test_forall_temp) |
5277 | gfc_trans_assign_need_temp (c->expr1, c->expr2, NULL, false, | |
6de9cd9a DN |
5278 | nested_forall_info, &block); |
5279 | else | |
5280 | { | |
5281 | /* Use the normal assignment copying routines. */ | |
2b56d6a4 | 5282 | assign = gfc_trans_assignment (c->expr1, c->expr2, false, true); |
6de9cd9a | 5283 | |
6de9cd9a | 5284 | /* Generate body and loops. */ |
bfcabc6c RS |
5285 | tmp = gfc_trans_nested_forall_loop (nested_forall_info, |
5286 | assign, 1); | |
6de9cd9a DN |
5287 | gfc_add_expr_to_block (&block, tmp); |
5288 | } | |
5289 | ||
640670c7 PT |
5290 | /* Cleanup any temporary symtrees that have been made to deal |
5291 | with dependencies. */ | |
5292 | if (new_symtree) | |
5293 | cleanup_forall_symtrees (c); | |
5294 | ||
6de9cd9a DN |
5295 | break; |
5296 | ||
5297 | case EXEC_WHERE: | |
6de9cd9a | 5298 | /* Translate WHERE or WHERE construct nested in FORALL. */ |
011daa76 | 5299 | gfc_trans_where_2 (c, NULL, false, nested_forall_info, &block); |
3891cee2 | 5300 | break; |
6de9cd9a DN |
5301 | |
5302 | /* Pointer assignment inside FORALL. */ | |
5303 | case EXEC_POINTER_ASSIGN: | |
a513927a | 5304 | need_temp = gfc_check_dependency (c->expr1, c->expr2, 0); |
7bd5dad2 LK |
5305 | /* Avoid cases where a temporary would never be needed and where |
5306 | the temp code is guaranteed to fail. */ | |
5307 | if (need_temp | |
5308 | || (flag_test_forall_temp | |
5309 | && c->expr2->expr_type != EXPR_CONSTANT | |
5310 | && c->expr2->expr_type != EXPR_NULL)) | |
a513927a | 5311 | gfc_trans_pointer_assign_need_temp (c->expr1, c->expr2, |
6de9cd9a DN |
5312 | nested_forall_info, &block); |
5313 | else | |
5314 | { | |
5315 | /* Use the normal assignment copying routines. */ | |
a513927a | 5316 | assign = gfc_trans_pointer_assignment (c->expr1, c->expr2); |
6de9cd9a | 5317 | |
6de9cd9a | 5318 | /* Generate body and loops. */ |
bfcabc6c RS |
5319 | tmp = gfc_trans_nested_forall_loop (nested_forall_info, |
5320 | assign, 1); | |
6de9cd9a DN |
5321 | gfc_add_expr_to_block (&block, tmp); |
5322 | } | |
5323 | break; | |
5324 | ||
5325 | case EXEC_FORALL: | |
5326 | tmp = gfc_trans_forall_1 (c, nested_forall_info); | |
5327 | gfc_add_expr_to_block (&block, tmp); | |
5328 | break; | |
5329 | ||
48474141 PT |
5330 | /* Explicit subroutine calls are prevented by the frontend but interface |
5331 | assignments can legitimately produce them. */ | |
476220e7 | 5332 | case EXEC_ASSIGN_CALL: |
eb74e79b | 5333 | assign = gfc_trans_call (c, true, NULL_TREE, NULL_TREE, false); |
bfcabc6c | 5334 | tmp = gfc_trans_nested_forall_loop (nested_forall_info, assign, 1); |
48474141 PT |
5335 | gfc_add_expr_to_block (&block, tmp); |
5336 | break; | |
5337 | ||
6de9cd9a | 5338 | default: |
6e45f57b | 5339 | gcc_unreachable (); |
6de9cd9a DN |
5340 | } |
5341 | ||
5342 | c = c->next; | |
5343 | } | |
5344 | ||
8c6a85e3 | 5345 | done: |
7b5b57b7 PB |
5346 | /* Restore the original index variables. */ |
5347 | for (fa = code->ext.forall_iterator, n = 0; fa; fa = fa->next, n++) | |
5348 | gfc_restore_sym (fa->var->symtree->n.sym, &saved_vars[n]); | |
6de9cd9a DN |
5349 | |
5350 | /* Free the space for var, start, end, step, varexpr. */ | |
cede9502 JM |
5351 | free (var); |
5352 | free (start); | |
5353 | free (end); | |
5354 | free (step); | |
5355 | free (varexpr); | |
5356 | free (saved_vars); | |
6de9cd9a | 5357 | |
3231fe90 MM |
5358 | for (this_forall = info->this_loop; this_forall;) |
5359 | { | |
5360 | iter_info *next = this_forall->next; | |
cede9502 | 5361 | free (this_forall); |
3231fe90 MM |
5362 | this_forall = next; |
5363 | } | |
5364 | ||
e8d366ec | 5365 | /* Free the space for this forall_info. */ |
cede9502 | 5366 | free (info); |
e8d366ec | 5367 | |
6de9cd9a DN |
5368 | if (pmask) |
5369 | { | |
5370 | /* Free the temporary for the mask. */ | |
1529b8d9 | 5371 | tmp = gfc_call_free (pmask); |
6de9cd9a DN |
5372 | gfc_add_expr_to_block (&block, tmp); |
5373 | } | |
5374 | if (maskindex) | |
5375 | pushdecl (maskindex); | |
5376 | ||
640670c7 PT |
5377 | gfc_add_block_to_block (&pre, &block); |
5378 | gfc_add_block_to_block (&pre, &post); | |
5379 | ||
5380 | return gfc_finish_block (&pre); | |
6de9cd9a DN |
5381 | } |
5382 | ||
5383 | ||
5384 | /* Translate the FORALL statement or construct. */ | |
5385 | ||
5386 | tree gfc_trans_forall (gfc_code * code) | |
5387 | { | |
5388 | return gfc_trans_forall_1 (code, NULL); | |
5389 | } | |
5390 | ||
5391 | ||
8c6a85e3 TB |
5392 | /* Translate the DO CONCURRENT construct. */ |
5393 | ||
5394 | tree gfc_trans_do_concurrent (gfc_code * code) | |
5395 | { | |
5396 | return gfc_trans_forall_1 (code, NULL); | |
5397 | } | |
5398 | ||
5399 | ||
6de9cd9a DN |
5400 | /* Evaluate the WHERE mask expression, copy its value to a temporary. |
5401 | If the WHERE construct is nested in FORALL, compute the overall temporary | |
5402 | needed by the WHERE mask expression multiplied by the iterator number of | |
5403 | the nested forall. | |
5404 | ME is the WHERE mask expression. | |
011daa76 RS |
5405 | MASK is the current execution mask upon input, whose sense may or may |
5406 | not be inverted as specified by the INVERT argument. | |
3891cee2 RS |
5407 | CMASK is the updated execution mask on output, or NULL if not required. |
5408 | PMASK is the pending execution mask on output, or NULL if not required. | |
5409 | BLOCK is the block in which to place the condition evaluation loops. */ | |
6de9cd9a | 5410 | |
3891cee2 | 5411 | static void |
6de9cd9a | 5412 | gfc_evaluate_where_mask (gfc_expr * me, forall_info * nested_forall_info, |
011daa76 | 5413 | tree mask, bool invert, tree cmask, tree pmask, |
3891cee2 | 5414 | tree mask_type, stmtblock_t * block) |
6de9cd9a DN |
5415 | { |
5416 | tree tmp, tmp1; | |
5417 | gfc_ss *lss, *rss; | |
5418 | gfc_loopinfo loop; | |
3891cee2 RS |
5419 | stmtblock_t body, body1; |
5420 | tree count, cond, mtmp; | |
6de9cd9a | 5421 | gfc_se lse, rse; |
6de9cd9a DN |
5422 | |
5423 | gfc_init_loopinfo (&loop); | |
5424 | ||
3891cee2 RS |
5425 | lss = gfc_walk_expr (me); |
5426 | rss = gfc_walk_expr (me); | |
6de9cd9a DN |
5427 | |
5428 | /* Variable to index the temporary. */ | |
5429 | count = gfc_create_var (gfc_array_index_type, "count"); | |
1f2959f0 | 5430 | /* Initialize count. */ |
726a989a | 5431 | gfc_add_modify (block, count, gfc_index_zero_node); |
6de9cd9a DN |
5432 | |
5433 | gfc_start_block (&body); | |
5434 | ||
5435 | gfc_init_se (&rse, NULL); | |
5436 | gfc_init_se (&lse, NULL); | |
5437 | ||
5438 | if (lss == gfc_ss_terminator) | |
5439 | { | |
5440 | gfc_init_block (&body1); | |
5441 | } | |
5442 | else | |
5443 | { | |
1f2959f0 | 5444 | /* Initialize the loop. */ |
6de9cd9a DN |
5445 | gfc_init_loopinfo (&loop); |
5446 | ||
5447 | /* We may need LSS to determine the shape of the expression. */ | |
5448 | gfc_add_ss_to_loop (&loop, lss); | |
5449 | gfc_add_ss_to_loop (&loop, rss); | |
5450 | ||
5451 | gfc_conv_ss_startstride (&loop); | |
bdfd2ff0 | 5452 | gfc_conv_loop_setup (&loop, &me->where); |
6de9cd9a DN |
5453 | |
5454 | gfc_mark_ss_chain_used (rss, 1); | |
5455 | /* Start the loop body. */ | |
5456 | gfc_start_scalarized_body (&loop, &body1); | |
5457 | ||
5458 | /* Translate the expression. */ | |
5459 | gfc_copy_loopinfo_to_se (&rse, &loop); | |
5460 | rse.ss = rss; | |
5461 | gfc_conv_expr (&rse, me); | |
5462 | } | |
6de9cd9a | 5463 | |
b82feea5 | 5464 | /* Variable to evaluate mask condition. */ |
3891cee2 RS |
5465 | cond = gfc_create_var (mask_type, "cond"); |
5466 | if (mask && (cmask || pmask)) | |
5467 | mtmp = gfc_create_var (mask_type, "mask"); | |
5468 | else mtmp = NULL_TREE; | |
5469 | ||
5470 | gfc_add_block_to_block (&body1, &lse.pre); | |
5471 | gfc_add_block_to_block (&body1, &rse.pre); | |
6de9cd9a | 5472 | |
726a989a | 5473 | gfc_add_modify (&body1, cond, fold_convert (mask_type, rse.expr)); |
3891cee2 RS |
5474 | |
5475 | if (mask && (cmask || pmask)) | |
42e73749 | 5476 | { |
1d6b7f39 | 5477 | tmp = gfc_build_array_ref (mask, count, NULL); |
011daa76 | 5478 | if (invert) |
bc98ed60 | 5479 | tmp = fold_build1_loc (input_location, TRUTH_NOT_EXPR, mask_type, tmp); |
726a989a | 5480 | gfc_add_modify (&body1, mtmp, tmp); |
42e73749 | 5481 | } |
6de9cd9a | 5482 | |
3891cee2 RS |
5483 | if (cmask) |
5484 | { | |
1d6b7f39 | 5485 | tmp1 = gfc_build_array_ref (cmask, count, NULL); |
3891cee2 RS |
5486 | tmp = cond; |
5487 | if (mask) | |
bc98ed60 TB |
5488 | tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR, mask_type, |
5489 | mtmp, tmp); | |
726a989a | 5490 | gfc_add_modify (&body1, tmp1, tmp); |
3891cee2 RS |
5491 | } |
5492 | ||
5493 | if (pmask) | |
5494 | { | |
1d6b7f39 | 5495 | tmp1 = gfc_build_array_ref (pmask, count, NULL); |
bc98ed60 | 5496 | tmp = fold_build1_loc (input_location, TRUTH_NOT_EXPR, mask_type, cond); |
3891cee2 | 5497 | if (mask) |
bc98ed60 TB |
5498 | tmp = fold_build2_loc (input_location, TRUTH_AND_EXPR, mask_type, mtmp, |
5499 | tmp); | |
726a989a | 5500 | gfc_add_modify (&body1, tmp1, tmp); |
3891cee2 RS |
5501 | } |
5502 | ||
5503 | gfc_add_block_to_block (&body1, &lse.post); | |
5504 | gfc_add_block_to_block (&body1, &rse.post); | |
5505 | ||
5506 | if (lss == gfc_ss_terminator) | |
6de9cd9a DN |
5507 | { |
5508 | gfc_add_block_to_block (&body, &body1); | |
5509 | } | |
5510 | else | |
5511 | { | |
5512 | /* Increment count. */ | |
bc98ed60 TB |
5513 | tmp1 = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, |
5514 | count, gfc_index_one_node); | |
726a989a | 5515 | gfc_add_modify (&body1, count, tmp1); |
6de9cd9a DN |
5516 | |
5517 | /* Generate the copying loops. */ | |
5518 | gfc_trans_scalarizing_loops (&loop, &body1); | |
5519 | ||
5520 | gfc_add_block_to_block (&body, &loop.pre); | |
5521 | gfc_add_block_to_block (&body, &loop.post); | |
5522 | ||
5523 | gfc_cleanup_loop (&loop); | |
5524 | /* TODO: Reuse lss and rss when copying temp->lhs. Need to be careful | |
5525 | as tree nodes in SS may not be valid in different scope. */ | |
5526 | } | |
5527 | ||
5528 | tmp1 = gfc_finish_block (&body); | |
5529 | /* If the WHERE construct is inside FORALL, fill the full temporary. */ | |
5530 | if (nested_forall_info != NULL) | |
bfcabc6c | 5531 | tmp1 = gfc_trans_nested_forall_loop (nested_forall_info, tmp1, 1); |
6de9cd9a DN |
5532 | |
5533 | gfc_add_expr_to_block (block, tmp1); | |
6de9cd9a DN |
5534 | } |
5535 | ||
5536 | ||
5537 | /* Translate an assignment statement in a WHERE statement or construct | |
5538 | statement. The MASK expression is used to control which elements | |
011daa76 RS |
5539 | of EXPR1 shall be assigned. The sense of MASK is specified by |
5540 | INVERT. */ | |
6de9cd9a DN |
5541 | |
5542 | static tree | |
011daa76 RS |
5543 | gfc_trans_where_assign (gfc_expr *expr1, gfc_expr *expr2, |
5544 | tree mask, bool invert, | |
a00b8d1a | 5545 | tree count1, tree count2, |
eb74e79b | 5546 | gfc_code *cnext) |
6de9cd9a DN |
5547 | { |
5548 | gfc_se lse; | |
5549 | gfc_se rse; | |
5550 | gfc_ss *lss; | |
5551 | gfc_ss *lss_section; | |
5552 | gfc_ss *rss; | |
5553 | ||
5554 | gfc_loopinfo loop; | |
5555 | tree tmp; | |
5556 | stmtblock_t block; | |
5557 | stmtblock_t body; | |
3c90c9ae | 5558 | tree index, maskexpr; |
6de9cd9a | 5559 | |
1cc0e193 | 5560 | /* A defined assignment. */ |
eb74e79b PT |
5561 | if (cnext && cnext->resolved_sym) |
5562 | return gfc_trans_call (cnext, true, mask, count1, invert); | |
5563 | ||
6de9cd9a DN |
5564 | #if 0 |
5565 | /* TODO: handle this special case. | |
5566 | Special case a single function returning an array. */ | |
5567 | if (expr2->expr_type == EXPR_FUNCTION && expr2->rank > 0) | |
5568 | { | |
5569 | tmp = gfc_trans_arrayfunc_assign (expr1, expr2); | |
5570 | if (tmp) | |
5571 | return tmp; | |
5572 | } | |
5573 | #endif | |
5574 | ||
5575 | /* Assignment of the form lhs = rhs. */ | |
5576 | gfc_start_block (&block); | |
5577 | ||
5578 | gfc_init_se (&lse, NULL); | |
5579 | gfc_init_se (&rse, NULL); | |
5580 | ||
5581 | /* Walk the lhs. */ | |
5582 | lss = gfc_walk_expr (expr1); | |
5583 | rss = NULL; | |
5584 | ||
5585 | /* In each where-assign-stmt, the mask-expr and the variable being | |
5586 | defined shall be arrays of the same shape. */ | |
6e45f57b | 5587 | gcc_assert (lss != gfc_ss_terminator); |
6de9cd9a DN |
5588 | |
5589 | /* The assignment needs scalarization. */ | |
5590 | lss_section = lss; | |
5591 | ||
5592 | /* Find a non-scalar SS from the lhs. */ | |
5593 | while (lss_section != gfc_ss_terminator | |
bcc4d4e0 | 5594 | && lss_section->info->type != GFC_SS_SECTION) |
6de9cd9a DN |
5595 | lss_section = lss_section->next; |
5596 | ||
6e45f57b | 5597 | gcc_assert (lss_section != gfc_ss_terminator); |
6de9cd9a DN |
5598 | |
5599 | /* Initialize the scalarizer. */ | |
5600 | gfc_init_loopinfo (&loop); | |
5601 | ||
5602 | /* Walk the rhs. */ | |
5603 | rss = gfc_walk_expr (expr2); | |
5604 | if (rss == gfc_ss_terminator) | |
26f77530 MM |
5605 | { |
5606 | /* The rhs is scalar. Add a ss for the expression. */ | |
5607 | rss = gfc_get_scalar_ss (gfc_ss_terminator, expr2); | |
42d0058e | 5608 | rss->info->where = 1; |
6de9cd9a DN |
5609 | } |
5610 | ||
5611 | /* Associate the SS with the loop. */ | |
5612 | gfc_add_ss_to_loop (&loop, lss); | |
5613 | gfc_add_ss_to_loop (&loop, rss); | |
5614 | ||
5615 | /* Calculate the bounds of the scalarization. */ | |
5616 | gfc_conv_ss_startstride (&loop); | |
5617 | ||
5618 | /* Resolve any data dependencies in the statement. */ | |
5619 | gfc_conv_resolve_dependencies (&loop, lss_section, rss); | |
5620 | ||
5621 | /* Setup the scalarizing loops. */ | |
bdfd2ff0 | 5622 | gfc_conv_loop_setup (&loop, &expr2->where); |
6de9cd9a DN |
5623 | |
5624 | /* Setup the gfc_se structures. */ | |
5625 | gfc_copy_loopinfo_to_se (&lse, &loop); | |
5626 | gfc_copy_loopinfo_to_se (&rse, &loop); | |
5627 | ||
5628 | rse.ss = rss; | |
5629 | gfc_mark_ss_chain_used (rss, 1); | |
5630 | if (loop.temp_ss == NULL) | |
5631 | { | |
5632 | lse.ss = lss; | |
5633 | gfc_mark_ss_chain_used (lss, 1); | |
5634 | } | |
5635 | else | |
5636 | { | |
5637 | lse.ss = loop.temp_ss; | |
5638 | gfc_mark_ss_chain_used (lss, 3); | |
5639 | gfc_mark_ss_chain_used (loop.temp_ss, 3); | |
5640 | } | |
5641 | ||
5642 | /* Start the scalarized loop body. */ | |
5643 | gfc_start_scalarized_body (&loop, &body); | |
5644 | ||
5645 | /* Translate the expression. */ | |
5646 | gfc_conv_expr (&rse, expr2); | |
5647 | if (lss != gfc_ss_terminator && loop.temp_ss != NULL) | |
3db5d687 | 5648 | gfc_conv_tmp_array_ref (&lse); |
6de9cd9a DN |
5649 | else |
5650 | gfc_conv_expr (&lse, expr1); | |
5651 | ||
3c90c9ae | 5652 | /* Form the mask expression according to the mask. */ |
6de9cd9a | 5653 | index = count1; |
1d6b7f39 | 5654 | maskexpr = gfc_build_array_ref (mask, index, NULL); |
011daa76 | 5655 | if (invert) |
bc98ed60 TB |
5656 | maskexpr = fold_build1_loc (input_location, TRUTH_NOT_EXPR, |
5657 | TREE_TYPE (maskexpr), maskexpr); | |
6de9cd9a | 5658 | |
6de9cd9a | 5659 | /* Use the scalar assignment as is. */ |
eb74e79b | 5660 | tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts, |
ed673c00 | 5661 | false, loop.temp_ss == NULL); |
a00b8d1a | 5662 | |
c2255bc4 | 5663 | tmp = build3_v (COND_EXPR, maskexpr, tmp, build_empty_stmt (input_location)); |
6de9cd9a DN |
5664 | |
5665 | gfc_add_expr_to_block (&body, tmp); | |
5666 | ||
5667 | if (lss == gfc_ss_terminator) | |
5668 | { | |
5669 | /* Increment count1. */ | |
bc98ed60 TB |
5670 | tmp = fold_build2_loc (input_location, PLUS_EXPR, gfc_array_index_type, |
5671 | count1, gfc_index_one_node); | |
726a989a | 5672 | gfc_add_modify (&body, count1, tmp); |
6de9cd9a DN |
5673 | |
5674 | /* Use the scalar assignment as is. */ | |
5675 | gfc_add_block_to_block (&block, &body); | |
5676 | } | |
5677 | else | |
5678 | { | |
6e45f57b PB |
5679 | gcc_assert (lse.ss == gfc_ss_terminator |
5680 | && rse.ss == gfc_ss_terminator); | |
6de9cd9a DN |
5681 | |
5682 | if (loop.temp_ss != NULL) | |
5683 | { | |
5684 | /* Increment count1 before finish the main body of a scalarized | |
5685 | expression. */ | |
bc98ed60 TB |
5686 | tmp = fold_build2_loc (input_location, PLUS_EXPR, |
5687 | gfc_array_index_type, count1, gfc_index_one_node); | |
726a989a | 5688 | gfc_add_modify (&body, count1, tmp); |
6de9cd9a DN |
5689 | gfc_trans_scalarized_loop_boundary (&loop, &body); |
5690 | ||
5691 | /* We need to copy the temporary to the actual lhs. */ | |
5692 | gfc_init_se (&lse, NULL); | |
5693 | gfc_init_se (&rse, NULL); | |
5694 | gfc_copy_loopinfo_to_se (&lse, &loop); | |
5695 | gfc_copy_loopinfo_to_se (&rse, &loop); | |
5696 | ||
5697 | rse.ss = loop.temp_ss; | |
5698 | lse.ss = lss; | |
5699 | ||
5700 | gfc_conv_tmp_array_ref (&rse); | |
6de9cd9a DN |
5701 | gfc_conv_expr (&lse, expr1); |
5702 | ||
6e45f57b PB |
5703 | gcc_assert (lse.ss == gfc_ss_terminator |
5704 | && rse.ss == gfc_ss_terminator); | |
6de9cd9a DN |
5705 | |
5706 | /* Form the mask expression according to the mask tree list. */ | |
5707 | index = count2; | |
1d6b7f39 | 5708 | maskexpr = gfc_build_array_ref (mask, index, NULL); |
011daa76 | 5709 | if (invert) |
bc98ed60 TB |
5710 | maskexpr = fold_build1_loc (input_location, TRUTH_NOT_EXPR, |
5711 | TREE_TYPE (maskexpr), maskexpr); | |
6de9cd9a | 5712 | |
6de9cd9a | 5713 | /* Use the scalar assignment as is. */ |
ed673c00 | 5714 | tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts, false, true); |
c2255bc4 AH |
5715 | tmp = build3_v (COND_EXPR, maskexpr, tmp, |
5716 | build_empty_stmt (input_location)); | |
6de9cd9a | 5717 | gfc_add_expr_to_block (&body, tmp); |
7ab92584 | 5718 | |
6de9cd9a | 5719 | /* Increment count2. */ |
bc98ed60 TB |
5720 | tmp = fold_build2_loc (input_location, PLUS_EXPR, |
5721 | gfc_array_index_type, count2, | |
5722 | gfc_index_one_node); | |
726a989a | 5723 | gfc_add_modify (&body, count2, tmp); |
6de9cd9a DN |
5724 | } |
5725 | else | |
5726 | { | |
5727 | /* Increment count1. */ | |
bc98ed60 TB |
5728 | tmp = fold_build2_loc (input_location, PLUS_EXPR, |
5729 | gfc_array_index_type, count1, | |
5730 | gfc_index_one_node); | |
726a989a | 5731 | gfc_add_modify (&body, count1, tmp); |
6de9cd9a DN |
5732 | } |
5733 | ||
5734 | /* Generate the copying loops. */ | |
5735 | gfc_trans_scalarizing_loops (&loop, &body); | |
5736 | ||
5737 | /* Wrap the whole thing up. */ | |
5738 | gfc_add_block_to_block (&block, &loop.pre); | |
5739 | gfc_add_block_to_block (&block, &loop.post); | |
5740 | gfc_cleanup_loop (&loop); | |
5741 | } | |
5742 | ||
5743 | return gfc_finish_block (&block); | |
5744 | } | |
5745 | ||
5746 | ||
5747 | /* Translate the WHERE construct or statement. | |
aa9c57ec | 5748 | This function can be called iteratively to translate the nested WHERE |
6de9cd9a | 5749 | construct or statement. |
3891cee2 | 5750 | MASK is the control mask. */ |
6de9cd9a DN |
5751 | |
5752 | static void | |
011daa76 | 5753 | gfc_trans_where_2 (gfc_code * code, tree mask, bool invert, |
3891cee2 | 5754 | forall_info * nested_forall_info, stmtblock_t * block) |
6de9cd9a | 5755 | { |
3891cee2 RS |
5756 | stmtblock_t inner_size_body; |
5757 | tree inner_size, size; | |
5758 | gfc_ss *lss, *rss; | |
5759 | tree mask_type; | |
6de9cd9a DN |
5760 | gfc_expr *expr1; |
5761 | gfc_expr *expr2; | |
5762 | gfc_code *cblock; | |
5763 | gfc_code *cnext; | |
3891cee2 | 5764 | tree tmp; |
ae772c2d | 5765 | tree cond; |
6de9cd9a | 5766 | tree count1, count2; |
011daa76 RS |
5767 | bool need_cmask; |
5768 | bool need_pmask; | |
6de9cd9a | 5769 | int need_temp; |
3891cee2 RS |
5770 | tree pcmask = NULL_TREE; |
5771 | tree ppmask = NULL_TREE; | |
5772 | tree cmask = NULL_TREE; | |
5773 | tree pmask = NULL_TREE; | |
a00b8d1a | 5774 | gfc_actual_arglist *arg; |
6de9cd9a DN |
5775 | |
5776 | /* the WHERE statement or the WHERE construct statement. */ | |
5777 | cblock = code->block; | |
3891cee2 | 5778 | |
3891cee2 RS |
5779 | /* As the mask array can be very big, prefer compact boolean types. */ |
5780 | mask_type = gfc_get_logical_type (gfc_logical_kinds[0].kind); | |
5781 | ||
011daa76 RS |
5782 | /* Determine which temporary masks are needed. */ |
5783 | if (!cblock->block) | |
90f58ec8 | 5784 | { |
011daa76 RS |
5785 | /* One clause: No ELSEWHEREs. */ |
5786 | need_cmask = (cblock->next != 0); | |
5787 | need_pmask = false; | |
90f58ec8 | 5788 | } |
011daa76 | 5789 | else if (cblock->block->block) |
90f58ec8 | 5790 | { |
011daa76 RS |
5791 | /* Three or more clauses: Conditional ELSEWHEREs. */ |
5792 | need_cmask = true; | |
5793 | need_pmask = true; | |
90f58ec8 | 5794 | } |
011daa76 RS |
5795 | else if (cblock->next) |
5796 | { | |
5797 | /* Two clauses, the first non-empty. */ | |
5798 | need_cmask = true; | |
5799 | need_pmask = (mask != NULL_TREE | |
5800 | && cblock->block->next != 0); | |
5801 | } | |
5802 | else if (!cblock->block->next) | |
3891cee2 | 5803 | { |
011daa76 RS |
5804 | /* Two clauses, both empty. */ |
5805 | need_cmask = false; | |
5806 | need_pmask = false; | |
5807 | } | |
5808 | /* Two clauses, the first empty, the second non-empty. */ | |
5809 | else if (mask) | |
5810 | { | |
a513927a | 5811 | need_cmask = (cblock->block->expr1 != 0); |
011daa76 | 5812 | need_pmask = true; |
3891cee2 RS |
5813 | } |
5814 | else | |
5815 | { | |
011daa76 RS |
5816 | need_cmask = true; |
5817 | need_pmask = false; | |
5818 | } | |
5819 | ||
5820 | if (need_cmask || need_pmask) | |
5821 | { | |
5822 | /* Calculate the size of temporary needed by the mask-expr. */ | |
5823 | gfc_init_block (&inner_size_body); | |
a513927a | 5824 | inner_size = compute_inner_temp_size (cblock->expr1, cblock->expr1, |
011daa76 RS |
5825 | &inner_size_body, &lss, &rss); |
5826 | ||
fcba5509 MM |
5827 | gfc_free_ss_chain (lss); |
5828 | gfc_free_ss_chain (rss); | |
5829 | ||
011daa76 RS |
5830 | /* Calculate the total size of temporary needed. */ |
5831 | size = compute_overall_iter_number (nested_forall_info, inner_size, | |
5832 | &inner_size_body, block); | |
5833 | ||
ae772c2d | 5834 | /* Check whether the size is negative. */ |
63ee5404 | 5835 | cond = fold_build2_loc (input_location, LE_EXPR, logical_type_node, size, |
bc98ed60 TB |
5836 | gfc_index_zero_node); |
5837 | size = fold_build3_loc (input_location, COND_EXPR, gfc_array_index_type, | |
5838 | cond, gfc_index_zero_node, size); | |
ae772c2d PT |
5839 | size = gfc_evaluate_now (size, block); |
5840 | ||
011daa76 RS |
5841 | /* Allocate temporary for WHERE mask if needed. */ |
5842 | if (need_cmask) | |
5843 | cmask = allocate_temp_for_forall_nest_1 (mask_type, size, block, | |
5844 | &pcmask); | |
5845 | ||
5846 | /* Allocate temporary for !mask if needed. */ | |
5847 | if (need_pmask) | |
5848 | pmask = allocate_temp_for_forall_nest_1 (mask_type, size, block, | |
5849 | &ppmask); | |
3891cee2 RS |
5850 | } |
5851 | ||
6de9cd9a DN |
5852 | while (cblock) |
5853 | { | |
011daa76 RS |
5854 | /* Each time around this loop, the where clause is conditional |
5855 | on the value of mask and invert, which are updated at the | |
5856 | bottom of the loop. */ | |
5857 | ||
6de9cd9a | 5858 | /* Has mask-expr. */ |
a513927a | 5859 | if (cblock->expr1) |
6de9cd9a | 5860 | { |
90f58ec8 RS |
5861 | /* Ensure that the WHERE mask will be evaluated exactly once. |
5862 | If there are no statements in this WHERE/ELSEWHERE clause, | |
5863 | then we don't need to update the control mask (cmask). | |
5864 | If this is the last clause of the WHERE construct, then | |
3891cee2 | 5865 | we don't need to update the pending control mask (pmask). */ |
011daa76 | 5866 | if (mask) |
a513927a | 5867 | gfc_evaluate_where_mask (cblock->expr1, nested_forall_info, |
011daa76 RS |
5868 | mask, invert, |
5869 | cblock->next ? cmask : NULL_TREE, | |
5870 | cblock->block ? pmask : NULL_TREE, | |
5871 | mask_type, block); | |
5872 | else | |
a513927a | 5873 | gfc_evaluate_where_mask (cblock->expr1, nested_forall_info, |
011daa76 RS |
5874 | NULL_TREE, false, |
5875 | (cblock->next || cblock->block) | |
5876 | ? cmask : NULL_TREE, | |
5877 | NULL_TREE, mask_type, block); | |
6de9cd9a | 5878 | |
011daa76 | 5879 | invert = false; |
6de9cd9a | 5880 | } |
90f58ec8 | 5881 | /* It's a final elsewhere-stmt. No mask-expr is present. */ |
6de9cd9a | 5882 | else |
3891cee2 | 5883 | cmask = mask; |
6de9cd9a | 5884 | |
011daa76 RS |
5885 | /* The body of this where clause are controlled by cmask with |
5886 | sense specified by invert. */ | |
5887 | ||
6de9cd9a DN |
5888 | /* Get the assignment statement of a WHERE statement, or the first |
5889 | statement in where-body-construct of a WHERE construct. */ | |
5890 | cnext = cblock->next; | |
5891 | while (cnext) | |
5892 | { | |
5893 | switch (cnext->op) | |
5894 | { | |
5895 | /* WHERE assignment statement. */ | |
a00b8d1a PT |
5896 | case EXEC_ASSIGN_CALL: |
5897 | ||
5898 | arg = cnext->ext.actual; | |
5899 | expr1 = expr2 = NULL; | |
5900 | for (; arg; arg = arg->next) | |
5901 | { | |
5902 | if (!arg->expr) | |
5903 | continue; | |
5904 | if (expr1 == NULL) | |
5905 | expr1 = arg->expr; | |
5906 | else | |
5907 | expr2 = arg->expr; | |
5908 | } | |
5909 | goto evaluate; | |
5910 | ||
6de9cd9a | 5911 | case EXEC_ASSIGN: |
a513927a | 5912 | expr1 = cnext->expr1; |
6de9cd9a | 5913 | expr2 = cnext->expr2; |
a00b8d1a | 5914 | evaluate: |
6de9cd9a DN |
5915 | if (nested_forall_info != NULL) |
5916 | { | |
3ded6210 | 5917 | need_temp = gfc_check_dependency (expr1, expr2, 0); |
7bd5dad2 LK |
5918 | if ((need_temp || flag_test_forall_temp) |
5919 | && cnext->op != EXEC_ASSIGN_CALL) | |
011daa76 RS |
5920 | gfc_trans_assign_need_temp (expr1, expr2, |
5921 | cmask, invert, | |
6de9cd9a DN |
5922 | nested_forall_info, block); |
5923 | else | |
5924 | { | |
5925 | /* Variables to control maskexpr. */ | |
5926 | count1 = gfc_create_var (gfc_array_index_type, "count1"); | |
5927 | count2 = gfc_create_var (gfc_array_index_type, "count2"); | |
726a989a RB |
5928 | gfc_add_modify (block, count1, gfc_index_zero_node); |
5929 | gfc_add_modify (block, count2, gfc_index_zero_node); | |
6de9cd9a | 5930 | |
011daa76 RS |
5931 | tmp = gfc_trans_where_assign (expr1, expr2, |
5932 | cmask, invert, | |
a00b8d1a | 5933 | count1, count2, |
eb74e79b | 5934 | cnext); |
8de1f441 | 5935 | |
6de9cd9a | 5936 | tmp = gfc_trans_nested_forall_loop (nested_forall_info, |
bfcabc6c | 5937 | tmp, 1); |
6de9cd9a DN |
5938 | gfc_add_expr_to_block (block, tmp); |
5939 | } | |
5940 | } | |
5941 | else | |
5942 | { | |
5943 | /* Variables to control maskexpr. */ | |
5944 | count1 = gfc_create_var (gfc_array_index_type, "count1"); | |
5945 | count2 = gfc_create_var (gfc_array_index_type, "count2"); | |
726a989a RB |
5946 | gfc_add_modify (block, count1, gfc_index_zero_node); |
5947 | gfc_add_modify (block, count2, gfc_index_zero_node); | |
6de9cd9a | 5948 | |
011daa76 RS |
5949 | tmp = gfc_trans_where_assign (expr1, expr2, |
5950 | cmask, invert, | |
a00b8d1a | 5951 | count1, count2, |
eb74e79b | 5952 | cnext); |
6de9cd9a DN |
5953 | gfc_add_expr_to_block (block, tmp); |
5954 | ||
5955 | } | |
5956 | break; | |
5957 | ||
5958 | /* WHERE or WHERE construct is part of a where-body-construct. */ | |
5959 | case EXEC_WHERE: | |
011daa76 RS |
5960 | gfc_trans_where_2 (cnext, cmask, invert, |
5961 | nested_forall_info, block); | |
3891cee2 | 5962 | break; |
6de9cd9a DN |
5963 | |
5964 | default: | |
6e45f57b | 5965 | gcc_unreachable (); |
6de9cd9a DN |
5966 | } |
5967 | ||
5968 | /* The next statement within the same where-body-construct. */ | |
5969 | cnext = cnext->next; | |
5970 | } | |
5971 | /* The next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt. */ | |
5972 | cblock = cblock->block; | |
011daa76 RS |
5973 | if (mask == NULL_TREE) |
5974 | { | |
5975 | /* If we're the initial WHERE, we can simply invert the sense | |
5976 | of the current mask to obtain the "mask" for the remaining | |
5977 | ELSEWHEREs. */ | |
5978 | invert = true; | |
5979 | mask = cmask; | |
5980 | } | |
5981 | else | |
5982 | { | |
5983 | /* Otherwise, for nested WHERE's we need to use the pending mask. */ | |
5984 | invert = false; | |
5985 | mask = pmask; | |
5986 | } | |
6de9cd9a | 5987 | } |
3891cee2 RS |
5988 | |
5989 | /* If we allocated a pending mask array, deallocate it now. */ | |
5990 | if (ppmask) | |
5991 | { | |
1529b8d9 | 5992 | tmp = gfc_call_free (ppmask); |
3891cee2 RS |
5993 | gfc_add_expr_to_block (block, tmp); |
5994 | } | |
5995 | ||
5996 | /* If we allocated a current mask array, deallocate it now. */ | |
5997 | if (pcmask) | |
5998 | { | |
1529b8d9 | 5999 | tmp = gfc_call_free (pcmask); |
3891cee2 RS |
6000 | gfc_add_expr_to_block (block, tmp); |
6001 | } | |
6de9cd9a DN |
6002 | } |
6003 | ||
3ded6210 RS |
6004 | /* Translate a simple WHERE construct or statement without dependencies. |
6005 | CBLOCK is the "then" clause of the WHERE statement, where CBLOCK->EXPR | |
6006 | is the mask condition, and EBLOCK if non-NULL is the "else" clause. | |
6007 | Currently both CBLOCK and EBLOCK are restricted to single assignments. */ | |
6008 | ||
6009 | static tree | |
6010 | gfc_trans_where_3 (gfc_code * cblock, gfc_code * eblock) | |
6011 | { | |
6012 | stmtblock_t block, body; | |
6013 | gfc_expr *cond, *tdst, *tsrc, *edst, *esrc; | |
6014 | tree tmp, cexpr, tstmt, estmt; | |
6015 | gfc_ss *css, *tdss, *tsss; | |
6016 | gfc_se cse, tdse, tsse, edse, esse; | |
6017 | gfc_loopinfo loop; | |
6018 | gfc_ss *edss = 0; | |
6019 | gfc_ss *esss = 0; | |
57bf3072 | 6020 | bool maybe_workshare = false; |
3ded6210 | 6021 | |
34d01e1d | 6022 | /* Allow the scalarizer to workshare simple where loops. */ |
57bf3072 JJ |
6023 | if ((ompws_flags & (OMPWS_WORKSHARE_FLAG | OMPWS_SCALARIZER_BODY)) |
6024 | == OMPWS_WORKSHARE_FLAG) | |
6025 | { | |
6026 | maybe_workshare = true; | |
6027 | ompws_flags |= OMPWS_SCALARIZER_WS | OMPWS_SCALARIZER_BODY; | |
6028 | } | |
34d01e1d | 6029 | |
a513927a SK |
6030 | cond = cblock->expr1; |
6031 | tdst = cblock->next->expr1; | |
3ded6210 | 6032 | tsrc = cblock->next->expr2; |
a513927a | 6033 | edst = eblock ? eblock->next->expr1 : NULL; |
3ded6210 RS |
6034 | esrc = eblock ? eblock->next->expr2 : NULL; |
6035 | ||
6036 | gfc_start_block (&block); | |
6037 | gfc_init_loopinfo (&loop); | |
6038 | ||
6039 | /* Handle the condition. */ | |
6040 | gfc_init_se (&cse, NULL); | |
6041 | css = gfc_walk_expr (cond); | |
6042 | gfc_add_ss_to_loop (&loop, css); | |
6043 | ||
6044 | /* Handle the then-clause. */ | |
6045 | gfc_init_se (&tdse, NULL); | |
6046 | gfc_init_se (&tsse, NULL); | |
6047 | tdss = gfc_walk_expr (tdst); | |
6048 | tsss = gfc_walk_expr (tsrc); | |
6049 | if (tsss == gfc_ss_terminator) | |
6050 | { | |
26f77530 | 6051 | tsss = gfc_get_scalar_ss (gfc_ss_terminator, tsrc); |
42d0058e | 6052 | tsss->info->where = 1; |
3ded6210 RS |
6053 | } |
6054 | gfc_add_ss_to_loop (&loop, tdss); | |
6055 | gfc_add_ss_to_loop (&loop, tsss); | |
6056 | ||
6057 | if (eblock) | |
6058 | { | |
6059 | /* Handle the else clause. */ | |
6060 | gfc_init_se (&edse, NULL); | |
6061 | gfc_init_se (&esse, NULL); | |
6062 | edss = gfc_walk_expr (edst); | |
6063 | esss = gfc_walk_expr (esrc); | |
6064 | if (esss == gfc_ss_terminator) | |
6065 | { | |
26f77530 | 6066 | esss = gfc_get_scalar_ss (gfc_ss_terminator, esrc); |
42d0058e | 6067 | esss->info->where = 1; |
3ded6210 RS |
6068 | } |
6069 | gfc_add_ss_to_loop (&loop, edss); | |
6070 | gfc_add_ss_to_loop (&loop, esss); | |
6071 | } | |
6072 | ||
6073 | gfc_conv_ss_startstride (&loop); | |
bdfd2ff0 | 6074 | gfc_conv_loop_setup (&loop, &tdst->where); |
3ded6210 RS |
6075 | |
6076 | gfc_mark_ss_chain_used (css, 1); | |
6077 | gfc_mark_ss_chain_used (tdss, 1); | |
6078 | gfc_mark_ss_chain_used (tsss, 1); | |
6079 | if (eblock) | |
6080 | { | |
6081 | gfc_mark_ss_chain_used (edss, 1); | |
6082 | gfc_mark_ss_chain_used (esss, 1); | |
6083 | } | |
6084 | ||
6085 | gfc_start_scalarized_body (&loop, &body); | |
6086 | ||
6087 | gfc_copy_loopinfo_to_se (&cse, &loop); | |
6088 | gfc_copy_loopinfo_to_se (&tdse, &loop); | |
6089 | gfc_copy_loopinfo_to_se (&tsse, &loop); | |
6090 | cse.ss = css; | |
6091 | tdse.ss = tdss; | |
6092 | tsse.ss = tsss; | |
6093 | if (eblock) | |
6094 | { | |
6095 | gfc_copy_loopinfo_to_se (&edse, &loop); | |
6096 | gfc_copy_loopinfo_to_se (&esse, &loop); | |
6097 | edse.ss = edss; | |
6098 | esse.ss = esss; | |
6099 | } | |
6100 | ||
6101 | gfc_conv_expr (&cse, cond); | |
6102 | gfc_add_block_to_block (&body, &cse.pre); | |
6103 | cexpr = cse.expr; | |
6104 | ||
6105 | gfc_conv_expr (&tsse, tsrc); | |
6106 | if (tdss != gfc_ss_terminator && loop.temp_ss != NULL) | |
3db5d687 | 6107 | gfc_conv_tmp_array_ref (&tdse); |
3ded6210 RS |
6108 | else |
6109 | gfc_conv_expr (&tdse, tdst); | |
6110 | ||
6111 | if (eblock) | |
6112 | { | |
6113 | gfc_conv_expr (&esse, esrc); | |
6114 | if (edss != gfc_ss_terminator && loop.temp_ss != NULL) | |
3db5d687 | 6115 | gfc_conv_tmp_array_ref (&edse); |
3ded6210 | 6116 | else |
3db5d687 | 6117 | gfc_conv_expr (&edse, edst); |
3ded6210 RS |
6118 | } |
6119 | ||
ed673c00 MM |
6120 | tstmt = gfc_trans_scalar_assign (&tdse, &tsse, tdst->ts, false, true); |
6121 | estmt = eblock ? gfc_trans_scalar_assign (&edse, &esse, edst->ts, | |
2b56d6a4 | 6122 | false, true) |
c2255bc4 | 6123 | : build_empty_stmt (input_location); |
3ded6210 RS |
6124 | tmp = build3_v (COND_EXPR, cexpr, tstmt, estmt); |
6125 | gfc_add_expr_to_block (&body, tmp); | |
6126 | gfc_add_block_to_block (&body, &cse.post); | |
6127 | ||
57bf3072 JJ |
6128 | if (maybe_workshare) |
6129 | ompws_flags &= ~OMPWS_SCALARIZER_BODY; | |
3ded6210 RS |
6130 | gfc_trans_scalarizing_loops (&loop, &body); |
6131 | gfc_add_block_to_block (&block, &loop.pre); | |
6132 | gfc_add_block_to_block (&block, &loop.post); | |
6133 | gfc_cleanup_loop (&loop); | |
6134 | ||
6135 | return gfc_finish_block (&block); | |
6136 | } | |
6de9cd9a DN |
6137 | |
6138 | /* As the WHERE or WHERE construct statement can be nested, we call | |
6139 | gfc_trans_where_2 to do the translation, and pass the initial | |
f7b529fa | 6140 | NULL values for both the control mask and the pending control mask. */ |
6de9cd9a DN |
6141 | |
6142 | tree | |
6143 | gfc_trans_where (gfc_code * code) | |
6144 | { | |
6145 | stmtblock_t block; | |
3ded6210 RS |
6146 | gfc_code *cblock; |
6147 | gfc_code *eblock; | |
6de9cd9a | 6148 | |
3ded6210 RS |
6149 | cblock = code->block; |
6150 | if (cblock->next | |
6151 | && cblock->next->op == EXEC_ASSIGN | |
6152 | && !cblock->next->next) | |
6153 | { | |
6154 | eblock = cblock->block; | |
6155 | if (!eblock) | |
6156 | { | |
6157 | /* A simple "WHERE (cond) x = y" statement or block is | |
6158 | dependence free if cond is not dependent upon writing x, | |
6159 | and the source y is unaffected by the destination x. */ | |
a513927a SK |
6160 | if (!gfc_check_dependency (cblock->next->expr1, |
6161 | cblock->expr1, 0) | |
6162 | && !gfc_check_dependency (cblock->next->expr1, | |
3ded6210 RS |
6163 | cblock->next->expr2, 0)) |
6164 | return gfc_trans_where_3 (cblock, NULL); | |
6165 | } | |
a513927a | 6166 | else if (!eblock->expr1 |
3ded6210 RS |
6167 | && !eblock->block |
6168 | && eblock->next | |
6169 | && eblock->next->op == EXEC_ASSIGN | |
6170 | && !eblock->next->next) | |
6171 | { | |
6172 | /* A simple "WHERE (cond) x1 = y1 ELSEWHERE x2 = y2 ENDWHERE" | |
6173 | block is dependence free if cond is not dependent on writes | |
6174 | to x1 and x2, y1 is not dependent on writes to x2, and y2 | |
6175 | is not dependent on writes to x1, and both y's are not | |
ae772c2d PT |
6176 | dependent upon their own x's. In addition to this, the |
6177 | final two dependency checks below exclude all but the same | |
6178 | array reference if the where and elswhere destinations | |
6179 | are the same. In short, this is VERY conservative and this | |
6180 | is needed because the two loops, required by the standard | |
6181 | are coalesced in gfc_trans_where_3. */ | |
524af0d6 | 6182 | if (!gfc_check_dependency (cblock->next->expr1, |
a513927a | 6183 | cblock->expr1, 0) |
524af0d6 | 6184 | && !gfc_check_dependency (eblock->next->expr1, |
a513927a | 6185 | cblock->expr1, 0) |
524af0d6 | 6186 | && !gfc_check_dependency (cblock->next->expr1, |
ae772c2d | 6187 | eblock->next->expr2, 1) |
524af0d6 | 6188 | && !gfc_check_dependency (eblock->next->expr1, |
ae772c2d | 6189 | cblock->next->expr2, 1) |
524af0d6 | 6190 | && !gfc_check_dependency (cblock->next->expr1, |
ae772c2d | 6191 | cblock->next->expr2, 1) |
524af0d6 | 6192 | && !gfc_check_dependency (eblock->next->expr1, |
ae772c2d | 6193 | eblock->next->expr2, 1) |
524af0d6 | 6194 | && !gfc_check_dependency (cblock->next->expr1, |
a513927a | 6195 | eblock->next->expr1, 0) |
524af0d6 | 6196 | && !gfc_check_dependency (eblock->next->expr1, |
a513927a | 6197 | cblock->next->expr1, 0)) |
3ded6210 RS |
6198 | return gfc_trans_where_3 (cblock, eblock); |
6199 | } | |
6200 | } | |
6201 | ||
6de9cd9a | 6202 | gfc_start_block (&block); |
6de9cd9a | 6203 | |
011daa76 | 6204 | gfc_trans_where_2 (code, NULL, false, NULL, &block); |
6de9cd9a | 6205 | |
6de9cd9a DN |
6206 | return gfc_finish_block (&block); |
6207 | } | |
6208 | ||
6209 | ||
6210 | /* CYCLE a DO loop. The label decl has already been created by | |
6211 | gfc_trans_do(), it's in TREE_PURPOSE (backend_decl) of the gfc_code | |
6212 | node at the head of the loop. We must mark the label as used. */ | |
6213 | ||
6214 | tree | |
6215 | gfc_trans_cycle (gfc_code * code) | |
6216 | { | |
6217 | tree cycle_label; | |
6218 | ||
e5ca9693 DK |
6219 | cycle_label = code->ext.which_construct->cycle_label; |
6220 | gcc_assert (cycle_label); | |
6221 | ||
6de9cd9a DN |
6222 | TREE_USED (cycle_label) = 1; |
6223 | return build1_v (GOTO_EXPR, cycle_label); | |
6224 | } | |
6225 | ||
6226 | ||
e7dc5b4f | 6227 | /* EXIT a DO loop. Similar to CYCLE, but now the label is in |
6de9cd9a DN |
6228 | TREE_VALUE (backend_decl) of the gfc_code node at the head of the |
6229 | loop. */ | |
6230 | ||
6231 | tree | |
6232 | gfc_trans_exit (gfc_code * code) | |
6233 | { | |
6234 | tree exit_label; | |
6235 | ||
e5ca9693 DK |
6236 | exit_label = code->ext.which_construct->exit_label; |
6237 | gcc_assert (exit_label); | |
6238 | ||
6de9cd9a DN |
6239 | TREE_USED (exit_label) = 1; |
6240 | return build1_v (GOTO_EXPR, exit_label); | |
6241 | } | |
6242 | ||
6243 | ||
cc03bf7a AV |
6244 | /* Get the initializer expression for the code and expr of an allocate. |
6245 | When no initializer is needed return NULL. */ | |
6246 | ||
6247 | static gfc_expr * | |
6248 | allocate_get_initializer (gfc_code * code, gfc_expr * expr) | |
6249 | { | |
6250 | if (!gfc_bt_struct (expr->ts.type) && expr->ts.type != BT_CLASS) | |
6251 | return NULL; | |
6252 | ||
6253 | /* An explicit type was given in allocate ( T:: object). */ | |
6254 | if (code->ext.alloc.ts.type == BT_DERIVED | |
6255 | && (code->ext.alloc.ts.u.derived->attr.alloc_comp | |
6256 | || gfc_has_default_initializer (code->ext.alloc.ts.u.derived))) | |
6257 | return gfc_default_initializer (&code->ext.alloc.ts); | |
6258 | ||
6259 | if (gfc_bt_struct (expr->ts.type) | |
6260 | && (expr->ts.u.derived->attr.alloc_comp | |
6261 | || gfc_has_default_initializer (expr->ts.u.derived))) | |
6262 | return gfc_default_initializer (&expr->ts); | |
6263 | ||
6264 | if (expr->ts.type == BT_CLASS | |
6265 | && (CLASS_DATA (expr)->ts.u.derived->attr.alloc_comp | |
6266 | || gfc_has_default_initializer (CLASS_DATA (expr)->ts.u.derived))) | |
6267 | return gfc_default_initializer (&CLASS_DATA (expr)->ts); | |
6268 | ||
6269 | return NULL; | |
6270 | } | |
6271 | ||
6de9cd9a DN |
6272 | /* Translate the ALLOCATE statement. */ |
6273 | ||
6274 | tree | |
d4b6d147 | 6275 | gfc_trans_allocate (gfc_code * code, gfc_omp_namelist *omp_allocate) |
6de9cd9a DN |
6276 | { |
6277 | gfc_alloc *al; | |
cc03bf7a | 6278 | gfc_expr *expr, *e3rhs = NULL, *init_expr; |
34d9d749 | 6279 | gfc_se se, se_sz; |
6de9cd9a DN |
6280 | tree tmp; |
6281 | tree parm; | |
6de9cd9a | 6282 | tree stat; |
8f992d64 DC |
6283 | tree errmsg; |
6284 | tree errlen; | |
6285 | tree label_errmsg; | |
6286 | tree label_finish; | |
60f5ed26 | 6287 | tree memsz; |
34d9d749 AV |
6288 | tree al_vptr, al_len; |
6289 | /* If an expr3 is present, then store the tree for accessing its | |
6290 | _vptr, and _len components in the variables, respectively. The | |
6291 | element size, i.e. _vptr%size, is stored in expr3_esize. Any of | |
6292 | the trees may be the NULL_TREE indicating that this is not | |
6293 | available for expr3's type. */ | |
6294 | tree expr3, expr3_vptr, expr3_len, expr3_esize; | |
1792349b AV |
6295 | /* Classify what expr3 stores. */ |
6296 | enum { E3_UNSET = 0, E3_SOURCE, E3_MOLD, E3_DESC } e3_is; | |
6de9cd9a | 6297 | stmtblock_t block; |
90cf3ecc | 6298 | stmtblock_t post; |
1312bb90 | 6299 | stmtblock_t final_block; |
4daa71b0 | 6300 | tree nelems; |
525a5e33 AV |
6301 | bool upoly_expr, tmp_expr3_len_flag = false, al_len_needs_set, is_coarray; |
6302 | bool needs_caf_sync, caf_refs_comp; | |
c1525930 | 6303 | bool e3_has_nodescriptor = false; |
db7ffcab | 6304 | gfc_symtree *newsym = NULL; |
525a5e33 | 6305 | symbol_attribute caf_attr; |
5bab4c96 | 6306 | gfc_actual_arglist *param_list; |
6de9cd9a | 6307 | |
cf2b3c22 | 6308 | if (!code->ext.alloc.list) |
6de9cd9a DN |
6309 | return NULL_TREE; |
6310 | ||
34d9d749 AV |
6311 | stat = tmp = memsz = al_vptr = al_len = NULL_TREE; |
6312 | expr3 = expr3_vptr = expr3_len = expr3_esize = NULL_TREE; | |
8f992d64 | 6313 | label_errmsg = label_finish = errmsg = errlen = NULL_TREE; |
1792349b | 6314 | e3_is = E3_UNSET; |
525a5e33 | 6315 | is_coarray = needs_caf_sync = false; |
3759634f | 6316 | |
90cf3ecc PT |
6317 | gfc_init_block (&block); |
6318 | gfc_init_block (&post); | |
1312bb90 | 6319 | gfc_init_block (&final_block); |
6de9cd9a | 6320 | |
8f992d64 DC |
6321 | /* STAT= (and maybe ERRMSG=) is present. */ |
6322 | if (code->expr1) | |
6de9cd9a | 6323 | { |
8f992d64 | 6324 | /* STAT=. */ |
e2cad04b | 6325 | tree gfc_int4_type_node = gfc_get_int_type (4); |
6de9cd9a | 6326 | stat = gfc_create_var (gfc_int4_type_node, "stat"); |
6de9cd9a | 6327 | |
8f992d64 DC |
6328 | /* ERRMSG= only makes sense with STAT=. */ |
6329 | if (code->expr2) | |
6330 | { | |
6331 | gfc_init_se (&se, NULL); | |
5d81ddd0 | 6332 | se.want_pointer = 1; |
8f992d64 | 6333 | gfc_conv_expr_lhs (&se, code->expr2); |
5d81ddd0 TB |
6334 | errmsg = se.expr; |
6335 | errlen = se.string_length; | |
8f992d64 DC |
6336 | } |
6337 | else | |
6338 | { | |
6339 | errmsg = null_pointer_node; | |
6340 | errlen = build_int_cst (gfc_charlen_type_node, 0); | |
6341 | } | |
6342 | ||
6343 | /* GOTO destinations. */ | |
6344 | label_errmsg = gfc_build_label_decl (NULL_TREE); | |
6345 | label_finish = gfc_build_label_decl (NULL_TREE); | |
5d81ddd0 | 6346 | TREE_USED (label_finish) = 0; |
6de9cd9a | 6347 | } |
6de9cd9a | 6348 | |
db7ffcab AV |
6349 | /* When an expr3 is present evaluate it only once. The standards prevent a |
6350 | dependency of expr3 on the objects in the allocate list. An expr3 can | |
6351 | be pre-evaluated in all cases. One just has to make sure, to use the | |
6352 | correct way, i.e., to get the descriptor or to get a reference | |
6353 | expression. */ | |
34d9d749 AV |
6354 | if (code->expr3) |
6355 | { | |
139d4065 AV |
6356 | bool vtab_needed = false, temp_var_needed = false, |
6357 | temp_obj_created = false; | |
ffaf9305 AV |
6358 | |
6359 | is_coarray = gfc_is_coarray (code->expr3); | |
34d9d749 | 6360 | |
1312bb90 PT |
6361 | if (code->expr3->expr_type == EXPR_FUNCTION && !code->expr3->mold |
6362 | && (gfc_is_class_array_function (code->expr3) | |
6363 | || gfc_is_alloc_class_scalar_function (code->expr3))) | |
6364 | code->expr3->must_finalize = 1; | |
6365 | ||
34d9d749 AV |
6366 | /* Figure whether we need the vtab from expr3. */ |
6367 | for (al = code->ext.alloc.list; !vtab_needed && al != NULL; | |
6368 | al = al->next) | |
6369 | vtab_needed = (al->expr->ts.type == BT_CLASS); | |
6370 | ||
1792349b | 6371 | gfc_init_se (&se, NULL); |
80d126ba SK |
6372 | /* When expr3 is a variable, i.e., a very simple expression, then |
6373 | convert it once here. If one has a source expression that has | |
6374 | substring references, part-refs, or %re/%im inquiries, wrap the | |
6375 | entity in parentheses to force evaluation of the expression. */ | |
6376 | if (code->expr3->expr_type == EXPR_VARIABLE | |
6377 | && is_subref_array (code->expr3)) | |
6378 | code->expr3 = gfc_get_parentheses (code->expr3); | |
6379 | ||
db7ffcab AV |
6380 | if (code->expr3->expr_type == EXPR_VARIABLE |
6381 | || code->expr3->expr_type == EXPR_ARRAY | |
6382 | || code->expr3->expr_type == EXPR_CONSTANT) | |
6383 | { | |
6384 | if (!code->expr3->mold | |
6385 | || code->expr3->ts.type == BT_CHARACTER | |
1792349b AV |
6386 | || vtab_needed |
6387 | || code->ext.alloc.arr_spec_from_expr3) | |
34d9d749 | 6388 | { |
1792349b AV |
6389 | /* Convert expr3 to a tree. For all "simple" expression just |
6390 | get the descriptor or the reference, respectively, depending | |
6391 | on the rank of the expr. */ | |
6392 | if (code->ext.alloc.arr_spec_from_expr3 || code->expr3->rank != 0) | |
440f9408 AV |
6393 | gfc_conv_expr_descriptor (&se, code->expr3); |
6394 | else | |
1c645536 AV |
6395 | { |
6396 | gfc_conv_expr_reference (&se, code->expr3); | |
6397 | ||
6398 | /* gfc_conv_expr_reference wraps POINTER_PLUS_EXPR in a | |
6399 | NOP_EXPR, which prevents gfortran from getting the vptr | |
6400 | from the source=-expression. Remove the NOP_EXPR and go | |
6401 | with the POINTER_PLUS_EXPR in this case. */ | |
6402 | if (code->expr3->ts.type == BT_CLASS | |
6403 | && TREE_CODE (se.expr) == NOP_EXPR | |
781d83d9 AV |
6404 | && (TREE_CODE (TREE_OPERAND (se.expr, 0)) |
6405 | == POINTER_PLUS_EXPR | |
6406 | || is_coarray)) | |
1c645536 AV |
6407 | se.expr = TREE_OPERAND (se.expr, 0); |
6408 | } | |
1792349b AV |
6409 | /* Create a temp variable only for component refs to prevent |
6410 | having to go through the full deref-chain each time and to | |
7ebd4a1d | 6411 | simplify computation of array properties. */ |
1792349b | 6412 | temp_var_needed = TREE_CODE (se.expr) == COMPONENT_REF; |
db7ffcab | 6413 | } |
db7ffcab AV |
6414 | } |
6415 | else | |
6416 | { | |
1792349b | 6417 | /* In all other cases evaluate the expr3. */ |
db7ffcab AV |
6418 | symbol_attribute attr; |
6419 | /* Get the descriptor for all arrays, that are not allocatable or | |
b8ac4f3b AV |
6420 | pointer, because the latter are descriptors already. |
6421 | The exception are function calls returning a class object: | |
6422 | The descriptor is stored in their results _data component, which | |
6423 | is easier to access, when first a temporary variable for the | |
6424 | result is created and the descriptor retrieved from there. */ | |
db7ffcab | 6425 | attr = gfc_expr_attr (code->expr3); |
b8ac4f3b AV |
6426 | if (code->expr3->rank != 0 |
6427 | && ((!attr.allocatable && !attr.pointer) | |
6428 | || (code->expr3->expr_type == EXPR_FUNCTION | |
574284e9 AV |
6429 | && (code->expr3->ts.type != BT_CLASS |
6430 | || (code->expr3->value.function.isym | |
6431 | && code->expr3->value.function.isym | |
6432 | ->transformational))))) | |
db7ffcab AV |
6433 | gfc_conv_expr_descriptor (&se, code->expr3); |
6434 | else | |
6435 | gfc_conv_expr_reference (&se, code->expr3); | |
6436 | if (code->expr3->ts.type == BT_CLASS) | |
6437 | gfc_conv_class_to_class (&se, code->expr3, | |
6438 | code->expr3->ts, | |
6439 | false, true, | |
6440 | false, false); | |
139d4065 | 6441 | temp_obj_created = temp_var_needed = !VAR_P (se.expr); |
1792349b AV |
6442 | } |
6443 | gfc_add_block_to_block (&block, &se.pre); | |
1312bb90 | 6444 | if (code->expr3->must_finalize) |
d7caf313 PT |
6445 | { |
6446 | gfc_add_block_to_block (&final_block, &se.finalblock); | |
6447 | gfc_add_block_to_block (&final_block, &se.post); | |
6448 | } | |
1312bb90 PT |
6449 | else |
6450 | gfc_add_block_to_block (&post, &se.post); | |
64e56ab0 AV |
6451 | |
6452 | /* Special case when string in expr3 is zero. */ | |
6453 | if (code->expr3->ts.type == BT_CHARACTER | |
6454 | && integer_zerop (se.string_length)) | |
6455 | { | |
6456 | gfc_init_se (&se, NULL); | |
6457 | temp_var_needed = false; | |
f622221a | 6458 | expr3_len = build_zero_cst (gfc_charlen_type_node); |
64e56ab0 AV |
6459 | e3_is = E3_MOLD; |
6460 | } | |
1792349b AV |
6461 | /* Prevent aliasing, i.e., se.expr may be already a |
6462 | variable declaration. */ | |
64e56ab0 | 6463 | else if (se.expr != NULL_TREE && temp_var_needed) |
1792349b | 6464 | { |
b8ac4f3b | 6465 | tree var, desc; |
781d83d9 | 6466 | tmp = GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se.expr)) || is_coarray ? |
1792349b AV |
6467 | se.expr |
6468 | : build_fold_indirect_ref_loc (input_location, se.expr); | |
b8ac4f3b AV |
6469 | |
6470 | /* Get the array descriptor and prepare it to be assigned to the | |
6471 | temporary variable var. For classes the array descriptor is | |
6472 | in the _data component and the object goes into the | |
6473 | GFC_DECL_SAVED_DESCRIPTOR. */ | |
6474 | if (code->expr3->ts.type == BT_CLASS | |
6475 | && code->expr3->rank != 0) | |
6476 | { | |
6477 | /* When an array_ref was in expr3, then the descriptor is the | |
6478 | first operand. */ | |
781d83d9 | 6479 | if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)) || is_coarray) |
b8ac4f3b AV |
6480 | { |
6481 | desc = TREE_OPERAND (tmp, 0); | |
6482 | } | |
6483 | else | |
6484 | { | |
6485 | desc = tmp; | |
6486 | tmp = gfc_class_data_get (tmp); | |
6487 | } | |
92c5266b AV |
6488 | if (code->ext.alloc.arr_spec_from_expr3) |
6489 | e3_is = E3_DESC; | |
b8ac4f3b AV |
6490 | } |
6491 | else | |
781d83d9 AV |
6492 | desc = !is_coarray ? se.expr |
6493 | : TREE_OPERAND (TREE_OPERAND (se.expr, 0), 0); | |
1792349b AV |
6494 | /* We need a regular (non-UID) symbol here, therefore give a |
6495 | prefix. */ | |
6496 | var = gfc_create_var (TREE_TYPE (tmp), "source"); | |
781d83d9 | 6497 | if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp)) || is_coarray) |
db7ffcab | 6498 | { |
1792349b | 6499 | gfc_allocate_lang_decl (var); |
b8ac4f3b | 6500 | GFC_DECL_SAVED_DESCRIPTOR (var) = desc; |
1792349b AV |
6501 | } |
6502 | gfc_add_modify_loc (input_location, &block, var, tmp); | |
26e46e4b | 6503 | |
1792349b | 6504 | expr3 = var; |
db7ffcab | 6505 | if (se.string_length) |
1792349b | 6506 | /* Evaluate it assuming that it also is complicated like expr3. */ |
db7ffcab | 6507 | expr3_len = gfc_evaluate_now (se.string_length, &block); |
34d9d749 | 6508 | } |
1792349b AV |
6509 | else |
6510 | { | |
6511 | expr3 = se.expr; | |
6512 | expr3_len = se.string_length; | |
6513 | } | |
3cae214f PT |
6514 | |
6515 | /* Deallocate any allocatable components in expressions that use a | |
139d4065 AV |
6516 | temporary object, i.e. are not a simple alias of to an EXPR_VARIABLE. |
6517 | E.g. temporaries of a function call need freeing of their components | |
b0e85485 PT |
6518 | here. Explicit derived type allocation of class entities uses expr3 |
6519 | to carry the default initializer. This must not be deallocated or | |
6520 | finalized. */ | |
3cae214f PT |
6521 | if ((code->expr3->ts.type == BT_DERIVED |
6522 | || code->expr3->ts.type == BT_CLASS) | |
139d4065 | 6523 | && (code->expr3->expr_type != EXPR_VARIABLE || temp_obj_created) |
fd876246 | 6524 | && code->expr3->ts.u.derived->attr.alloc_comp |
b0e85485 PT |
6525 | && !code->expr3->must_finalize |
6526 | && !code->ext.alloc.expr3_not_explicit) | |
3cae214f PT |
6527 | { |
6528 | tmp = gfc_deallocate_alloc_comp (code->expr3->ts.u.derived, | |
6529 | expr3, code->expr3->rank); | |
6530 | gfc_prepend_expr_to_block (&post, tmp); | |
6531 | } | |
6532 | ||
1792349b | 6533 | /* Store what the expr3 is to be used for. */ |
b8ac4f3b AV |
6534 | if (e3_is == E3_UNSET) |
6535 | e3_is = expr3 != NULL_TREE ? | |
6536 | (code->ext.alloc.arr_spec_from_expr3 ? | |
6537 | E3_DESC | |
6538 | : (code->expr3->mold ? E3_MOLD : E3_SOURCE)) | |
6539 | : E3_UNSET; | |
34d9d749 AV |
6540 | |
6541 | /* Figure how to get the _vtab entry. This also obtains the tree | |
6542 | expression for accessing the _len component, because only | |
6543 | unlimited polymorphic objects, which are a subcategory of class | |
6544 | types, have a _len component. */ | |
6545 | if (code->expr3->ts.type == BT_CLASS) | |
6546 | { | |
6547 | gfc_expr *rhs; | |
b8ac4f3b AV |
6548 | tmp = expr3 != NULL_TREE && POINTER_TYPE_P (TREE_TYPE (expr3)) ? |
6549 | build_fold_indirect_ref (expr3): expr3; | |
db7ffcab AV |
6550 | /* Polymorphic SOURCE: VPTR must be determined at run time. |
6551 | expr3 may be a temporary array declaration, therefore check for | |
6552 | GFC_CLASS_TYPE_P before trying to get the _vptr component. */ | |
b8ac4f3b | 6553 | if (tmp != NULL_TREE |
b8ac4f3b AV |
6554 | && (e3_is == E3_DESC |
6555 | || (GFC_CLASS_TYPE_P (TREE_TYPE (tmp)) | |
6556 | && (VAR_P (tmp) || !code->expr3->ref)) | |
6557 | || (VAR_P (tmp) && DECL_LANG_SPECIFIC (tmp)))) | |
34d9d749 | 6558 | tmp = gfc_class_vptr_get (expr3); |
34d9d749 AV |
6559 | else |
6560 | { | |
6561 | rhs = gfc_find_and_cut_at_last_class_ref (code->expr3); | |
6562 | gfc_add_vptr_component (rhs); | |
6563 | gfc_init_se (&se, NULL); | |
6564 | se.want_pointer = 1; | |
6565 | gfc_conv_expr (&se, rhs); | |
6566 | tmp = se.expr; | |
6567 | gfc_free_expr (rhs); | |
6568 | } | |
6569 | /* Set the element size. */ | |
6570 | expr3_esize = gfc_vptr_size_get (tmp); | |
6571 | if (vtab_needed) | |
6572 | expr3_vptr = tmp; | |
6573 | /* Initialize the ref to the _len component. */ | |
6574 | if (expr3_len == NULL_TREE && UNLIMITED_POLY (code->expr3)) | |
6575 | { | |
6576 | /* Same like for retrieving the _vptr. */ | |
6577 | if (expr3 != NULL_TREE && !code->expr3->ref) | |
1792349b | 6578 | expr3_len = gfc_class_len_get (expr3); |
34d9d749 AV |
6579 | else |
6580 | { | |
6581 | rhs = gfc_find_and_cut_at_last_class_ref (code->expr3); | |
6582 | gfc_add_len_component (rhs); | |
6583 | gfc_init_se (&se, NULL); | |
6584 | gfc_conv_expr (&se, rhs); | |
6585 | expr3_len = se.expr; | |
6586 | gfc_free_expr (rhs); | |
6587 | } | |
6588 | } | |
6589 | } | |
6590 | else | |
6591 | { | |
6592 | /* When the object to allocate is polymorphic type, then it | |
6593 | needs its vtab set correctly, so deduce the required _vtab | |
6594 | and _len from the source expression. */ | |
6595 | if (vtab_needed) | |
6596 | { | |
6597 | /* VPTR is fixed at compile time. */ | |
6598 | gfc_symbol *vtab; | |
90cf3ecc | 6599 | |
34d9d749 AV |
6600 | vtab = gfc_find_vtab (&code->expr3->ts); |
6601 | gcc_assert (vtab); | |
6602 | expr3_vptr = gfc_get_symbol_decl (vtab); | |
6603 | expr3_vptr = gfc_build_addr_expr (NULL_TREE, | |
6604 | expr3_vptr); | |
6605 | } | |
6606 | /* _len component needs to be set, when ts is a character | |
6607 | array. */ | |
6608 | if (expr3_len == NULL_TREE | |
6609 | && code->expr3->ts.type == BT_CHARACTER) | |
6610 | { | |
6611 | if (code->expr3->ts.u.cl | |
6612 | && code->expr3->ts.u.cl->length) | |
6613 | { | |
6614 | gfc_init_se (&se, NULL); | |
6615 | gfc_conv_expr (&se, code->expr3->ts.u.cl->length); | |
6616 | gfc_add_block_to_block (&block, &se.pre); | |
6617 | expr3_len = gfc_evaluate_now (se.expr, &block); | |
6618 | } | |
6619 | gcc_assert (expr3_len); | |
6620 | } | |
6621 | /* For character arrays only the kind's size is needed, because | |
6622 | the array mem_size is _len * (elem_size = kind_size). | |
6623 | For all other get the element size in the normal way. */ | |
6624 | if (code->expr3->ts.type == BT_CHARACTER) | |
6625 | expr3_esize = TYPE_SIZE_UNIT ( | |
6626 | gfc_get_char_type (code->expr3->ts.kind)); | |
6627 | else | |
6628 | expr3_esize = TYPE_SIZE_UNIT ( | |
6629 | gfc_typenode_for_spec (&code->expr3->ts)); | |
6630 | } | |
6631 | gcc_assert (expr3_esize); | |
6632 | expr3_esize = fold_convert (sizetype, expr3_esize); | |
1792349b | 6633 | if (e3_is == E3_MOLD) |
64e56ab0 AV |
6634 | /* The expr3 is no longer valid after this point. */ |
6635 | expr3 = NULL_TREE; | |
34d9d749 AV |
6636 | } |
6637 | else if (code->ext.alloc.ts.type != BT_UNKNOWN) | |
6638 | { | |
6639 | /* Compute the explicit typespec given only once for all objects | |
6640 | to allocate. */ | |
6641 | if (code->ext.alloc.ts.type != BT_CHARACTER) | |
6642 | expr3_esize = TYPE_SIZE_UNIT ( | |
6643 | gfc_typenode_for_spec (&code->ext.alloc.ts)); | |
8cd119d8 | 6644 | else if (code->ext.alloc.ts.u.cl->length != NULL) |
34d9d749 AV |
6645 | { |
6646 | gfc_expr *sz; | |
34d9d749 AV |
6647 | sz = gfc_copy_expr (code->ext.alloc.ts.u.cl->length); |
6648 | gfc_init_se (&se_sz, NULL); | |
6649 | gfc_conv_expr (&se_sz, sz); | |
6650 | gfc_free_expr (sz); | |
6651 | tmp = gfc_get_char_type (code->ext.alloc.ts.kind); | |
6652 | tmp = TYPE_SIZE_UNIT (tmp); | |
6653 | tmp = fold_convert (TREE_TYPE (se_sz.expr), tmp); | |
69aaea06 | 6654 | gfc_add_block_to_block (&block, &se_sz.pre); |
34d9d749 AV |
6655 | expr3_esize = fold_build2_loc (input_location, MULT_EXPR, |
6656 | TREE_TYPE (se_sz.expr), | |
6657 | tmp, se_sz.expr); | |
69aaea06 | 6658 | expr3_esize = gfc_evaluate_now (expr3_esize, &block); |
34d9d749 | 6659 | } |
8cd119d8 PT |
6660 | else |
6661 | expr3_esize = NULL_TREE; | |
34d9d749 AV |
6662 | } |
6663 | ||
574284e9 AV |
6664 | /* The routine gfc_trans_assignment () already implements all |
6665 | techniques needed. Unfortunately we may have a temporary | |
6666 | variable for the source= expression here. When that is the | |
6667 | case convert this variable into a temporary gfc_expr of type | |
6668 | EXPR_VARIABLE and used it as rhs for the assignment. The | |
6669 | advantage is, that we get scalarizer support for free, | |
6670 | don't have to take care about scalar to array treatment and | |
6671 | will benefit of every enhancements gfc_trans_assignment () | |
6672 | gets. | |
6673 | No need to check whether e3_is is E3_UNSET, because that is | |
6674 | done by expr3 != NULL_TREE. | |
6675 | Exclude variables since the following block does not handle | |
6676 | array sections. In any case, there is no harm in sending | |
6677 | variables to gfc_trans_assignment because there is no | |
6678 | evaluation of variables. */ | |
6679 | if (code->expr3) | |
6680 | { | |
6681 | if (code->expr3->expr_type != EXPR_VARIABLE | |
6682 | && e3_is != E3_MOLD && expr3 != NULL_TREE | |
6683 | && DECL_P (expr3) && DECL_ARTIFICIAL (expr3)) | |
6684 | { | |
6685 | /* Build a temporary symtree and symbol. Do not add it to the current | |
7ebd4a1d | 6686 | namespace to prevent accidentaly modifying a colliding |
574284e9 AV |
6687 | symbol's as. */ |
6688 | newsym = XCNEW (gfc_symtree); | |
6689 | /* The name of the symtree should be unique, because gfc_create_var () | |
6690 | took care about generating the identifier. */ | |
51f03c6b JJ |
6691 | newsym->name |
6692 | = gfc_get_string ("%s", IDENTIFIER_POINTER (DECL_NAME (expr3))); | |
574284e9 AV |
6693 | newsym->n.sym = gfc_new_symbol (newsym->name, NULL); |
6694 | /* The backend_decl is known. It is expr3, which is inserted | |
6695 | here. */ | |
6696 | newsym->n.sym->backend_decl = expr3; | |
6697 | e3rhs = gfc_get_expr (); | |
6698 | e3rhs->rank = code->expr3->rank; | |
6699 | e3rhs->symtree = newsym; | |
6700 | /* Mark the symbol referenced or gfc_trans_assignment will bug. */ | |
6701 | newsym->n.sym->attr.referenced = 1; | |
6702 | e3rhs->expr_type = EXPR_VARIABLE; | |
6703 | e3rhs->where = code->expr3->where; | |
6704 | /* Set the symbols type, upto it was BT_UNKNOWN. */ | |
6705 | if (IS_CLASS_ARRAY (code->expr3) | |
6706 | && code->expr3->expr_type == EXPR_FUNCTION | |
6707 | && code->expr3->value.function.isym | |
6708 | && code->expr3->value.function.isym->transformational) | |
6709 | { | |
6710 | e3rhs->ts = CLASS_DATA (code->expr3)->ts; | |
6711 | } | |
6712 | else if (code->expr3->ts.type == BT_CLASS | |
6713 | && !GFC_CLASS_TYPE_P (TREE_TYPE (expr3))) | |
6714 | e3rhs->ts = CLASS_DATA (code->expr3)->ts; | |
6715 | else | |
6716 | e3rhs->ts = code->expr3->ts; | |
6717 | newsym->n.sym->ts = e3rhs->ts; | |
6718 | /* Check whether the expr3 is array valued. */ | |
6719 | if (e3rhs->rank) | |
6720 | { | |
6721 | gfc_array_spec *arr; | |
6722 | arr = gfc_get_array_spec (); | |
6723 | arr->rank = e3rhs->rank; | |
6724 | arr->type = AS_DEFERRED; | |
6725 | /* Set the dimension and pointer attribute for arrays | |
6726 | to be on the safe side. */ | |
6727 | newsym->n.sym->attr.dimension = 1; | |
6728 | newsym->n.sym->attr.pointer = 1; | |
6729 | newsym->n.sym->as = arr; | |
6730 | if (IS_CLASS_ARRAY (code->expr3) | |
6731 | && code->expr3->expr_type == EXPR_FUNCTION | |
6732 | && code->expr3->value.function.isym | |
6733 | && code->expr3->value.function.isym->transformational) | |
6734 | { | |
6735 | gfc_array_spec *tarr; | |
6736 | tarr = gfc_get_array_spec (); | |
6737 | *tarr = *arr; | |
6738 | e3rhs->ts.u.derived->as = tarr; | |
6739 | } | |
6740 | gfc_add_full_array_ref (e3rhs, arr); | |
6741 | } | |
6742 | else if (POINTER_TYPE_P (TREE_TYPE (expr3))) | |
6743 | newsym->n.sym->attr.pointer = 1; | |
6744 | /* The string length is known, too. Set it for char arrays. */ | |
6745 | if (e3rhs->ts.type == BT_CHARACTER) | |
6746 | newsym->n.sym->ts.u.cl->backend_decl = expr3_len; | |
6747 | gfc_commit_symbol (newsym->n.sym); | |
6748 | } | |
6749 | else | |
6750 | e3rhs = gfc_copy_expr (code->expr3); | |
c1525930 | 6751 | |
6262e3a2 CLT |
6752 | // We need to propagate the bounds of the expr3 for source=/mold=. |
6753 | // However, for non-named arrays, the lbound has to be 1 and neither the | |
6754 | // bound used inside the called function even when returning an | |
6755 | // allocatable/pointer nor the zero used internally. | |
6756 | if (e3_is == E3_DESC | |
6757 | && code->expr3->expr_type != EXPR_VARIABLE) | |
6758 | e3_has_nodescriptor = true; | |
574284e9 AV |
6759 | } |
6760 | ||
34d9d749 | 6761 | /* Loop over all objects to allocate. */ |
cf2b3c22 | 6762 | for (al = code->ext.alloc.list; al != NULL; al = al->next) |
6de9cd9a | 6763 | { |
f43085aa | 6764 | expr = gfc_copy_expr (al->expr); |
34d9d749 AV |
6765 | /* UNLIMITED_POLY () needs the _data component to be set, when |
6766 | expr is a unlimited polymorphic object. But the _data component | |
6767 | has not been set yet, so check the derived type's attr for the | |
6768 | unlimited polymorphic flag to be safe. */ | |
6769 | upoly_expr = UNLIMITED_POLY (expr) | |
6770 | || (expr->ts.type == BT_DERIVED | |
6771 | && expr->ts.u.derived->attr.unlimited_polymorphic); | |
6772 | gfc_init_se (&se, NULL); | |
f43085aa | 6773 | |
34d9d749 AV |
6774 | /* For class types prepare the expressions to ref the _vptr |
6775 | and the _len component. The latter for unlimited polymorphic | |
6776 | types only. */ | |
f43085aa | 6777 | if (expr->ts.type == BT_CLASS) |
34d9d749 AV |
6778 | { |
6779 | gfc_expr *expr_ref_vptr, *expr_ref_len; | |
6780 | gfc_add_data_component (expr); | |
6781 | /* Prep the vptr handle. */ | |
6782 | expr_ref_vptr = gfc_copy_expr (al->expr); | |
6783 | gfc_add_vptr_component (expr_ref_vptr); | |
6784 | se.want_pointer = 1; | |
6785 | gfc_conv_expr (&se, expr_ref_vptr); | |
6786 | al_vptr = se.expr; | |
6787 | se.want_pointer = 0; | |
6788 | gfc_free_expr (expr_ref_vptr); | |
6789 | /* Allocated unlimited polymorphic objects always have a _len | |
6790 | component. */ | |
6791 | if (upoly_expr) | |
6792 | { | |
6793 | expr_ref_len = gfc_copy_expr (al->expr); | |
6794 | gfc_add_len_component (expr_ref_len); | |
6795 | gfc_conv_expr (&se, expr_ref_len); | |
6796 | al_len = se.expr; | |
6797 | gfc_free_expr (expr_ref_len); | |
6798 | } | |
6799 | else | |
6800 | /* In a loop ensure that all loop variable dependent variables | |
6801 | are initialized at the same spot in all execution paths. */ | |
6802 | al_len = NULL_TREE; | |
6803 | } | |
6804 | else | |
6805 | al_vptr = al_len = NULL_TREE; | |
6de9cd9a DN |
6806 | |
6807 | se.want_pointer = 1; | |
6808 | se.descriptor_only = 1; | |
78ab5260 | 6809 | |
6de9cd9a | 6810 | gfc_conv_expr (&se, expr); |
34d9d749 AV |
6811 | if (expr->ts.type == BT_CHARACTER && expr->ts.deferred) |
6812 | /* se.string_length now stores the .string_length variable of expr | |
6813 | needed to allocate character(len=:) arrays. */ | |
6814 | al_len = se.string_length; | |
6815 | ||
6816 | al_len_needs_set = al_len != NULL_TREE; | |
67914693 | 6817 | /* When allocating an array one cannot use much of the |
34d9d749 AV |
6818 | pre-evaluated expr3 expressions, because for most of them the |
6819 | scalarizer is needed which is not available in the pre-evaluation | |
6820 | step. Therefore gfc_array_allocate () is responsible (and able) | |
6821 | to handle the complete array allocation. Only the element size | |
6822 | needs to be provided, which is done most of the time by the | |
6823 | pre-evaluation step. */ | |
4daa71b0 | 6824 | nelems = NULL_TREE; |
764d5c7b AV |
6825 | if (expr3_len && (code->expr3->ts.type == BT_CHARACTER |
6826 | || code->expr3->ts.type == BT_CLASS)) | |
6827 | { | |
6828 | /* When al is an array, then the element size for each element | |
6829 | in the array is needed, which is the product of the len and | |
6830 | esize for char arrays. For unlimited polymorphics len can be | |
6831 | zero, therefore take the maximum of len and one. */ | |
48024a99 HA |
6832 | tree lhs_len; |
6833 | ||
6834 | /* If an allocatable character variable has fixed length, use it. | |
6835 | Otherwise use source length. As different lengths are not | |
6836 | allowed by the standard, generate a runtime check. */ | |
6837 | if (expr->ts.type == BT_CHARACTER && !expr->ts.deferred) | |
6838 | { | |
6839 | gfc_trans_same_strlen_check ("ALLOCATE with SOURCE= or MOLD=", | |
6840 | &code->expr3->where, | |
6841 | se.string_length, expr3_len, | |
6842 | &block); | |
6843 | lhs_len = fold_convert (TREE_TYPE (expr3_len), se.string_length); | |
6844 | } | |
6845 | else | |
6846 | lhs_len = expr3_len; | |
6847 | ||
764d5c7b AV |
6848 | tmp = fold_build2_loc (input_location, MAX_EXPR, |
6849 | TREE_TYPE (expr3_len), | |
48024a99 HA |
6850 | lhs_len, fold_convert (TREE_TYPE (expr3_len), |
6851 | integer_one_node)); | |
764d5c7b AV |
6852 | tmp = fold_build2_loc (input_location, MULT_EXPR, |
6853 | TREE_TYPE (expr3_esize), expr3_esize, | |
6854 | fold_convert (TREE_TYPE (expr3_esize), tmp)); | |
6855 | } | |
34d9d749 AV |
6856 | else |
6857 | tmp = expr3_esize; | |
c1525930 | 6858 | |
d4b6d147 TB |
6859 | gfc_omp_namelist *omp_alloc_item = NULL; |
6860 | if (omp_allocate) | |
6861 | { | |
6862 | gfc_omp_namelist *n = NULL; | |
6863 | gfc_omp_namelist *n_null = NULL; | |
6864 | for (n = omp_allocate; n; n = n->next) | |
6865 | { | |
6866 | if (n->sym == NULL) | |
6867 | { | |
6868 | n_null = n; | |
6869 | continue; | |
6870 | } | |
6871 | if (expr->expr_type == EXPR_VARIABLE | |
6872 | && expr->symtree->n.sym == n->sym) | |
6873 | { | |
6874 | gfc_ref *ref; | |
6875 | for (ref = expr->ref; ref; ref = ref->next) | |
6876 | if (ref->type == REF_COMPONENT) | |
6877 | break; | |
6878 | if (ref == NULL) | |
6879 | break; | |
6880 | } | |
6881 | } | |
6882 | omp_alloc_item = n ? n : n_null; | |
6883 | ||
6884 | } | |
6885 | ||
34d9d749 | 6886 | if (!gfc_array_allocate (&se, expr, stat, errmsg, errlen, |
1792349b AV |
6887 | label_finish, tmp, &nelems, |
6888 | e3rhs ? e3rhs : code->expr3, | |
6889 | e3_is == E3_DESC ? expr3 : NULL_TREE, | |
d4b6d147 | 6890 | e3_has_nodescriptor, omp_alloc_item)) |
6de9cd9a | 6891 | { |
34d9d749 AV |
6892 | /* A scalar or derived type. First compute the size to |
6893 | allocate. | |
cf2b3c22 | 6894 | |
34d9d749 | 6895 | expr3_len is set when expr3 is an unlimited polymorphic |
48024a99 HA |
6896 | object or a deferred length string. |
6897 | ||
6898 | If an allocatable character variable has fixed length, use it. | |
6899 | Otherwise use source length. As different lengths are not | |
6900 | allowed by the standard, a runtime check was inserted | |
6901 | above. */ | |
34d9d749 | 6902 | if (expr3_len != NULL_TREE) |
8d51f26f | 6903 | { |
48024a99 HA |
6904 | tree lhs_len; |
6905 | if (expr->ts.type == BT_CHARACTER && !expr->ts.deferred) | |
6906 | lhs_len = fold_convert (TREE_TYPE (expr3_len), | |
6907 | se.string_length); | |
6908 | else | |
6909 | lhs_len = expr3_len; | |
6910 | ||
6911 | tmp = fold_convert (TREE_TYPE (expr3_esize), lhs_len); | |
34d9d749 AV |
6912 | tmp = fold_build2_loc (input_location, MULT_EXPR, |
6913 | TREE_TYPE (expr3_esize), | |
6914 | expr3_esize, tmp); | |
6915 | if (code->expr3->ts.type != BT_CLASS) | |
6916 | /* expr3 is a deferred length string, i.e., we are | |
6917 | done. */ | |
6918 | memsz = tmp; | |
8d51f26f | 6919 | else |
5b384b3d | 6920 | { |
34d9d749 AV |
6921 | /* For unlimited polymorphic enties build |
6922 | (len > 0) ? element_size * len : element_size | |
6923 | to compute the number of bytes to allocate. | |
6924 | This allows the allocation of unlimited polymorphic | |
6925 | objects from an expr3 that is also unlimited | |
6926 | polymorphic and stores a _len dependent object, | |
6927 | e.g., a string. */ | |
6928 | memsz = fold_build2_loc (input_location, GT_EXPR, | |
63ee5404 | 6929 | logical_type_node, expr3_len, |
f622221a JB |
6930 | build_zero_cst |
6931 | (TREE_TYPE (expr3_len))); | |
34d9d749 AV |
6932 | memsz = fold_build3_loc (input_location, COND_EXPR, |
6933 | TREE_TYPE (expr3_esize), | |
6934 | memsz, tmp, expr3_esize); | |
5b384b3d | 6935 | } |
8d51f26f | 6936 | } |
34d9d749 AV |
6937 | else if (expr3_esize != NULL_TREE) |
6938 | /* Any other object in expr3 just needs element size in | |
6939 | bytes. */ | |
6940 | memsz = expr3_esize; | |
6941 | else if ((expr->ts.type == BT_CHARACTER && expr->ts.deferred) | |
6942 | || (upoly_expr | |
6943 | && code->ext.alloc.ts.type == BT_CHARACTER)) | |
2573aab9 | 6944 | { |
34d9d749 AV |
6945 | /* Allocating deferred length char arrays need the length |
6946 | to allocate in the alloc_type_spec. But also unlimited | |
6947 | polymorphic objects may be allocated as char arrays. | |
6948 | Both are handled here. */ | |
2573aab9 TB |
6949 | gfc_init_se (&se_sz, NULL); |
6950 | gfc_conv_expr (&se_sz, code->ext.alloc.ts.u.cl->length); | |
6951 | gfc_add_block_to_block (&se.pre, &se_sz.pre); | |
6952 | se_sz.expr = gfc_evaluate_now (se_sz.expr, &se.pre); | |
6953 | gfc_add_block_to_block (&se.pre, &se_sz.post); | |
34d9d749 AV |
6954 | expr3_len = se_sz.expr; |
6955 | tmp_expr3_len_flag = true; | |
6956 | tmp = TYPE_SIZE_UNIT ( | |
6957 | gfc_get_char_type (code->ext.alloc.ts.kind)); | |
2573aab9 | 6958 | memsz = fold_build2_loc (input_location, MULT_EXPR, |
34d9d749 AV |
6959 | TREE_TYPE (tmp), |
6960 | fold_convert (TREE_TYPE (tmp), | |
6961 | expr3_len), | |
6962 | tmp); | |
2573aab9 | 6963 | } |
34d9d749 | 6964 | else if (expr->ts.type == BT_CHARACTER) |
8d51f26f | 6965 | { |
34d9d749 AV |
6966 | /* Compute the number of bytes needed to allocate a fixed |
6967 | length char array. */ | |
6968 | gcc_assert (se.string_length != NULL_TREE); | |
6969 | tmp = TYPE_SIZE_UNIT (gfc_get_char_type (expr->ts.kind)); | |
8d51f26f PT |
6970 | memsz = fold_build2_loc (input_location, MULT_EXPR, |
6971 | TREE_TYPE (tmp), tmp, | |
34d9d749 AV |
6972 | fold_convert (TREE_TYPE (tmp), |
6973 | se.string_length)); | |
8d51f26f | 6974 | } |
34d9d749 AV |
6975 | else if (code->ext.alloc.ts.type != BT_UNKNOWN) |
6976 | /* Handle all types, where the alloc_type_spec is set. */ | |
6977 | memsz = TYPE_SIZE_UNIT (gfc_typenode_for_spec (&code->ext.alloc.ts)); | |
6978 | else | |
6979 | /* Handle size computation of the type declared to alloc. */ | |
6f3d1a5e | 6980 | memsz = TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (se.expr))); |
90cf3ecc | 6981 | |
d4b6d147 TB |
6982 | bool use_coarray_alloc |
6983 | = (flag_coarray == GFC_FCOARRAY_LIB | |
6984 | && (caf_attr = gfc_caf_attr (expr, true, &caf_refs_comp)) | |
6985 | .codimension); | |
6986 | tree omp_cond = NULL_TREE; | |
6987 | tree omp_alt_alloc = NULL_TREE; | |
6988 | tree succ_add_expr = NULL_TREE; | |
6989 | if (!use_coarray_alloc && omp_alloc_item) | |
6990 | { | |
6991 | tree align, alloc, sz; | |
6992 | gfc_se se2; | |
6993 | ||
6994 | omp_cond = boolean_true_node; | |
6995 | if (omp_alloc_item->u2.allocator) | |
6996 | { | |
6997 | gfc_init_se (&se2, NULL); | |
6998 | gfc_conv_expr (&se2, omp_alloc_item->u2.allocator); | |
6999 | gfc_add_block_to_block (&se.pre, &se2.pre); | |
7000 | alloc = gfc_evaluate_now (se2.expr, &se.pre); | |
7001 | gfc_add_block_to_block (&se.pre, &se2.post); | |
7002 | } | |
7003 | else | |
7004 | alloc = build_zero_cst (ptr_type_node); | |
7005 | tmp = TREE_TYPE (TREE_TYPE (se.expr)); | |
7006 | if (tmp == void_type_node) | |
7007 | tmp = gfc_typenode_for_spec (&expr->ts, 0); | |
7008 | if (omp_alloc_item->u.align) | |
7009 | { | |
7010 | gfc_init_se (&se2, NULL); | |
7011 | gfc_conv_expr (&se2, omp_alloc_item->u.align); | |
7012 | gcc_assert (CONSTANT_CLASS_P (se2.expr) | |
7013 | && se2.pre.head == NULL | |
7014 | && se2.post.head == NULL); | |
7015 | align = build_int_cst (size_type_node, | |
7016 | MAX (tree_to_uhwi (se2.expr), | |
7017 | TYPE_ALIGN_UNIT (tmp))); | |
7018 | } | |
7019 | else | |
7020 | align = build_int_cst (size_type_node, TYPE_ALIGN_UNIT (tmp)); | |
7021 | sz = fold_build2_loc (input_location, MAX_EXPR, size_type_node, | |
7022 | fold_convert (size_type_node, memsz), | |
7023 | build_int_cst (size_type_node, 1)); | |
7024 | omp_alt_alloc = builtin_decl_explicit (BUILT_IN_GOMP_ALLOC); | |
7025 | DECL_ATTRIBUTES (omp_alt_alloc) | |
7026 | = tree_cons (get_identifier ("omp allocator"), | |
7027 | build_tree_list (NULL_TREE, alloc), | |
7028 | DECL_ATTRIBUTES (omp_alt_alloc)); | |
7029 | omp_alt_alloc = build_call_expr (omp_alt_alloc, 3, align, sz, alloc); | |
7030 | succ_add_expr = gfc_omp_call_add_alloc (se.expr); | |
7031 | } | |
7032 | ||
525a5e33 | 7033 | /* Store the caf-attributes for latter use. */ |
d4b6d147 | 7034 | if (use_coarray_alloc) |
3c9f5092 AV |
7035 | { |
7036 | /* Scalar allocatable components in coarray'ed derived types make | |
7037 | it here and are treated now. */ | |
7038 | tree caf_decl, token; | |
7039 | gfc_se caf_se; | |
7040 | ||
ffaf9305 | 7041 | is_coarray = true; |
525a5e33 AV |
7042 | /* Set flag, to add synchronize after the allocate. */ |
7043 | needs_caf_sync = needs_caf_sync | |
7044 | || caf_attr.coarray_comp || !caf_refs_comp; | |
ffaf9305 | 7045 | |
3c9f5092 AV |
7046 | gfc_init_se (&caf_se, NULL); |
7047 | ||
7048 | caf_decl = gfc_get_tree_for_caf_expr (expr); | |
7049 | gfc_get_caf_token_offset (&caf_se, &token, NULL, caf_decl, | |
7050 | NULL_TREE, NULL); | |
7051 | gfc_add_block_to_block (&se.pre, &caf_se.pre); | |
7052 | gfc_allocate_allocatable (&se.pre, se.expr, memsz, | |
7053 | gfc_build_addr_expr (NULL_TREE, token), | |
7054 | NULL_TREE, NULL_TREE, NULL_TREE, | |
7055 | label_finish, expr, 1); | |
7056 | } | |
5b130807 | 7057 | /* Allocate - for non-pointers with re-alloc checking. */ |
3c9f5092 AV |
7058 | else if (gfc_expr_attr (expr).allocatable) |
7059 | gfc_allocate_allocatable (&se.pre, se.expr, memsz, | |
7060 | NULL_TREE, stat, errmsg, errlen, | |
d4b6d147 TB |
7061 | label_finish, expr, 0, |
7062 | omp_cond, omp_alt_alloc, succ_add_expr); | |
90cf3ecc | 7063 | else |
d4b6d147 TB |
7064 | gfc_allocate_using_malloc (&se.pre, se.expr, memsz, stat, |
7065 | omp_cond, omp_alt_alloc, succ_add_expr); | |
6de9cd9a | 7066 | } |
34d9d749 AV |
7067 | else |
7068 | { | |
ffaf9305 AV |
7069 | /* Allocating coarrays needs a sync after the allocate executed. |
7070 | Set the flag to add the sync after all objects are allocated. */ | |
525a5e33 AV |
7071 | if (flag_coarray == GFC_FCOARRAY_LIB |
7072 | && (caf_attr = gfc_caf_attr (expr, true, &caf_refs_comp)) | |
7073 | .codimension) | |
7074 | { | |
7075 | is_coarray = true; | |
7076 | needs_caf_sync = needs_caf_sync | |
7077 | || caf_attr.coarray_comp || !caf_refs_comp; | |
7078 | } | |
ffaf9305 | 7079 | |
34d9d749 AV |
7080 | if (expr->ts.type == BT_CHARACTER && al_len != NULL_TREE |
7081 | && expr3_len != NULL_TREE) | |
7082 | { | |
7083 | /* Arrays need to have a _len set before the array | |
7084 | descriptor is filled. */ | |
7085 | gfc_add_modify (&block, al_len, | |
7086 | fold_convert (TREE_TYPE (al_len), expr3_len)); | |
7087 | /* Prevent setting the length twice. */ | |
7088 | al_len_needs_set = false; | |
7089 | } | |
afbc5ae8 | 7090 | else if (expr->ts.type == BT_CHARACTER && al_len != NULL_TREE |
323c5722 | 7091 | && code->ext.alloc.ts.u.cl->length) |
afbc5ae8 PT |
7092 | { |
7093 | /* Cover the cases where a string length is explicitly | |
7094 | specified by a type spec for deferred length character | |
7095 | arrays or unlimited polymorphic objects without a | |
7096 | source= or mold= expression. */ | |
7097 | gfc_init_se (&se_sz, NULL); | |
7098 | gfc_conv_expr (&se_sz, code->ext.alloc.ts.u.cl->length); | |
69aaea06 | 7099 | gfc_add_block_to_block (&block, &se_sz.pre); |
afbc5ae8 PT |
7100 | gfc_add_modify (&block, al_len, |
7101 | fold_convert (TREE_TYPE (al_len), | |
7102 | se_sz.expr)); | |
7103 | al_len_needs_set = false; | |
7104 | } | |
34d9d749 | 7105 | } |
6de9cd9a | 7106 | |
90cf3ecc | 7107 | gfc_add_block_to_block (&block, &se.pre); |
cf2b3c22 | 7108 | |
8f992d64 DC |
7109 | /* Error checking -- Note: ERRMSG only makes sense with STAT. */ |
7110 | if (code->expr1) | |
7111 | { | |
5d81ddd0 | 7112 | tmp = build1_v (GOTO_EXPR, label_errmsg); |
8f992d64 | 7113 | parm = fold_build2_loc (input_location, NE_EXPR, |
63ee5404 | 7114 | logical_type_node, stat, |
8f992d64 DC |
7115 | build_int_cst (TREE_TYPE (stat), 0)); |
7116 | tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, | |
ed9c79e1 JJ |
7117 | gfc_unlikely (parm, PRED_FORTRAN_FAIL_ALLOC), |
7118 | tmp, build_empty_stmt (input_location)); | |
8f992d64 DC |
7119 | gfc_add_expr_to_block (&block, tmp); |
7120 | } | |
8b704316 | 7121 | |
574284e9 AV |
7122 | /* Set the vptr only when no source= is set. When source= is set, then |
7123 | the trans_assignment below will set the vptr. */ | |
7124 | if (al_vptr != NULL_TREE && (!code->expr3 || code->expr3->mold)) | |
c49ea23d | 7125 | { |
34d9d749 AV |
7126 | if (expr3_vptr != NULL_TREE) |
7127 | /* The vtab is already known, so just assign it. */ | |
7128 | gfc_add_modify (&block, al_vptr, | |
7129 | fold_convert (TREE_TYPE (al_vptr), expr3_vptr)); | |
c49ea23d PT |
7130 | else |
7131 | { | |
7132 | /* VPTR is fixed at compile time. */ | |
7133 | gfc_symbol *vtab; | |
7134 | gfc_typespec *ts; | |
34d9d749 | 7135 | |
c49ea23d | 7136 | if (code->expr3) |
34d9d749 AV |
7137 | /* Although expr3 is pre-evaluated above, it may happen, |
7138 | that for arrays or in mold= cases the pre-evaluation | |
7139 | was not successful. In these rare cases take the vtab | |
7140 | from the typespec of expr3 here. */ | |
c49ea23d | 7141 | ts = &code->expr3->ts; |
34d9d749 AV |
7142 | else if (code->ext.alloc.ts.type == BT_DERIVED || upoly_expr) |
7143 | /* The alloc_type_spec gives the type to allocate or the | |
7144 | al is unlimited polymorphic, which enforces the use of | |
7145 | an alloc_type_spec that is not necessarily a BT_DERIVED. */ | |
c49ea23d | 7146 | ts = &code->ext.alloc.ts; |
c49ea23d | 7147 | else |
34d9d749 AV |
7148 | /* Prepare for setting the vtab as declared. */ |
7149 | ts = &expr->ts; | |
7150 | ||
7151 | vtab = gfc_find_vtab (ts); | |
7152 | gcc_assert (vtab); | |
7153 | tmp = gfc_build_addr_expr (NULL_TREE, | |
7154 | gfc_get_symbol_decl (vtab)); | |
7155 | gfc_add_modify (&block, al_vptr, | |
7156 | fold_convert (TREE_TYPE (al_vptr), tmp)); | |
c49ea23d | 7157 | } |
c49ea23d PT |
7158 | } |
7159 | ||
34d9d749 AV |
7160 | /* Add assignment for string length. */ |
7161 | if (al_len != NULL_TREE && al_len_needs_set) | |
7162 | { | |
7163 | if (expr3_len != NULL_TREE) | |
7164 | { | |
7165 | gfc_add_modify (&block, al_len, | |
7166 | fold_convert (TREE_TYPE (al_len), | |
7167 | expr3_len)); | |
7168 | /* When tmp_expr3_len_flag is set, then expr3_len is | |
7169 | abused to carry the length information from the | |
7170 | alloc_type. Clear it to prevent setting incorrect len | |
7171 | information in future loop iterations. */ | |
7172 | if (tmp_expr3_len_flag) | |
7173 | /* No need to reset tmp_expr3_len_flag, because the | |
67914693 | 7174 | presence of an expr3 cannot change within in the |
34d9d749 AV |
7175 | loop. */ |
7176 | expr3_len = NULL_TREE; | |
7177 | } | |
7178 | else if (code->ext.alloc.ts.type == BT_CHARACTER | |
323c5722 | 7179 | && code->ext.alloc.ts.u.cl->length) |
34d9d749 AV |
7180 | { |
7181 | /* Cover the cases where a string length is explicitly | |
7182 | specified by a type spec for deferred length character | |
7183 | arrays or unlimited polymorphic objects without a | |
7184 | source= or mold= expression. */ | |
69aaea06 AV |
7185 | if (expr3_esize == NULL_TREE || code->ext.alloc.ts.kind != 1) |
7186 | { | |
7187 | gfc_init_se (&se_sz, NULL); | |
7188 | gfc_conv_expr (&se_sz, code->ext.alloc.ts.u.cl->length); | |
7189 | gfc_add_block_to_block (&block, &se_sz.pre); | |
7190 | gfc_add_modify (&block, al_len, | |
7191 | fold_convert (TREE_TYPE (al_len), | |
7192 | se_sz.expr)); | |
7193 | } | |
7194 | else | |
7195 | gfc_add_modify (&block, al_len, | |
7196 | fold_convert (TREE_TYPE (al_len), | |
7197 | expr3_esize)); | |
34d9d749 AV |
7198 | } |
7199 | else | |
7200 | /* No length information needed, because type to allocate | |
7201 | has no length. Set _len to 0. */ | |
7202 | gfc_add_modify (&block, al_len, | |
7203 | fold_convert (TREE_TYPE (al_len), | |
7204 | integer_zero_node)); | |
7205 | } | |
cc03bf7a AV |
7206 | |
7207 | init_expr = NULL; | |
64e56ab0 | 7208 | if (code->expr3 && !code->expr3->mold && e3_is != E3_MOLD) |
cf2b3c22 | 7209 | { |
db7ffcab | 7210 | /* Initialization via SOURCE block (or static default initializer). |
574284e9 AV |
7211 | Switch off automatic reallocation since we have just done the |
7212 | ALLOCATE. */ | |
7213 | int realloc_lhs = flag_realloc_lhs; | |
7214 | gfc_expr *init_expr = gfc_expr_to_initialize (expr); | |
7215 | gfc_expr *rhs = e3rhs ? e3rhs : gfc_copy_expr (code->expr3); | |
7216 | flag_realloc_lhs = 0; | |
d7caf313 PT |
7217 | |
7218 | /* Set the symbol to be artificial so that the result is not finalized. */ | |
7219 | init_expr->symtree->n.sym->attr.artificial = 1; | |
21ced277 | 7220 | tmp = gfc_trans_assignment (init_expr, rhs, true, false, true, |
574284e9 | 7221 | false); |
d7caf313 PT |
7222 | init_expr->symtree->n.sym->attr.artificial = 0; |
7223 | ||
574284e9 AV |
7224 | flag_realloc_lhs = realloc_lhs; |
7225 | /* Free the expression allocated for init_expr. */ | |
7226 | gfc_free_expr (init_expr); | |
7227 | if (rhs != e3rhs) | |
7228 | gfc_free_expr (rhs); | |
f43085aa JW |
7229 | gfc_add_expr_to_block (&block, tmp); |
7230 | } | |
5bab4c96 PT |
7231 | /* Set KIND and LEN PDT components and allocate those that are |
7232 | parameterized. */ | |
7233 | else if (expr->ts.type == BT_DERIVED | |
7234 | && expr->ts.u.derived->attr.pdt_type) | |
7235 | { | |
7236 | if (code->expr3 && code->expr3->param_list) | |
7237 | param_list = code->expr3->param_list; | |
7238 | else if (expr->param_list) | |
7239 | param_list = expr->param_list; | |
7240 | else | |
7241 | param_list = expr->symtree->n.sym->param_list; | |
7242 | tmp = gfc_allocate_pdt_comp (expr->ts.u.derived, se.expr, | |
7243 | expr->rank, param_list); | |
7244 | gfc_add_expr_to_block (&block, tmp); | |
7245 | } | |
7246 | /* Ditto for CLASS expressions. */ | |
7247 | else if (expr->ts.type == BT_CLASS | |
7248 | && CLASS_DATA (expr)->ts.u.derived->attr.pdt_type) | |
7249 | { | |
7250 | if (code->expr3 && code->expr3->param_list) | |
7251 | param_list = code->expr3->param_list; | |
7252 | else if (expr->param_list) | |
7253 | param_list = expr->param_list; | |
7254 | else | |
7255 | param_list = expr->symtree->n.sym->param_list; | |
7256 | tmp = gfc_allocate_pdt_comp (CLASS_DATA (expr)->ts.u.derived, | |
7257 | se.expr, expr->rank, param_list); | |
7258 | gfc_add_expr_to_block (&block, tmp); | |
7259 | } | |
574284e9 AV |
7260 | else if (code->expr3 && code->expr3->mold |
7261 | && code->expr3->ts.type == BT_CLASS) | |
50f30801 | 7262 | { |
574284e9 AV |
7263 | /* Use class_init_assign to initialize expr. */ |
7264 | gfc_code *ini; | |
7265 | ini = gfc_get_code (EXEC_INIT_ASSIGN); | |
4afe8252 | 7266 | ini->expr1 = gfc_find_and_cut_at_last_class_ref (expr, true); |
574284e9 AV |
7267 | tmp = gfc_trans_class_init_assign (ini); |
7268 | gfc_free_statements (ini); | |
b6ff8128 | 7269 | gfc_add_expr_to_block (&block, tmp); |
50f30801 | 7270 | } |
cc03bf7a AV |
7271 | else if ((init_expr = allocate_get_initializer (code, expr))) |
7272 | { | |
7273 | /* Use class_init_assign to initialize expr. */ | |
7274 | gfc_code *ini; | |
7275 | int realloc_lhs = flag_realloc_lhs; | |
7276 | ini = gfc_get_code (EXEC_INIT_ASSIGN); | |
7277 | ini->expr1 = gfc_expr_to_initialize (expr); | |
7278 | ini->expr2 = init_expr; | |
7279 | flag_realloc_lhs = 0; | |
7280 | tmp= gfc_trans_init_assign (ini); | |
7281 | flag_realloc_lhs = realloc_lhs; | |
7282 | gfc_free_statements (ini); | |
7283 | /* Init_expr is freeed by above free_statements, just need to null | |
7284 | it here. */ | |
7285 | init_expr = NULL; | |
7286 | gfc_add_expr_to_block (&block, tmp); | |
7287 | } | |
f43085aa | 7288 | |
de91486c AV |
7289 | /* Nullify all pointers in derived type coarrays. This registers a |
7290 | token for them which allows their allocation. */ | |
7291 | if (is_coarray) | |
7292 | { | |
7293 | gfc_symbol *type = NULL; | |
7294 | symbol_attribute caf_attr; | |
7295 | int rank = 0; | |
7296 | if (code->ext.alloc.ts.type == BT_DERIVED | |
7297 | && code->ext.alloc.ts.u.derived->attr.pointer_comp) | |
7298 | { | |
7299 | type = code->ext.alloc.ts.u.derived; | |
7300 | rank = type->attr.dimension ? type->as->rank : 0; | |
7301 | gfc_clear_attr (&caf_attr); | |
7302 | } | |
7303 | else if (expr->ts.type == BT_DERIVED | |
7304 | && expr->ts.u.derived->attr.pointer_comp) | |
7305 | { | |
7306 | type = expr->ts.u.derived; | |
7307 | rank = expr->rank; | |
7308 | caf_attr = gfc_caf_attr (expr, true); | |
7309 | } | |
7310 | ||
7311 | /* Initialize the tokens of pointer components in derived type | |
7312 | coarrays. */ | |
7313 | if (type) | |
7314 | { | |
7315 | tmp = (caf_attr.codimension && !caf_attr.dimension) | |
7316 | ? gfc_conv_descriptor_data_get (se.expr) : se.expr; | |
7317 | tmp = gfc_nullify_alloc_comp (type, tmp, rank, | |
7318 | GFC_STRUCTURE_CAF_MODE_IN_COARRAY); | |
7319 | gfc_add_expr_to_block (&block, tmp); | |
7320 | } | |
7321 | } | |
7322 | ||
574284e9 | 7323 | gfc_free_expr (expr); |
34d9d749 | 7324 | } // for-loop |
6de9cd9a | 7325 | |
db7ffcab AV |
7326 | if (e3rhs) |
7327 | { | |
7328 | if (newsym) | |
7329 | { | |
7330 | gfc_free_symbol (newsym->n.sym); | |
7331 | XDELETE (newsym); | |
7332 | } | |
7333 | gfc_free_expr (e3rhs); | |
7334 | } | |
5d81ddd0 | 7335 | /* STAT. */ |
a513927a | 7336 | if (code->expr1) |
6de9cd9a | 7337 | { |
8f992d64 | 7338 | tmp = build1_v (LABEL_EXPR, label_errmsg); |
6de9cd9a | 7339 | gfc_add_expr_to_block (&block, tmp); |
6de9cd9a DN |
7340 | } |
7341 | ||
5d81ddd0 TB |
7342 | /* ERRMSG - only useful if STAT is present. */ |
7343 | if (code->expr1 && code->expr2) | |
3759634f | 7344 | { |
3759634f | 7345 | const char *msg = "Attempt to allocate an allocated object"; |
871dbb61 HA |
7346 | const char *oommsg = "Insufficient virtual memory"; |
7347 | tree slen, dlen, errmsg_str, oom_str, oom_loc; | |
5d81ddd0 | 7348 | stmtblock_t errmsg_block; |
3759634f | 7349 | |
5d81ddd0 | 7350 | gfc_init_block (&errmsg_block); |
3759634f | 7351 | |
5d81ddd0 TB |
7352 | errmsg_str = gfc_create_var (pchar_type_node, "ERRMSG"); |
7353 | gfc_add_modify (&errmsg_block, errmsg_str, | |
3759634f SK |
7354 | gfc_build_addr_expr (pchar_type_node, |
7355 | gfc_build_localized_cstring_const (msg))); | |
7356 | ||
f622221a | 7357 | slen = build_int_cst (gfc_charlen_type_node, strlen (msg)); |
3759634f | 7358 | dlen = gfc_get_expr_charlen (code->expr2); |
34d9d749 AV |
7359 | slen = fold_build2_loc (input_location, MIN_EXPR, |
7360 | TREE_TYPE (slen), dlen, slen); | |
3759634f | 7361 | |
34d9d749 AV |
7362 | gfc_trans_string_copy (&errmsg_block, dlen, errmsg, |
7363 | code->expr2->ts.kind, | |
7364 | slen, errmsg_str, | |
7365 | gfc_default_character_kind); | |
5d81ddd0 | 7366 | dlen = gfc_finish_block (&errmsg_block); |
3759634f | 7367 | |
871dbb61 HA |
7368 | tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, |
7369 | stat, build_int_cst (TREE_TYPE (stat), | |
7370 | LIBERROR_ALLOCATION)); | |
7371 | ||
7372 | tmp = build3_v (COND_EXPR, tmp, | |
7373 | dlen, build_empty_stmt (input_location)); | |
7374 | ||
7375 | gfc_add_expr_to_block (&block, tmp); | |
7376 | ||
7377 | oom_str = gfc_create_var (pchar_type_node, "OOMMSG"); | |
7378 | oom_loc = gfc_build_localized_cstring_const (oommsg); | |
7379 | gfc_add_modify (&errmsg_block, oom_str, | |
7380 | gfc_build_addr_expr (pchar_type_node, oom_loc)); | |
7381 | ||
7382 | slen = build_int_cst (gfc_charlen_type_node, strlen (oommsg)); | |
7383 | dlen = gfc_get_expr_charlen (code->expr2); | |
7384 | slen = fold_build2_loc (input_location, MIN_EXPR, | |
7385 | TREE_TYPE (slen), dlen, slen); | |
7386 | ||
7387 | gfc_trans_string_copy (&errmsg_block, dlen, errmsg, | |
7388 | code->expr2->ts.kind, | |
7389 | slen, oom_str, | |
7390 | gfc_default_character_kind); | |
7391 | dlen = gfc_finish_block (&errmsg_block); | |
7392 | ||
7393 | tmp = fold_build2_loc (input_location, EQ_EXPR, logical_type_node, | |
7394 | stat, build_int_cst (TREE_TYPE (stat), | |
7395 | LIBERROR_NO_MEMORY)); | |
3759634f | 7396 | |
34d9d749 AV |
7397 | tmp = build3_v (COND_EXPR, tmp, |
7398 | dlen, build_empty_stmt (input_location)); | |
3759634f SK |
7399 | |
7400 | gfc_add_expr_to_block (&block, tmp); | |
7401 | } | |
7402 | ||
8f992d64 DC |
7403 | /* STAT block. */ |
7404 | if (code->expr1) | |
7405 | { | |
5d81ddd0 TB |
7406 | if (TREE_USED (label_finish)) |
7407 | { | |
7408 | tmp = build1_v (LABEL_EXPR, label_finish); | |
7409 | gfc_add_expr_to_block (&block, tmp); | |
7410 | } | |
7411 | ||
8f992d64 DC |
7412 | gfc_init_se (&se, NULL); |
7413 | gfc_conv_expr_lhs (&se, code->expr1); | |
7414 | tmp = convert (TREE_TYPE (se.expr), stat); | |
7415 | gfc_add_modify (&block, se.expr, tmp); | |
7416 | } | |
7417 | ||
525a5e33 | 7418 | if (needs_caf_sync) |
ffaf9305 AV |
7419 | { |
7420 | /* Add a sync all after the allocation has been executed. */ | |
0f09fc8a | 7421 | tree zero_size = build_zero_cst (size_type_node); |
ffaf9305 AV |
7422 | tmp = build_call_expr_loc (input_location, gfor_fndecl_caf_sync_all, |
7423 | 3, null_pointer_node, null_pointer_node, | |
0f09fc8a | 7424 | zero_size); |
ffaf9305 AV |
7425 | gfc_add_expr_to_block (&post, tmp); |
7426 | } | |
7427 | ||
90cf3ecc PT |
7428 | gfc_add_block_to_block (&block, &se.post); |
7429 | gfc_add_block_to_block (&block, &post); | |
1312bb90 PT |
7430 | if (code->expr3 && code->expr3->must_finalize) |
7431 | gfc_add_block_to_block (&block, &final_block); | |
90cf3ecc | 7432 | |
6de9cd9a DN |
7433 | return gfc_finish_block (&block); |
7434 | } | |
7435 | ||
7436 | ||
3759634f SK |
7437 | /* Translate a DEALLOCATE statement. */ |
7438 | ||
6de9cd9a | 7439 | tree |
3759634f | 7440 | gfc_trans_deallocate (gfc_code *code) |
6de9cd9a DN |
7441 | { |
7442 | gfc_se se; | |
7443 | gfc_alloc *al; | |
5d81ddd0 TB |
7444 | tree apstat, pstat, stat, errmsg, errlen, tmp; |
7445 | tree label_finish, label_errmsg; | |
6de9cd9a DN |
7446 | stmtblock_t block; |
7447 | ||
5d81ddd0 TB |
7448 | pstat = apstat = stat = errmsg = errlen = tmp = NULL_TREE; |
7449 | label_finish = label_errmsg = NULL_TREE; | |
3759634f | 7450 | |
6de9cd9a DN |
7451 | gfc_start_block (&block); |
7452 | ||
3759634f SK |
7453 | /* Count the number of failed deallocations. If deallocate() was |
7454 | called with STAT= , then set STAT to the count. If deallocate | |
7455 | was called with ERRMSG, then set ERRMG to a string. */ | |
5d81ddd0 | 7456 | if (code->expr1) |
364667a1 SK |
7457 | { |
7458 | tree gfc_int4_type_node = gfc_get_int_type (4); | |
7459 | ||
364667a1 | 7460 | stat = gfc_create_var (gfc_int4_type_node, "stat"); |
628c189e | 7461 | pstat = gfc_build_addr_expr (NULL_TREE, stat); |
364667a1 | 7462 | |
5d81ddd0 TB |
7463 | /* GOTO destinations. */ |
7464 | label_errmsg = gfc_build_label_decl (NULL_TREE); | |
7465 | label_finish = gfc_build_label_decl (NULL_TREE); | |
7466 | TREE_USED (label_finish) = 0; | |
7467 | } | |
364667a1 | 7468 | |
5d81ddd0 TB |
7469 | /* Set ERRMSG - only needed if STAT is available. */ |
7470 | if (code->expr1 && code->expr2) | |
7471 | { | |
7472 | gfc_init_se (&se, NULL); | |
7473 | se.want_pointer = 1; | |
7474 | gfc_conv_expr_lhs (&se, code->expr2); | |
7475 | errmsg = se.expr; | |
7476 | errlen = se.string_length; | |
364667a1 | 7477 | } |
364667a1 | 7478 | |
cf2b3c22 | 7479 | for (al = code->ext.alloc.list; al != NULL; al = al->next) |
6de9cd9a | 7480 | { |
0d87fa8c | 7481 | gfc_expr *expr = gfc_copy_expr (al->expr); |
ba85c8c3 AV |
7482 | bool is_coarray = false, is_coarray_array = false; |
7483 | int caf_mode = 0; | |
7484 | ||
6e45f57b | 7485 | gcc_assert (expr->expr_type == EXPR_VARIABLE); |
6de9cd9a | 7486 | |
0d87fa8c JW |
7487 | if (expr->ts.type == BT_CLASS) |
7488 | gfc_add_data_component (expr); | |
7489 | ||
6de9cd9a DN |
7490 | gfc_init_se (&se, NULL); |
7491 | gfc_start_block (&se.pre); | |
7492 | ||
7493 | se.want_pointer = 1; | |
7494 | se.descriptor_only = 1; | |
7495 | gfc_conv_expr (&se, expr); | |
7496 | ||
5bab4c96 PT |
7497 | /* Deallocate PDT components that are parameterized. */ |
7498 | tmp = NULL; | |
7499 | if (expr->ts.type == BT_DERIVED | |
7500 | && expr->ts.u.derived->attr.pdt_type | |
7501 | && expr->symtree->n.sym->param_list) | |
7502 | tmp = gfc_deallocate_pdt_comp (expr->ts.u.derived, se.expr, expr->rank); | |
7503 | else if (expr->ts.type == BT_CLASS | |
7504 | && CLASS_DATA (expr)->ts.u.derived->attr.pdt_type | |
7505 | && expr->symtree->n.sym->param_list) | |
7506 | tmp = gfc_deallocate_pdt_comp (CLASS_DATA (expr)->ts.u.derived, | |
7507 | se.expr, expr->rank); | |
7508 | ||
7509 | if (tmp) | |
7510 | gfc_add_expr_to_block (&block, tmp); | |
7511 | ||
de91486c AV |
7512 | if (flag_coarray == GFC_FCOARRAY_LIB |
7513 | || flag_coarray == GFC_FCOARRAY_SINGLE) | |
ba85c8c3 AV |
7514 | { |
7515 | bool comp_ref; | |
7516 | symbol_attribute caf_attr = gfc_caf_attr (expr, false, &comp_ref); | |
7517 | if (caf_attr.codimension) | |
7518 | { | |
7519 | is_coarray = true; | |
7520 | is_coarray_array = caf_attr.dimension || !comp_ref | |
7521 | || caf_attr.coarray_comp; | |
7522 | ||
de91486c AV |
7523 | if (flag_coarray == GFC_FCOARRAY_LIB) |
7524 | /* When the expression to deallocate is referencing a | |
7525 | component, then only deallocate it, but do not | |
7526 | deregister. */ | |
7527 | caf_mode = GFC_STRUCTURE_CAF_MODE_IN_COARRAY | |
7528 | | (comp_ref && !caf_attr.coarray_comp | |
7529 | ? GFC_STRUCTURE_CAF_MODE_DEALLOC_ONLY : 0); | |
ba85c8c3 AV |
7530 | } |
7531 | } | |
ba85c8c3 AV |
7532 | |
7533 | if (expr->rank || is_coarray_array) | |
2c807128 | 7534 | { |
ec6a7096 PT |
7535 | gfc_ref *ref; |
7536 | ||
ba85c8c3 AV |
7537 | if (gfc_bt_struct (expr->ts.type) |
7538 | && expr->ts.u.derived->attr.alloc_comp | |
ef292537 | 7539 | && !gfc_is_finalizable (expr->ts.u.derived, NULL)) |
5046aff5 | 7540 | { |
2c807128 | 7541 | gfc_ref *last = NULL; |
ec6a7096 | 7542 | |
2c807128 JW |
7543 | for (ref = expr->ref; ref; ref = ref->next) |
7544 | if (ref->type == REF_COMPONENT) | |
7545 | last = ref; | |
7546 | ||
7547 | /* Do not deallocate the components of a derived type | |
34d9d749 | 7548 | ultimate pointer component. */ |
2c807128 JW |
7549 | if (!(last && last->u.c.component->attr.pointer) |
7550 | && !(!last && expr->symtree->n.sym->attr.pointer)) | |
7551 | { | |
ba85c8c3 | 7552 | if (is_coarray && expr->rank == 0 |
eb401400 AV |
7553 | && (!last || !last->u.c.component->attr.dimension) |
7554 | && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se.expr))) | |
ba85c8c3 AV |
7555 | { |
7556 | /* Add the ref to the data member only, when this is not | |
7557 | a regular array or deallocate_alloc_comp will try to | |
7558 | add another one. */ | |
7559 | tmp = gfc_conv_descriptor_data_get (se.expr); | |
7560 | } | |
7561 | else | |
7562 | tmp = se.expr; | |
7563 | tmp = gfc_deallocate_alloc_comp (expr->ts.u.derived, tmp, | |
7564 | expr->rank, caf_mode); | |
2c807128 JW |
7565 | gfc_add_expr_to_block (&se.pre, tmp); |
7566 | } | |
5046aff5 | 7567 | } |
ec6a7096 PT |
7568 | |
7569 | if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se.expr))) | |
7570 | { | |
ba85c8c3 AV |
7571 | gfc_coarray_deregtype caf_dtype; |
7572 | ||
7573 | if (is_coarray) | |
7574 | caf_dtype = gfc_caf_is_dealloc_only (caf_mode) | |
7575 | ? GFC_CAF_COARRAY_DEALLOCATE_ONLY | |
7576 | : GFC_CAF_COARRAY_DEREGISTER; | |
7577 | else | |
7578 | caf_dtype = GFC_CAF_COARRAY_NOCOARRAY; | |
39da5866 AV |
7579 | tmp = gfc_deallocate_with_status (se.expr, pstat, errmsg, errlen, |
7580 | label_finish, false, expr, | |
7581 | caf_dtype); | |
ec6a7096 PT |
7582 | gfc_add_expr_to_block (&se.pre, tmp); |
7583 | } | |
7584 | else if (TREE_CODE (se.expr) == COMPONENT_REF | |
7585 | && TREE_CODE (TREE_TYPE (se.expr)) == ARRAY_TYPE | |
7586 | && TREE_CODE (TREE_TYPE (TREE_TYPE (se.expr))) | |
7587 | == RECORD_TYPE) | |
7588 | { | |
e53b6e56 | 7589 | /* class.cc(finalize_component) generates these, when a |
ec6a7096 PT |
7590 | finalizable entity has a non-allocatable derived type array |
7591 | component, which has allocatable components. Obtain the | |
7592 | derived type of the array and deallocate the allocatable | |
7593 | components. */ | |
7594 | for (ref = expr->ref; ref; ref = ref->next) | |
7595 | { | |
7596 | if (ref->u.c.component->attr.dimension | |
7597 | && ref->u.c.component->ts.type == BT_DERIVED) | |
7598 | break; | |
7599 | } | |
7600 | ||
7601 | if (ref && ref->u.c.component->ts.u.derived->attr.alloc_comp | |
7602 | && !gfc_is_finalizable (ref->u.c.component->ts.u.derived, | |
7603 | NULL)) | |
7604 | { | |
7605 | tmp = gfc_deallocate_alloc_comp | |
7606 | (ref->u.c.component->ts.u.derived, | |
7607 | se.expr, expr->rank); | |
7608 | gfc_add_expr_to_block (&se.pre, tmp); | |
7609 | } | |
7610 | } | |
7611 | ||
4fb5478c | 7612 | if (al->expr->ts.type == BT_CLASS) |
34d9d749 AV |
7613 | { |
7614 | gfc_reset_vptr (&se.pre, al->expr); | |
7615 | if (UNLIMITED_POLY (al->expr) | |
7616 | || (al->expr->ts.type == BT_DERIVED | |
7617 | && al->expr->ts.u.derived->attr.unlimited_polymorphic)) | |
7618 | /* Clear _len, too. */ | |
7619 | gfc_reset_len (&se.pre, al->expr); | |
7620 | } | |
5046aff5 | 7621 | } |
6de9cd9a DN |
7622 | else |
7623 | { | |
ba85c8c3 AV |
7624 | tmp = gfc_deallocate_scalar_with_status (se.expr, pstat, label_finish, |
7625 | false, al->expr, | |
e21e13e2 MM |
7626 | al->expr->ts, NULL_TREE, |
7627 | is_coarray); | |
54200abb RG |
7628 | gfc_add_expr_to_block (&se.pre, tmp); |
7629 | ||
0d87fa8c | 7630 | /* Set to zero after deallocation. */ |
bc98ed60 TB |
7631 | tmp = fold_build2_loc (input_location, MODIFY_EXPR, void_type_node, |
7632 | se.expr, | |
7633 | build_int_cst (TREE_TYPE (se.expr), 0)); | |
0d87fa8c | 7634 | gfc_add_expr_to_block (&se.pre, tmp); |
8b704316 | 7635 | |
0d87fa8c | 7636 | if (al->expr->ts.type == BT_CLASS) |
34d9d749 AV |
7637 | { |
7638 | gfc_reset_vptr (&se.pre, al->expr); | |
7639 | if (UNLIMITED_POLY (al->expr) | |
7640 | || (al->expr->ts.type == BT_DERIVED | |
7641 | && al->expr->ts.u.derived->attr.unlimited_polymorphic)) | |
7642 | /* Clear _len, too. */ | |
7643 | gfc_reset_len (&se.pre, al->expr); | |
7644 | } | |
6de9cd9a | 7645 | } |
364667a1 | 7646 | |
5d81ddd0 | 7647 | if (code->expr1) |
364667a1 | 7648 | { |
5d81ddd0 TB |
7649 | tree cond; |
7650 | ||
63ee5404 | 7651 | cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node, stat, |
5d81ddd0 TB |
7652 | build_int_cst (TREE_TYPE (stat), 0)); |
7653 | tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, | |
ed9c79e1 | 7654 | gfc_unlikely (cond, PRED_FORTRAN_FAIL_ALLOC), |
5d81ddd0 TB |
7655 | build1_v (GOTO_EXPR, label_errmsg), |
7656 | build_empty_stmt (input_location)); | |
7657 | gfc_add_expr_to_block (&se.pre, tmp); | |
364667a1 SK |
7658 | } |
7659 | ||
6de9cd9a DN |
7660 | tmp = gfc_finish_block (&se.pre); |
7661 | gfc_add_expr_to_block (&block, tmp); | |
0d87fa8c | 7662 | gfc_free_expr (expr); |
364667a1 SK |
7663 | } |
7664 | ||
a513927a | 7665 | if (code->expr1) |
364667a1 | 7666 | { |
5d81ddd0 TB |
7667 | tmp = build1_v (LABEL_EXPR, label_errmsg); |
7668 | gfc_add_expr_to_block (&block, tmp); | |
6de9cd9a DN |
7669 | } |
7670 | ||
5d81ddd0 TB |
7671 | /* Set ERRMSG - only needed if STAT is available. */ |
7672 | if (code->expr1 && code->expr2) | |
3759634f | 7673 | { |
3759634f | 7674 | const char *msg = "Attempt to deallocate an unallocated object"; |
5d81ddd0 TB |
7675 | stmtblock_t errmsg_block; |
7676 | tree errmsg_str, slen, dlen, cond; | |
3759634f | 7677 | |
5d81ddd0 | 7678 | gfc_init_block (&errmsg_block); |
3759634f | 7679 | |
5d81ddd0 TB |
7680 | errmsg_str = gfc_create_var (pchar_type_node, "ERRMSG"); |
7681 | gfc_add_modify (&errmsg_block, errmsg_str, | |
3759634f SK |
7682 | gfc_build_addr_expr (pchar_type_node, |
7683 | gfc_build_localized_cstring_const (msg))); | |
f622221a | 7684 | slen = build_int_cst (gfc_charlen_type_node, strlen (msg)); |
3759634f | 7685 | dlen = gfc_get_expr_charlen (code->expr2); |
3759634f | 7686 | |
5d81ddd0 TB |
7687 | gfc_trans_string_copy (&errmsg_block, dlen, errmsg, code->expr2->ts.kind, |
7688 | slen, errmsg_str, gfc_default_character_kind); | |
7689 | tmp = gfc_finish_block (&errmsg_block); | |
3759634f | 7690 | |
63ee5404 | 7691 | cond = fold_build2_loc (input_location, NE_EXPR, logical_type_node, stat, |
5d81ddd0 TB |
7692 | build_int_cst (TREE_TYPE (stat), 0)); |
7693 | tmp = fold_build3_loc (input_location, COND_EXPR, void_type_node, | |
ed9c79e1 | 7694 | gfc_unlikely (cond, PRED_FORTRAN_FAIL_ALLOC), tmp, |
5d81ddd0 | 7695 | build_empty_stmt (input_location)); |
3759634f | 7696 | |
5d81ddd0 TB |
7697 | gfc_add_expr_to_block (&block, tmp); |
7698 | } | |
3759634f | 7699 | |
5d81ddd0 TB |
7700 | if (code->expr1 && TREE_USED (label_finish)) |
7701 | { | |
7702 | tmp = build1_v (LABEL_EXPR, label_finish); | |
3759634f SK |
7703 | gfc_add_expr_to_block (&block, tmp); |
7704 | } | |
7705 | ||
5d81ddd0 TB |
7706 | /* Set STAT. */ |
7707 | if (code->expr1) | |
7708 | { | |
7709 | gfc_init_se (&se, NULL); | |
7710 | gfc_conv_expr_lhs (&se, code->expr1); | |
7711 | tmp = convert (TREE_TYPE (se.expr), stat); | |
7712 | gfc_add_modify (&block, se.expr, tmp); | |
7713 | } | |
7714 | ||
6de9cd9a DN |
7715 | return gfc_finish_block (&block); |
7716 | } | |
7717 | ||
d2886bc7 | 7718 | #include "gt-fortran-trans-stmt.h" |