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