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