1 /* Statement translation -- generate GCC trees from gfc_code.
2 Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008
3 Free Software Foundation, Inc.
4 Contributed by Paul Brook <paul@nowt.org>
5 and Steven Bosscher <s.bosscher@student.tudelft.nl>
7 This file is part of GCC.
9 GCC is free software; you can redistribute it and/or modify it under
10 the terms of the GNU General Public License as published by the Free
11 Software Foundation; either version 3, or (at your option) any later
14 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
15 WARRANTY; without even the implied warranty of MERCHANTABILITY or
16 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
19 You should have received a copy of the GNU General Public License
20 along with GCC; see the file COPYING3. If not see
21 <http://www.gnu.org/licenses/>. */
26 #include "coretypes.h"
35 #include "trans-stmt.h"
36 #include "trans-types.h"
37 #include "trans-array.h"
38 #include "trans-const.h"
40 #include "dependency.h"
42 typedef struct iter_info
48 struct iter_info *next;
52 typedef struct forall_info
59 struct forall_info *prev_nest;
63 static void gfc_trans_where_2 (gfc_code *, tree, bool,
64 forall_info *, stmtblock_t *);
66 /* Translate a F95 label number to a LABEL_EXPR. */
69 gfc_trans_label_here (gfc_code * code)
71 return build1_v (LABEL_EXPR, gfc_get_label_decl (code->here));
75 /* Given a variable expression which has been ASSIGNed to, find the decl
76 containing the auxiliary variables. For variables in common blocks this
80 gfc_conv_label_variable (gfc_se * se, gfc_expr * expr)
82 gcc_assert (expr->symtree->n.sym->attr.assign == 1);
83 gfc_conv_expr (se, expr);
84 /* Deals with variable in common block. Get the field declaration. */
85 if (TREE_CODE (se->expr) == COMPONENT_REF)
86 se->expr = TREE_OPERAND (se->expr, 1);
87 /* Deals with dummy argument. Get the parameter declaration. */
88 else if (TREE_CODE (se->expr) == INDIRECT_REF)
89 se->expr = TREE_OPERAND (se->expr, 0);
92 /* Translate a label assignment statement. */
95 gfc_trans_label_assign (gfc_code * code)
104 /* Start a new block. */
105 gfc_init_se (&se, NULL);
106 gfc_start_block (&se.pre);
107 gfc_conv_label_variable (&se, code->expr);
109 len = GFC_DECL_STRING_LEN (se.expr);
110 addr = GFC_DECL_ASSIGN_ADDR (se.expr);
112 label_tree = gfc_get_label_decl (code->label);
114 if (code->label->defined == ST_LABEL_TARGET)
116 label_tree = gfc_build_addr_expr (pvoid_type_node, label_tree);
117 len_tree = integer_minus_one_node;
121 gfc_expr *format = code->label->format;
123 label_len = format->value.character.length;
124 len_tree = build_int_cst (NULL_TREE, label_len);
125 label_tree = gfc_build_wide_string_const (format->ts.kind, label_len + 1,
126 format->value.character.string);
127 label_tree = gfc_build_addr_expr (pvoid_type_node, label_tree);
130 gfc_add_modify (&se.pre, len, len_tree);
131 gfc_add_modify (&se.pre, addr, label_tree);
133 return gfc_finish_block (&se.pre);
136 /* Translate a GOTO statement. */
139 gfc_trans_goto (gfc_code * code)
141 locus loc = code->loc;
147 if (code->label != NULL)
148 return build1_v (GOTO_EXPR, gfc_get_label_decl (code->label));
151 gfc_init_se (&se, NULL);
152 gfc_start_block (&se.pre);
153 gfc_conv_label_variable (&se, code->expr);
154 tmp = GFC_DECL_STRING_LEN (se.expr);
155 tmp = fold_build2 (NE_EXPR, boolean_type_node, tmp,
156 build_int_cst (TREE_TYPE (tmp), -1));
157 gfc_trans_runtime_check (true, false, tmp, &se.pre, &loc,
158 "Assigned label is not a target label");
160 assigned_goto = GFC_DECL_ASSIGN_ADDR (se.expr);
165 target = fold_build1 (GOTO_EXPR, void_type_node, assigned_goto);
166 gfc_add_expr_to_block (&se.pre, target);
167 return gfc_finish_block (&se.pre);
170 /* Check the label list. */
173 target = gfc_get_label_decl (code->label);
174 tmp = gfc_build_addr_expr (pvoid_type_node, target);
175 tmp = fold_build2 (EQ_EXPR, boolean_type_node, tmp, assigned_goto);
176 tmp = build3_v (COND_EXPR, tmp,
177 fold_build1 (GOTO_EXPR, void_type_node, target),
178 build_empty_stmt ());
179 gfc_add_expr_to_block (&se.pre, tmp);
182 while (code != NULL);
183 gfc_trans_runtime_check (true, false, boolean_true_node, &se.pre, &loc,
184 "Assigned label is not in the list");
186 return gfc_finish_block (&se.pre);
190 /* Translate an ENTRY statement. Just adds a label for this entry point. */
192 gfc_trans_entry (gfc_code * code)
194 return build1_v (LABEL_EXPR, code->ext.entry->label);
198 /* Check for dependencies between INTENT(IN) and INTENT(OUT) arguments of
199 elemental subroutines. Make temporaries for output arguments if any such
200 dependencies are found. Output arguments are chosen because internal_unpack
201 can be used, as is, to copy the result back to the variable. */
203 gfc_conv_elemental_dependencies (gfc_se * se, gfc_se * loopse,
204 gfc_symbol * sym, gfc_actual_arglist * arg)
206 gfc_actual_arglist *arg0;
208 gfc_formal_arglist *formal;
209 gfc_loopinfo tmp_loop;
221 if (loopse->ss == NULL)
226 formal = sym->formal;
228 /* Loop over all the arguments testing for dependencies. */
229 for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL)
235 /* Obtain the info structure for the current argument. */
237 for (ss = loopse->ss; ss && ss != gfc_ss_terminator; ss = ss->next)
241 info = &ss->data.info;
245 /* If there is a dependency, create a temporary and use it
246 instead of the variable. */
247 fsym = formal ? formal->sym : NULL;
248 if (e->expr_type == EXPR_VARIABLE
250 && fsym->attr.intent != INTENT_IN
251 && gfc_check_fncall_dependency (e, fsym->attr.intent,
255 stmtblock_t temp_post;
257 /* Make a local loopinfo for the temporary creation, so that
258 none of the other ss->info's have to be renormalized. */
259 gfc_init_loopinfo (&tmp_loop);
260 for (n = 0; n < info->dimen; n++)
262 tmp_loop.to[n] = loopse->loop->to[n];
263 tmp_loop.from[n] = loopse->loop->from[n];
264 tmp_loop.order[n] = loopse->loop->order[n];
267 /* Obtain the argument descriptor for unpacking. */
268 gfc_init_se (&parmse, NULL);
269 parmse.want_pointer = 1;
270 gfc_conv_expr_descriptor (&parmse, e, gfc_walk_expr (e));
271 gfc_add_block_to_block (&se->pre, &parmse.pre);
273 /* If we've got INTENT(INOUT), initialize the array temporary with
274 a copy of the values. */
275 if (fsym->attr.intent == INTENT_INOUT)
276 initial = parmse.expr;
280 /* Generate the temporary. Merge the block so that the
281 declarations are put at the right binding level. Cleaning up the
282 temporary should be the very last thing done, so we add the code to
283 a new block and add it to se->post as last instructions. */
284 size = gfc_create_var (gfc_array_index_type, NULL);
285 data = gfc_create_var (pvoid_type_node, NULL);
286 gfc_start_block (&block);
287 gfc_init_block (&temp_post);
288 tmp = gfc_typenode_for_spec (&e->ts);
289 tmp = gfc_trans_create_temp_array (&se->pre, &temp_post,
290 &tmp_loop, info, tmp,
294 gfc_add_modify (&se->pre, size, tmp);
295 tmp = fold_convert (pvoid_type_node, info->data);
296 gfc_add_modify (&se->pre, data, tmp);
297 gfc_merge_block_scope (&block);
299 /* Calculate the offset for the temporary. */
300 offset = gfc_index_zero_node;
301 for (n = 0; n < info->dimen; n++)
303 tmp = gfc_conv_descriptor_stride (info->descriptor,
305 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
306 loopse->loop->from[n], tmp);
307 offset = fold_build2 (MINUS_EXPR, gfc_array_index_type,
310 info->offset = gfc_create_var (gfc_array_index_type, NULL);
311 gfc_add_modify (&se->pre, info->offset, offset);
314 /* Copy the result back using unpack. */
315 tmp = build_call_expr (gfor_fndecl_in_unpack, 2, parmse.expr, data);
316 gfc_add_expr_to_block (&se->post, tmp);
318 /* XXX: This is possibly not needed; but isn't it cleaner this way? */
319 gfc_add_block_to_block (&se->pre, &parmse.pre);
321 gfc_add_block_to_block (&se->post, &parmse.post);
322 gfc_add_block_to_block (&se->post, &temp_post);
328 /* Translate the CALL statement. Builds a call to an F95 subroutine. */
331 gfc_trans_call (gfc_code * code, bool dependency_check)
335 int has_alternate_specifier;
337 /* A CALL starts a new block because the actual arguments may have to
338 be evaluated first. */
339 gfc_init_se (&se, NULL);
340 gfc_start_block (&se.pre);
342 gcc_assert (code->resolved_sym);
344 ss = gfc_ss_terminator;
345 if (code->resolved_sym->attr.elemental)
346 ss = gfc_walk_elemental_function_args (ss, code->ext.actual, GFC_SS_REFERENCE);
348 /* Is not an elemental subroutine call with array valued arguments. */
349 if (ss == gfc_ss_terminator)
352 /* Translate the call. */
353 has_alternate_specifier
354 = gfc_conv_function_call (&se, code->resolved_sym, code->ext.actual,
357 /* A subroutine without side-effect, by definition, does nothing! */
358 TREE_SIDE_EFFECTS (se.expr) = 1;
360 /* Chain the pieces together and return the block. */
361 if (has_alternate_specifier)
363 gfc_code *select_code;
365 select_code = code->next;
366 gcc_assert(select_code->op == EXEC_SELECT);
367 sym = select_code->expr->symtree->n.sym;
368 se.expr = convert (gfc_typenode_for_spec (&sym->ts), se.expr);
369 if (sym->backend_decl == NULL)
370 sym->backend_decl = gfc_get_symbol_decl (sym);
371 gfc_add_modify (&se.pre, sym->backend_decl, se.expr);
374 gfc_add_expr_to_block (&se.pre, se.expr);
376 gfc_add_block_to_block (&se.pre, &se.post);
381 /* An elemental subroutine call with array valued arguments has
388 /* gfc_walk_elemental_function_args renders the ss chain in the
389 reverse order to the actual argument order. */
390 ss = gfc_reverse_ss (ss);
392 /* Initialize the loop. */
393 gfc_init_se (&loopse, NULL);
394 gfc_init_loopinfo (&loop);
395 gfc_add_ss_to_loop (&loop, ss);
397 gfc_conv_ss_startstride (&loop);
398 gfc_conv_loop_setup (&loop, &code->expr->where);
399 gfc_mark_ss_chain_used (ss, 1);
401 /* Convert the arguments, checking for dependencies. */
402 gfc_copy_loopinfo_to_se (&loopse, &loop);
405 /* For operator assignment, do dependency checking. */
406 if (dependency_check)
409 sym = code->resolved_sym;
410 gfc_conv_elemental_dependencies (&se, &loopse, sym,
414 /* Generate the loop body. */
415 gfc_start_scalarized_body (&loop, &body);
416 gfc_init_block (&block);
418 /* Add the subroutine call to the block. */
419 gfc_conv_function_call (&loopse, code->resolved_sym, code->ext.actual,
421 gfc_add_expr_to_block (&loopse.pre, loopse.expr);
423 gfc_add_block_to_block (&block, &loopse.pre);
424 gfc_add_block_to_block (&block, &loopse.post);
426 /* Finish up the loop block and the loop. */
427 gfc_add_expr_to_block (&body, gfc_finish_block (&block));
428 gfc_trans_scalarizing_loops (&loop, &body);
429 gfc_add_block_to_block (&se.pre, &loop.pre);
430 gfc_add_block_to_block (&se.pre, &loop.post);
431 gfc_add_block_to_block (&se.pre, &se.post);
432 gfc_cleanup_loop (&loop);
435 return gfc_finish_block (&se.pre);
439 /* Translate the RETURN statement. */
442 gfc_trans_return (gfc_code * code ATTRIBUTE_UNUSED)
450 /* If code->expr is not NULL, this return statement must appear
451 in a subroutine and current_fake_result_decl has already
454 result = gfc_get_fake_result_decl (NULL, 0);
457 gfc_warning ("An alternate return at %L without a * dummy argument",
459 return build1_v (GOTO_EXPR, gfc_get_return_label ());
462 /* Start a new block for this statement. */
463 gfc_init_se (&se, NULL);
464 gfc_start_block (&se.pre);
466 gfc_conv_expr (&se, code->expr);
468 tmp = fold_build2 (MODIFY_EXPR, TREE_TYPE (result), result,
469 fold_convert (TREE_TYPE (result), se.expr));
470 gfc_add_expr_to_block (&se.pre, tmp);
472 tmp = build1_v (GOTO_EXPR, gfc_get_return_label ());
473 gfc_add_expr_to_block (&se.pre, tmp);
474 gfc_add_block_to_block (&se.pre, &se.post);
475 return gfc_finish_block (&se.pre);
478 return build1_v (GOTO_EXPR, gfc_get_return_label ());
482 /* Translate the PAUSE statement. We have to translate this statement
483 to a runtime library call. */
486 gfc_trans_pause (gfc_code * code)
488 tree gfc_int4_type_node = gfc_get_int_type (4);
492 /* Start a new block for this statement. */
493 gfc_init_se (&se, NULL);
494 gfc_start_block (&se.pre);
497 if (code->expr == NULL)
499 tmp = build_int_cst (gfc_int4_type_node, code->ext.stop_code);
500 tmp = build_call_expr (gfor_fndecl_pause_numeric, 1, tmp);
504 gfc_conv_expr_reference (&se, code->expr);
505 tmp = build_call_expr (gfor_fndecl_pause_string, 2,
506 se.expr, se.string_length);
509 gfc_add_expr_to_block (&se.pre, tmp);
511 gfc_add_block_to_block (&se.pre, &se.post);
513 return gfc_finish_block (&se.pre);
517 /* Translate the STOP statement. We have to translate this statement
518 to a runtime library call. */
521 gfc_trans_stop (gfc_code * code)
523 tree gfc_int4_type_node = gfc_get_int_type (4);
527 /* Start a new block for this statement. */
528 gfc_init_se (&se, NULL);
529 gfc_start_block (&se.pre);
532 if (code->expr == NULL)
534 tmp = build_int_cst (gfc_int4_type_node, code->ext.stop_code);
535 tmp = build_call_expr (gfor_fndecl_stop_numeric, 1, tmp);
539 gfc_conv_expr_reference (&se, code->expr);
540 tmp = build_call_expr (gfor_fndecl_stop_string, 2,
541 se.expr, se.string_length);
544 gfc_add_expr_to_block (&se.pre, tmp);
546 gfc_add_block_to_block (&se.pre, &se.post);
548 return gfc_finish_block (&se.pre);
552 /* Generate GENERIC for the IF construct. This function also deals with
553 the simple IF statement, because the front end translates the IF
554 statement into an IF construct.
586 where COND_S is the simplified version of the predicate. PRE_COND_S
587 are the pre side-effects produced by the translation of the
589 We need to build the chain recursively otherwise we run into
590 problems with folding incomplete statements. */
593 gfc_trans_if_1 (gfc_code * code)
598 /* Check for an unconditional ELSE clause. */
600 return gfc_trans_code (code->next);
602 /* Initialize a statement builder for each block. Puts in NULL_TREEs. */
603 gfc_init_se (&if_se, NULL);
604 gfc_start_block (&if_se.pre);
606 /* Calculate the IF condition expression. */
607 gfc_conv_expr_val (&if_se, code->expr);
609 /* Translate the THEN clause. */
610 stmt = gfc_trans_code (code->next);
612 /* Translate the ELSE clause. */
614 elsestmt = gfc_trans_if_1 (code->block);
616 elsestmt = build_empty_stmt ();
618 /* Build the condition expression and add it to the condition block. */
619 stmt = fold_build3 (COND_EXPR, void_type_node, if_se.expr, stmt, elsestmt);
621 gfc_add_expr_to_block (&if_se.pre, stmt);
623 /* Finish off this statement. */
624 return gfc_finish_block (&if_se.pre);
628 gfc_trans_if (gfc_code * code)
630 /* Ignore the top EXEC_IF, it only announces an IF construct. The
631 actual code we must translate is in code->block. */
633 return gfc_trans_if_1 (code->block);
637 /* Translate an arithmetic IF expression.
639 IF (cond) label1, label2, label3 translates to
651 An optimized version can be generated in case of equal labels.
652 E.g., if label1 is equal to label2, we can translate it to
661 gfc_trans_arithmetic_if (gfc_code * code)
669 /* Start a new block. */
670 gfc_init_se (&se, NULL);
671 gfc_start_block (&se.pre);
673 /* Pre-evaluate COND. */
674 gfc_conv_expr_val (&se, code->expr);
675 se.expr = gfc_evaluate_now (se.expr, &se.pre);
677 /* Build something to compare with. */
678 zero = gfc_build_const (TREE_TYPE (se.expr), integer_zero_node);
680 if (code->label->value != code->label2->value)
682 /* If (cond < 0) take branch1 else take branch2.
683 First build jumps to the COND .LT. 0 and the COND .EQ. 0 cases. */
684 branch1 = build1_v (GOTO_EXPR, gfc_get_label_decl (code->label));
685 branch2 = build1_v (GOTO_EXPR, gfc_get_label_decl (code->label2));
687 if (code->label->value != code->label3->value)
688 tmp = fold_build2 (LT_EXPR, boolean_type_node, se.expr, zero);
690 tmp = fold_build2 (NE_EXPR, boolean_type_node, se.expr, zero);
692 branch1 = fold_build3 (COND_EXPR, void_type_node, tmp, branch1, branch2);
695 branch1 = build1_v (GOTO_EXPR, gfc_get_label_decl (code->label));
697 if (code->label->value != code->label3->value
698 && code->label2->value != code->label3->value)
700 /* if (cond <= 0) take branch1 else take branch2. */
701 branch2 = build1_v (GOTO_EXPR, gfc_get_label_decl (code->label3));
702 tmp = fold_build2 (LE_EXPR, boolean_type_node, se.expr, zero);
703 branch1 = fold_build3 (COND_EXPR, void_type_node, tmp, branch1, branch2);
706 /* Append the COND_EXPR to the evaluation of COND, and return. */
707 gfc_add_expr_to_block (&se.pre, branch1);
708 return gfc_finish_block (&se.pre);
712 /* Translate the simple DO construct. This is where the loop variable has
713 integer type and step +-1. We can't use this in the general case
714 because integer overflow and floating point errors could give incorrect
716 We translate a do loop from:
718 DO dovar = from, to, step
724 [Evaluate loop bounds and step]
726 if ((step > 0) ? (dovar <= to) : (dovar => to))
732 cond = (dovar == to);
734 if (cond) goto end_label;
739 This helps the optimizers by avoiding the extra induction variable
740 used in the general case. */
743 gfc_trans_simple_do (gfc_code * code, stmtblock_t *pblock, tree dovar,
744 tree from, tree to, tree step)
753 type = TREE_TYPE (dovar);
755 /* Initialize the DO variable: dovar = from. */
756 gfc_add_modify (pblock, dovar, from);
758 /* Cycle and exit statements are implemented with gotos. */
759 cycle_label = gfc_build_label_decl (NULL_TREE);
760 exit_label = gfc_build_label_decl (NULL_TREE);
762 /* Put the labels where they can be found later. See gfc_trans_do(). */
763 code->block->backend_decl = tree_cons (cycle_label, exit_label, NULL);
766 gfc_start_block (&body);
768 /* Main loop body. */
769 tmp = gfc_trans_code (code->block->next);
770 gfc_add_expr_to_block (&body, tmp);
772 /* Label for cycle statements (if needed). */
773 if (TREE_USED (cycle_label))
775 tmp = build1_v (LABEL_EXPR, cycle_label);
776 gfc_add_expr_to_block (&body, tmp);
779 /* Evaluate the loop condition. */
780 cond = fold_build2 (EQ_EXPR, boolean_type_node, dovar, to);
781 cond = gfc_evaluate_now (cond, &body);
783 /* Increment the loop variable. */
784 tmp = fold_build2 (PLUS_EXPR, type, dovar, step);
785 gfc_add_modify (&body, dovar, tmp);
788 tmp = build1_v (GOTO_EXPR, exit_label);
789 TREE_USED (exit_label) = 1;
790 tmp = fold_build3 (COND_EXPR, void_type_node,
791 cond, tmp, build_empty_stmt ());
792 gfc_add_expr_to_block (&body, tmp);
794 /* Finish the loop body. */
795 tmp = gfc_finish_block (&body);
796 tmp = build1_v (LOOP_EXPR, tmp);
798 /* Only execute the loop if the number of iterations is positive. */
799 if (tree_int_cst_sgn (step) > 0)
800 cond = fold_build2 (LE_EXPR, boolean_type_node, dovar, to);
802 cond = fold_build2 (GE_EXPR, boolean_type_node, dovar, to);
803 tmp = fold_build3 (COND_EXPR, void_type_node,
804 cond, tmp, build_empty_stmt ());
805 gfc_add_expr_to_block (pblock, tmp);
807 /* Add the exit label. */
808 tmp = build1_v (LABEL_EXPR, exit_label);
809 gfc_add_expr_to_block (pblock, tmp);
811 return gfc_finish_block (pblock);
814 /* Translate the DO construct. This obviously is one of the most
815 important ones to get right with any compiler, but especially
818 We special case some loop forms as described in gfc_trans_simple_do.
819 For other cases we implement them with a separate loop count,
820 as described in the standard.
822 We translate a do loop from:
824 DO dovar = from, to, step
830 [evaluate loop bounds and step]
831 empty = (step > 0 ? to < from : to > from);
832 countm1 = (to - from) / step;
834 if (empty) goto exit_label;
840 if (countm1 ==0) goto exit_label;
845 countm1 is an unsigned integer. It is equal to the loop count minus one,
846 because the loop count itself can overflow. */
849 gfc_trans_do (gfc_code * code)
867 gfc_start_block (&block);
869 /* Evaluate all the expressions in the iterator. */
870 gfc_init_se (&se, NULL);
871 gfc_conv_expr_lhs (&se, code->ext.iterator->var);
872 gfc_add_block_to_block (&block, &se.pre);
874 type = TREE_TYPE (dovar);
876 gfc_init_se (&se, NULL);
877 gfc_conv_expr_val (&se, code->ext.iterator->start);
878 gfc_add_block_to_block (&block, &se.pre);
879 from = gfc_evaluate_now (se.expr, &block);
881 gfc_init_se (&se, NULL);
882 gfc_conv_expr_val (&se, code->ext.iterator->end);
883 gfc_add_block_to_block (&block, &se.pre);
884 to = gfc_evaluate_now (se.expr, &block);
886 gfc_init_se (&se, NULL);
887 gfc_conv_expr_val (&se, code->ext.iterator->step);
888 gfc_add_block_to_block (&block, &se.pre);
889 step = gfc_evaluate_now (se.expr, &block);
891 /* Special case simple loops. */
892 if (TREE_CODE (type) == INTEGER_TYPE
893 && (integer_onep (step)
894 || tree_int_cst_equal (step, integer_minus_one_node)))
895 return gfc_trans_simple_do (code, &block, dovar, from, to, step);
897 pos_step = fold_build2 (GT_EXPR, boolean_type_node, step,
898 fold_convert (type, integer_zero_node));
900 if (TREE_CODE (type) == INTEGER_TYPE)
901 utype = unsigned_type_for (type);
903 utype = unsigned_type_for (gfc_array_index_type);
904 countm1 = gfc_create_var (utype, "countm1");
906 /* Cycle and exit statements are implemented with gotos. */
907 cycle_label = gfc_build_label_decl (NULL_TREE);
908 exit_label = gfc_build_label_decl (NULL_TREE);
909 TREE_USED (exit_label) = 1;
911 /* Initialize the DO variable: dovar = from. */
912 gfc_add_modify (&block, dovar, from);
914 /* Initialize loop count and jump to exit label if the loop is empty.
915 This code is executed before we enter the loop body. We generate:
918 if (to < from) goto exit_label;
919 countm1 = (to - from) / step;
923 if (to > from) goto exit_label;
924 countm1 = (from - to) / -step;
926 if (TREE_CODE (type) == INTEGER_TYPE)
930 tmp = fold_build2 (LT_EXPR, boolean_type_node, to, from);
931 pos = fold_build3 (COND_EXPR, void_type_node, tmp,
932 build1_v (GOTO_EXPR, exit_label),
933 build_empty_stmt ());
934 tmp = fold_build2 (MINUS_EXPR, type, to, from);
935 tmp = fold_convert (utype, tmp);
936 tmp = fold_build2 (TRUNC_DIV_EXPR, utype, tmp,
937 fold_convert (utype, step));
938 tmp = build2 (MODIFY_EXPR, void_type_node, countm1, tmp);
939 pos = build2 (COMPOUND_EXPR, void_type_node, pos, tmp);
941 tmp = fold_build2 (GT_EXPR, boolean_type_node, to, from);
942 neg = fold_build3 (COND_EXPR, void_type_node, tmp,
943 build1_v (GOTO_EXPR, exit_label),
944 build_empty_stmt ());
945 tmp = fold_build2 (MINUS_EXPR, type, from, to);
946 tmp = fold_convert (utype, tmp);
947 tmp = fold_build2 (TRUNC_DIV_EXPR, utype, tmp,
948 fold_convert (utype, fold_build1 (NEGATE_EXPR,
950 tmp = build2 (MODIFY_EXPR, void_type_node, countm1, tmp);
951 neg = build2 (COMPOUND_EXPR, void_type_node, neg, tmp);
953 tmp = fold_build3 (COND_EXPR, void_type_node, pos_step, pos, neg);
954 gfc_add_expr_to_block (&block, tmp);
958 /* TODO: We could use the same width as the real type.
959 This would probably cause more problems that it solves
960 when we implement "long double" types. */
962 tmp = fold_build2 (MINUS_EXPR, type, to, from);
963 tmp = fold_build2 (RDIV_EXPR, type, tmp, step);
964 tmp = fold_build1 (FIX_TRUNC_EXPR, utype, tmp);
965 gfc_add_modify (&block, countm1, tmp);
967 /* We need a special check for empty loops:
968 empty = (step > 0 ? to < from : to > from); */
969 tmp = fold_build3 (COND_EXPR, boolean_type_node, pos_step,
970 fold_build2 (LT_EXPR, boolean_type_node, to, from),
971 fold_build2 (GT_EXPR, boolean_type_node, to, from));
972 /* If the loop is empty, go directly to the exit label. */
973 tmp = fold_build3 (COND_EXPR, void_type_node, tmp,
974 build1_v (GOTO_EXPR, exit_label),
975 build_empty_stmt ());
976 gfc_add_expr_to_block (&block, tmp);
980 gfc_start_block (&body);
982 /* Put these labels where they can be found later. We put the
983 labels in a TREE_LIST node (because TREE_CHAIN is already
984 used). cycle_label goes in TREE_PURPOSE (backend_decl), exit
985 label in TREE_VALUE (backend_decl). */
987 code->block->backend_decl = tree_cons (cycle_label, exit_label, NULL);
989 /* Main loop body. */
990 tmp = gfc_trans_code (code->block->next);
991 gfc_add_expr_to_block (&body, tmp);
993 /* Label for cycle statements (if needed). */
994 if (TREE_USED (cycle_label))
996 tmp = build1_v (LABEL_EXPR, cycle_label);
997 gfc_add_expr_to_block (&body, tmp);
1000 /* Increment the loop variable. */
1001 tmp = fold_build2 (PLUS_EXPR, type, dovar, step);
1002 gfc_add_modify (&body, dovar, tmp);
1004 /* End with the loop condition. Loop until countm1 == 0. */
1005 cond = fold_build2 (EQ_EXPR, boolean_type_node, countm1,
1006 build_int_cst (utype, 0));
1007 tmp = build1_v (GOTO_EXPR, exit_label);
1008 tmp = fold_build3 (COND_EXPR, void_type_node,
1009 cond, tmp, build_empty_stmt ());
1010 gfc_add_expr_to_block (&body, tmp);
1012 /* Decrement the loop count. */
1013 tmp = fold_build2 (MINUS_EXPR, utype, countm1, build_int_cst (utype, 1));
1014 gfc_add_modify (&body, countm1, tmp);
1016 /* End of loop body. */
1017 tmp = gfc_finish_block (&body);
1019 /* The for loop itself. */
1020 tmp = build1_v (LOOP_EXPR, tmp);
1021 gfc_add_expr_to_block (&block, tmp);
1023 /* Add the exit label. */
1024 tmp = build1_v (LABEL_EXPR, exit_label);
1025 gfc_add_expr_to_block (&block, tmp);
1027 return gfc_finish_block (&block);
1031 /* Translate the DO WHILE construct.
1044 if (! cond) goto exit_label;
1050 Because the evaluation of the exit condition `cond' may have side
1051 effects, we can't do much for empty loop bodies. The backend optimizers
1052 should be smart enough to eliminate any dead loops. */
1055 gfc_trans_do_while (gfc_code * code)
1063 /* Everything we build here is part of the loop body. */
1064 gfc_start_block (&block);
1066 /* Cycle and exit statements are implemented with gotos. */
1067 cycle_label = gfc_build_label_decl (NULL_TREE);
1068 exit_label = gfc_build_label_decl (NULL_TREE);
1070 /* Put the labels where they can be found later. See gfc_trans_do(). */
1071 code->block->backend_decl = tree_cons (cycle_label, exit_label, NULL);
1073 /* Create a GIMPLE version of the exit condition. */
1074 gfc_init_se (&cond, NULL);
1075 gfc_conv_expr_val (&cond, code->expr);
1076 gfc_add_block_to_block (&block, &cond.pre);
1077 cond.expr = fold_build1 (TRUTH_NOT_EXPR, boolean_type_node, cond.expr);
1079 /* Build "IF (! cond) GOTO exit_label". */
1080 tmp = build1_v (GOTO_EXPR, exit_label);
1081 TREE_USED (exit_label) = 1;
1082 tmp = fold_build3 (COND_EXPR, void_type_node,
1083 cond.expr, tmp, build_empty_stmt ());
1084 gfc_add_expr_to_block (&block, tmp);
1086 /* The main body of the loop. */
1087 tmp = gfc_trans_code (code->block->next);
1088 gfc_add_expr_to_block (&block, tmp);
1090 /* Label for cycle statements (if needed). */
1091 if (TREE_USED (cycle_label))
1093 tmp = build1_v (LABEL_EXPR, cycle_label);
1094 gfc_add_expr_to_block (&block, tmp);
1097 /* End of loop body. */
1098 tmp = gfc_finish_block (&block);
1100 gfc_init_block (&block);
1101 /* Build the loop. */
1102 tmp = build1_v (LOOP_EXPR, tmp);
1103 gfc_add_expr_to_block (&block, tmp);
1105 /* Add the exit label. */
1106 tmp = build1_v (LABEL_EXPR, exit_label);
1107 gfc_add_expr_to_block (&block, tmp);
1109 return gfc_finish_block (&block);
1113 /* Translate the SELECT CASE construct for INTEGER case expressions,
1114 without killing all potential optimizations. The problem is that
1115 Fortran allows unbounded cases, but the back-end does not, so we
1116 need to intercept those before we enter the equivalent SWITCH_EXPR
1119 For example, we translate this,
1122 CASE (:100,101,105:115)
1132 to the GENERIC equivalent,
1136 case (minimum value for typeof(expr) ... 100:
1142 case 200 ... (maximum value for typeof(expr):
1159 gfc_trans_integer_select (gfc_code * code)
1169 gfc_start_block (&block);
1171 /* Calculate the switch expression. */
1172 gfc_init_se (&se, NULL);
1173 gfc_conv_expr_val (&se, code->expr);
1174 gfc_add_block_to_block (&block, &se.pre);
1176 end_label = gfc_build_label_decl (NULL_TREE);
1178 gfc_init_block (&body);
1180 for (c = code->block; c; c = c->block)
1182 for (cp = c->ext.case_list; cp; cp = cp->next)
1187 /* Assume it's the default case. */
1188 low = high = NULL_TREE;
1192 low = gfc_conv_mpz_to_tree (cp->low->value.integer,
1195 /* If there's only a lower bound, set the high bound to the
1196 maximum value of the case expression. */
1198 high = TYPE_MAX_VALUE (TREE_TYPE (se.expr));
1203 /* Three cases are possible here:
1205 1) There is no lower bound, e.g. CASE (:N).
1206 2) There is a lower bound .NE. high bound, that is
1207 a case range, e.g. CASE (N:M) where M>N (we make
1208 sure that M>N during type resolution).
1209 3) There is a lower bound, and it has the same value
1210 as the high bound, e.g. CASE (N:N). This is our
1211 internal representation of CASE(N).
1213 In the first and second case, we need to set a value for
1214 high. In the third case, we don't because the GCC middle
1215 end represents a single case value by just letting high be
1216 a NULL_TREE. We can't do that because we need to be able
1217 to represent unbounded cases. */
1221 && mpz_cmp (cp->low->value.integer,
1222 cp->high->value.integer) != 0))
1223 high = gfc_conv_mpz_to_tree (cp->high->value.integer,
1226 /* Unbounded case. */
1228 low = TYPE_MIN_VALUE (TREE_TYPE (se.expr));
1231 /* Build a label. */
1232 label = gfc_build_label_decl (NULL_TREE);
1234 /* Add this case label.
1235 Add parameter 'label', make it match GCC backend. */
1236 tmp = fold_build3 (CASE_LABEL_EXPR, void_type_node,
1238 gfc_add_expr_to_block (&body, tmp);
1241 /* Add the statements for this case. */
1242 tmp = gfc_trans_code (c->next);
1243 gfc_add_expr_to_block (&body, tmp);
1245 /* Break to the end of the construct. */
1246 tmp = build1_v (GOTO_EXPR, end_label);
1247 gfc_add_expr_to_block (&body, tmp);
1250 tmp = gfc_finish_block (&body);
1251 tmp = build3_v (SWITCH_EXPR, se.expr, tmp, NULL_TREE);
1252 gfc_add_expr_to_block (&block, tmp);
1254 tmp = build1_v (LABEL_EXPR, end_label);
1255 gfc_add_expr_to_block (&block, tmp);
1257 return gfc_finish_block (&block);
1261 /* Translate the SELECT CASE construct for LOGICAL case expressions.
1263 There are only two cases possible here, even though the standard
1264 does allow three cases in a LOGICAL SELECT CASE construct: .TRUE.,
1265 .FALSE., and DEFAULT.
1267 We never generate more than two blocks here. Instead, we always
1268 try to eliminate the DEFAULT case. This way, we can translate this
1269 kind of SELECT construct to a simple
1273 expression in GENERIC. */
1276 gfc_trans_logical_select (gfc_code * code)
1279 gfc_code *t, *f, *d;
1284 /* Assume we don't have any cases at all. */
1287 /* Now see which ones we actually do have. We can have at most two
1288 cases in a single case list: one for .TRUE. and one for .FALSE.
1289 The default case is always separate. If the cases for .TRUE. and
1290 .FALSE. are in the same case list, the block for that case list
1291 always executed, and we don't generate code a COND_EXPR. */
1292 for (c = code->block; c; c = c->block)
1294 for (cp = c->ext.case_list; cp; cp = cp->next)
1298 if (cp->low->value.logical == 0) /* .FALSE. */
1300 else /* if (cp->value.logical != 0), thus .TRUE. */
1308 /* Start a new block. */
1309 gfc_start_block (&block);
1311 /* Calculate the switch expression. We always need to do this
1312 because it may have side effects. */
1313 gfc_init_se (&se, NULL);
1314 gfc_conv_expr_val (&se, code->expr);
1315 gfc_add_block_to_block (&block, &se.pre);
1317 if (t == f && t != NULL)
1319 /* Cases for .TRUE. and .FALSE. are in the same block. Just
1320 translate the code for these cases, append it to the current
1322 gfc_add_expr_to_block (&block, gfc_trans_code (t->next));
1326 tree true_tree, false_tree, stmt;
1328 true_tree = build_empty_stmt ();
1329 false_tree = build_empty_stmt ();
1331 /* If we have a case for .TRUE. and for .FALSE., discard the default case.
1332 Otherwise, if .TRUE. or .FALSE. is missing and there is a default case,
1333 make the missing case the default case. */
1334 if (t != NULL && f != NULL)
1344 /* Translate the code for each of these blocks, and append it to
1345 the current block. */
1347 true_tree = gfc_trans_code (t->next);
1350 false_tree = gfc_trans_code (f->next);
1352 stmt = fold_build3 (COND_EXPR, void_type_node, se.expr,
1353 true_tree, false_tree);
1354 gfc_add_expr_to_block (&block, stmt);
1357 return gfc_finish_block (&block);
1361 /* Translate the SELECT CASE construct for CHARACTER case expressions.
1362 Instead of generating compares and jumps, it is far simpler to
1363 generate a data structure describing the cases in order and call a
1364 library subroutine that locates the right case.
1365 This is particularly true because this is the only case where we
1366 might have to dispose of a temporary.
1367 The library subroutine returns a pointer to jump to or NULL if no
1368 branches are to be taken. */
1371 gfc_trans_character_select (gfc_code *code)
1373 tree init, node, end_label, tmp, type, case_num, label, fndecl;
1374 stmtblock_t block, body;
1380 /* The jump table types are stored in static variables to avoid
1381 constructing them from scratch every single time. */
1382 static tree select_struct[2];
1383 static tree ss_string1[2], ss_string1_len[2];
1384 static tree ss_string2[2], ss_string2_len[2];
1385 static tree ss_target[2];
1387 tree pchartype = gfc_get_pchar_type (code->expr->ts.kind);
1389 if (code->expr->ts.kind == 1)
1391 else if (code->expr->ts.kind == 4)
1396 if (select_struct[k] == NULL)
1398 select_struct[k] = make_node (RECORD_TYPE);
1400 if (code->expr->ts.kind == 1)
1401 TYPE_NAME (select_struct[k]) = get_identifier ("_jump_struct_char1");
1402 else if (code->expr->ts.kind == 4)
1403 TYPE_NAME (select_struct[k]) = get_identifier ("_jump_struct_char4");
1408 #define ADD_FIELD(NAME, TYPE) \
1409 ss_##NAME[k] = gfc_add_field_to_struct \
1410 (&(TYPE_FIELDS (select_struct[k])), select_struct[k], \
1411 get_identifier (stringize(NAME)), TYPE)
1413 ADD_FIELD (string1, pchartype);
1414 ADD_FIELD (string1_len, gfc_charlen_type_node);
1416 ADD_FIELD (string2, pchartype);
1417 ADD_FIELD (string2_len, gfc_charlen_type_node);
1419 ADD_FIELD (target, integer_type_node);
1422 gfc_finish_type (select_struct[k]);
1425 cp = code->block->ext.case_list;
1426 while (cp->left != NULL)
1430 for (d = cp; d; d = d->right)
1433 end_label = gfc_build_label_decl (NULL_TREE);
1435 /* Generate the body */
1436 gfc_start_block (&block);
1437 gfc_init_block (&body);
1439 for (c = code->block; c; c = c->block)
1441 for (d = c->ext.case_list; d; d = d->next)
1443 label = gfc_build_label_decl (NULL_TREE);
1444 tmp = fold_build3 (CASE_LABEL_EXPR, void_type_node,
1445 build_int_cst (NULL_TREE, d->n),
1446 build_int_cst (NULL_TREE, d->n), label);
1447 gfc_add_expr_to_block (&body, tmp);
1450 tmp = gfc_trans_code (c->next);
1451 gfc_add_expr_to_block (&body, tmp);
1453 tmp = build1_v (GOTO_EXPR, end_label);
1454 gfc_add_expr_to_block (&body, tmp);
1457 /* Generate the structure describing the branches */
1460 for(d = cp; d; d = d->right)
1464 gfc_init_se (&se, NULL);
1468 node = tree_cons (ss_string1[k], null_pointer_node, node);
1469 node = tree_cons (ss_string1_len[k], integer_zero_node, node);
1473 gfc_conv_expr_reference (&se, d->low);
1475 node = tree_cons (ss_string1[k], se.expr, node);
1476 node = tree_cons (ss_string1_len[k], se.string_length, node);
1479 if (d->high == NULL)
1481 node = tree_cons (ss_string2[k], null_pointer_node, node);
1482 node = tree_cons (ss_string2_len[k], integer_zero_node, node);
1486 gfc_init_se (&se, NULL);
1487 gfc_conv_expr_reference (&se, d->high);
1489 node = tree_cons (ss_string2[k], se.expr, node);
1490 node = tree_cons (ss_string2_len[k], se.string_length, node);
1493 node = tree_cons (ss_target[k], build_int_cst (integer_type_node, d->n),
1496 tmp = build_constructor_from_list (select_struct[k], nreverse (node));
1497 init = tree_cons (NULL_TREE, tmp, init);
1500 type = build_array_type (select_struct[k],
1501 build_index_type (build_int_cst (NULL_TREE, n-1)));
1503 init = build_constructor_from_list (type, nreverse(init));
1504 TREE_CONSTANT (init) = 1;
1505 TREE_STATIC (init) = 1;
1506 /* Create a static variable to hold the jump table. */
1507 tmp = gfc_create_var (type, "jumptable");
1508 TREE_CONSTANT (tmp) = 1;
1509 TREE_STATIC (tmp) = 1;
1510 TREE_READONLY (tmp) = 1;
1511 DECL_INITIAL (tmp) = init;
1514 /* Build the library call */
1515 init = gfc_build_addr_expr (pvoid_type_node, init);
1517 gfc_init_se (&se, NULL);
1518 gfc_conv_expr_reference (&se, code->expr);
1520 gfc_add_block_to_block (&block, &se.pre);
1522 if (code->expr->ts.kind == 1)
1523 fndecl = gfor_fndecl_select_string;
1524 else if (code->expr->ts.kind == 4)
1525 fndecl = gfor_fndecl_select_string_char4;
1529 tmp = build_call_expr (fndecl, 4, init, build_int_cst (NULL_TREE, n),
1530 se.expr, se.string_length);
1531 case_num = gfc_create_var (integer_type_node, "case_num");
1532 gfc_add_modify (&block, case_num, tmp);
1534 gfc_add_block_to_block (&block, &se.post);
1536 tmp = gfc_finish_block (&body);
1537 tmp = build3_v (SWITCH_EXPR, case_num, tmp, NULL_TREE);
1538 gfc_add_expr_to_block (&block, tmp);
1540 tmp = build1_v (LABEL_EXPR, end_label);
1541 gfc_add_expr_to_block (&block, tmp);
1543 return gfc_finish_block (&block);
1547 /* Translate the three variants of the SELECT CASE construct.
1549 SELECT CASEs with INTEGER case expressions can be translated to an
1550 equivalent GENERIC switch statement, and for LOGICAL case
1551 expressions we build one or two if-else compares.
1553 SELECT CASEs with CHARACTER case expressions are a whole different
1554 story, because they don't exist in GENERIC. So we sort them and
1555 do a binary search at runtime.
1557 Fortran has no BREAK statement, and it does not allow jumps from
1558 one case block to another. That makes things a lot easier for
1562 gfc_trans_select (gfc_code * code)
1564 gcc_assert (code && code->expr);
1566 /* Empty SELECT constructs are legal. */
1567 if (code->block == NULL)
1568 return build_empty_stmt ();
1570 /* Select the correct translation function. */
1571 switch (code->expr->ts.type)
1573 case BT_LOGICAL: return gfc_trans_logical_select (code);
1574 case BT_INTEGER: return gfc_trans_integer_select (code);
1575 case BT_CHARACTER: return gfc_trans_character_select (code);
1577 gfc_internal_error ("gfc_trans_select(): Bad type for case expr.");
1583 /* Traversal function to substitute a replacement symtree if the symbol
1584 in the expression is the same as that passed. f == 2 signals that
1585 that variable itself is not to be checked - only the references.
1586 This group of functions is used when the variable expression in a
1587 FORALL assignment has internal references. For example:
1588 FORALL (i = 1:4) p(p(i)) = i
1589 The only recourse here is to store a copy of 'p' for the index
1592 static gfc_symtree *new_symtree;
1593 static gfc_symtree *old_symtree;
1596 forall_replace (gfc_expr *expr, gfc_symbol *sym, int *f)
1598 if (expr->expr_type != EXPR_VARIABLE)
1603 else if (expr->symtree->n.sym == sym)
1604 expr->symtree = new_symtree;
1610 forall_replace_symtree (gfc_expr *e, gfc_symbol *sym, int f)
1612 gfc_traverse_expr (e, sym, forall_replace, f);
1616 forall_restore (gfc_expr *expr,
1617 gfc_symbol *sym ATTRIBUTE_UNUSED,
1618 int *f ATTRIBUTE_UNUSED)
1620 if (expr->expr_type != EXPR_VARIABLE)
1623 if (expr->symtree == new_symtree)
1624 expr->symtree = old_symtree;
1630 forall_restore_symtree (gfc_expr *e)
1632 gfc_traverse_expr (e, NULL, forall_restore, 0);
1636 forall_make_variable_temp (gfc_code *c, stmtblock_t *pre, stmtblock_t *post)
1641 gfc_symbol *new_sym;
1642 gfc_symbol *old_sym;
1646 /* Build a copy of the lvalue. */
1647 old_symtree = c->expr->symtree;
1648 old_sym = old_symtree->n.sym;
1649 e = gfc_lval_expr_from_sym (old_sym);
1650 if (old_sym->attr.dimension)
1652 gfc_init_se (&tse, NULL);
1653 gfc_conv_subref_array_arg (&tse, e, 0, INTENT_IN);
1654 gfc_add_block_to_block (pre, &tse.pre);
1655 gfc_add_block_to_block (post, &tse.post);
1656 tse.expr = build_fold_indirect_ref (tse.expr);
1658 if (e->ts.type != BT_CHARACTER)
1660 /* Use the variable offset for the temporary. */
1661 tmp = gfc_conv_descriptor_offset (tse.expr);
1662 gfc_add_modify (pre, tmp,
1663 gfc_conv_array_offset (old_sym->backend_decl));
1668 gfc_init_se (&tse, NULL);
1669 gfc_init_se (&rse, NULL);
1670 gfc_conv_expr (&rse, e);
1671 if (e->ts.type == BT_CHARACTER)
1673 tse.string_length = rse.string_length;
1674 tmp = gfc_get_character_type_len (gfc_default_character_kind,
1676 tse.expr = gfc_conv_string_tmp (&tse, build_pointer_type (tmp),
1678 gfc_add_block_to_block (pre, &tse.pre);
1679 gfc_add_block_to_block (post, &tse.post);
1683 tmp = gfc_typenode_for_spec (&e->ts);
1684 tse.expr = gfc_create_var (tmp, "temp");
1687 tmp = gfc_trans_scalar_assign (&tse, &rse, e->ts, true,
1688 e->expr_type == EXPR_VARIABLE);
1689 gfc_add_expr_to_block (pre, tmp);
1693 /* Create a new symbol to represent the lvalue. */
1694 new_sym = gfc_new_symbol (old_sym->name, NULL);
1695 new_sym->ts = old_sym->ts;
1696 new_sym->attr.referenced = 1;
1697 new_sym->attr.dimension = old_sym->attr.dimension;
1698 new_sym->attr.flavor = old_sym->attr.flavor;
1700 /* Use the temporary as the backend_decl. */
1701 new_sym->backend_decl = tse.expr;
1703 /* Create a fake symtree for it. */
1705 new_symtree = gfc_new_symtree (&root, old_sym->name);
1706 new_symtree->n.sym = new_sym;
1707 gcc_assert (new_symtree == root);
1709 /* Go through the expression reference replacing the old_symtree
1711 forall_replace_symtree (c->expr, old_sym, 2);
1713 /* Now we have made this temporary, we might as well use it for
1714 the right hand side. */
1715 forall_replace_symtree (c->expr2, old_sym, 1);
1719 /* Handles dependencies in forall assignments. */
1721 check_forall_dependencies (gfc_code *c, stmtblock_t *pre, stmtblock_t *post)
1728 lsym = c->expr->symtree->n.sym;
1729 need_temp = gfc_check_dependency (c->expr, c->expr2, 0);
1731 /* Now check for dependencies within the 'variable'
1732 expression itself. These are treated by making a complete
1733 copy of variable and changing all the references to it
1734 point to the copy instead. Note that the shallow copy of
1735 the variable will not suffice for derived types with
1736 pointer components. We therefore leave these to their
1738 if (lsym->ts.type == BT_DERIVED
1739 && lsym->ts.derived->attr.pointer_comp)
1743 if (find_forall_index (c->expr, lsym, 2) == SUCCESS)
1745 forall_make_variable_temp (c, pre, post);
1749 /* Substrings with dependencies are treated in the same
1751 if (c->expr->ts.type == BT_CHARACTER
1753 && c->expr2->expr_type == EXPR_VARIABLE
1754 && lsym == c->expr2->symtree->n.sym)
1756 for (lref = c->expr->ref; lref; lref = lref->next)
1757 if (lref->type == REF_SUBSTRING)
1759 for (rref = c->expr2->ref; rref; rref = rref->next)
1760 if (rref->type == REF_SUBSTRING)
1764 && gfc_dep_compare_expr (rref->u.ss.start, lref->u.ss.start) < 0)
1766 forall_make_variable_temp (c, pre, post);
1775 cleanup_forall_symtrees (gfc_code *c)
1777 forall_restore_symtree (c->expr);
1778 forall_restore_symtree (c->expr2);
1779 gfc_free (new_symtree->n.sym);
1780 gfc_free (new_symtree);
1784 /* Generate the loops for a FORALL block, specified by FORALL_TMP. BODY
1785 is the contents of the FORALL block/stmt to be iterated. MASK_FLAG
1786 indicates whether we should generate code to test the FORALLs mask
1787 array. OUTER is the loop header to be used for initializing mask
1790 The generated loop format is:
1791 count = (end - start + step) / step
1804 gfc_trans_forall_loop (forall_info *forall_tmp, tree body,
1805 int mask_flag, stmtblock_t *outer)
1813 tree var, start, end, step;
1816 /* Initialize the mask index outside the FORALL nest. */
1817 if (mask_flag && forall_tmp->mask)
1818 gfc_add_modify (outer, forall_tmp->maskindex, gfc_index_zero_node);
1820 iter = forall_tmp->this_loop;
1821 nvar = forall_tmp->nvar;
1822 for (n = 0; n < nvar; n++)
1825 start = iter->start;
1829 exit_label = gfc_build_label_decl (NULL_TREE);
1830 TREE_USED (exit_label) = 1;
1832 /* The loop counter. */
1833 count = gfc_create_var (TREE_TYPE (var), "count");
1835 /* The body of the loop. */
1836 gfc_init_block (&block);
1838 /* The exit condition. */
1839 cond = fold_build2 (LE_EXPR, boolean_type_node,
1840 count, build_int_cst (TREE_TYPE (count), 0));
1841 tmp = build1_v (GOTO_EXPR, exit_label);
1842 tmp = fold_build3 (COND_EXPR, void_type_node,
1843 cond, tmp, build_empty_stmt ());
1844 gfc_add_expr_to_block (&block, tmp);
1846 /* The main loop body. */
1847 gfc_add_expr_to_block (&block, body);
1849 /* Increment the loop variable. */
1850 tmp = fold_build2 (PLUS_EXPR, TREE_TYPE (var), var, step);
1851 gfc_add_modify (&block, var, tmp);
1853 /* Advance to the next mask element. Only do this for the
1855 if (n == 0 && mask_flag && forall_tmp->mask)
1857 tree maskindex = forall_tmp->maskindex;
1858 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1859 maskindex, gfc_index_one_node);
1860 gfc_add_modify (&block, maskindex, tmp);
1863 /* Decrement the loop counter. */
1864 tmp = fold_build2 (MINUS_EXPR, TREE_TYPE (var), count,
1865 build_int_cst (TREE_TYPE (var), 1));
1866 gfc_add_modify (&block, count, tmp);
1868 body = gfc_finish_block (&block);
1870 /* Loop var initialization. */
1871 gfc_init_block (&block);
1872 gfc_add_modify (&block, var, start);
1875 /* Initialize the loop counter. */
1876 tmp = fold_build2 (MINUS_EXPR, TREE_TYPE (var), step, start);
1877 tmp = fold_build2 (PLUS_EXPR, TREE_TYPE (var), end, tmp);
1878 tmp = fold_build2 (TRUNC_DIV_EXPR, TREE_TYPE (var), tmp, step);
1879 gfc_add_modify (&block, count, tmp);
1881 /* The loop expression. */
1882 tmp = build1_v (LOOP_EXPR, body);
1883 gfc_add_expr_to_block (&block, tmp);
1885 /* The exit label. */
1886 tmp = build1_v (LABEL_EXPR, exit_label);
1887 gfc_add_expr_to_block (&block, tmp);
1889 body = gfc_finish_block (&block);
1896 /* Generate the body and loops according to MASK_FLAG. If MASK_FLAG
1897 is nonzero, the body is controlled by all masks in the forall nest.
1898 Otherwise, the innermost loop is not controlled by it's mask. This
1899 is used for initializing that mask. */
1902 gfc_trans_nested_forall_loop (forall_info * nested_forall_info, tree body,
1907 forall_info *forall_tmp;
1908 tree mask, maskindex;
1910 gfc_start_block (&header);
1912 forall_tmp = nested_forall_info;
1913 while (forall_tmp != NULL)
1915 /* Generate body with masks' control. */
1918 mask = forall_tmp->mask;
1919 maskindex = forall_tmp->maskindex;
1921 /* If a mask was specified make the assignment conditional. */
1924 tmp = gfc_build_array_ref (mask, maskindex, NULL);
1925 body = build3_v (COND_EXPR, tmp, body, build_empty_stmt ());
1928 body = gfc_trans_forall_loop (forall_tmp, body, mask_flag, &header);
1929 forall_tmp = forall_tmp->prev_nest;
1933 gfc_add_expr_to_block (&header, body);
1934 return gfc_finish_block (&header);
1938 /* Allocate data for holding a temporary array. Returns either a local
1939 temporary array or a pointer variable. */
1942 gfc_do_allocate (tree bytesize, tree size, tree * pdata, stmtblock_t * pblock,
1949 if (INTEGER_CST_P (size))
1951 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, size,
1952 gfc_index_one_node);
1957 type = build_range_type (gfc_array_index_type, gfc_index_zero_node, tmp);
1958 type = build_array_type (elem_type, type);
1959 if (gfc_can_put_var_on_stack (bytesize))
1961 gcc_assert (INTEGER_CST_P (size));
1962 tmpvar = gfc_create_var (type, "temp");
1967 tmpvar = gfc_create_var (build_pointer_type (type), "temp");
1968 *pdata = convert (pvoid_type_node, tmpvar);
1970 tmp = gfc_call_malloc (pblock, TREE_TYPE (tmpvar), bytesize);
1971 gfc_add_modify (pblock, tmpvar, tmp);
1977 /* Generate codes to copy the temporary to the actual lhs. */
1980 generate_loop_for_temp_to_lhs (gfc_expr *expr, tree tmp1, tree count3,
1981 tree count1, tree wheremask, bool invert)
1985 stmtblock_t block, body;
1991 lss = gfc_walk_expr (expr);
1993 if (lss == gfc_ss_terminator)
1995 gfc_start_block (&block);
1997 gfc_init_se (&lse, NULL);
1999 /* Translate the expression. */
2000 gfc_conv_expr (&lse, expr);
2002 /* Form the expression for the temporary. */
2003 tmp = gfc_build_array_ref (tmp1, count1, NULL);
2005 /* Use the scalar assignment as is. */
2006 gfc_add_block_to_block (&block, &lse.pre);
2007 gfc_add_modify (&block, lse.expr, tmp);
2008 gfc_add_block_to_block (&block, &lse.post);
2010 /* Increment the count1. */
2011 tmp = fold_build2 (PLUS_EXPR, TREE_TYPE (count1), count1,
2012 gfc_index_one_node);
2013 gfc_add_modify (&block, count1, tmp);
2015 tmp = gfc_finish_block (&block);
2019 gfc_start_block (&block);
2021 gfc_init_loopinfo (&loop1);
2022 gfc_init_se (&rse, NULL);
2023 gfc_init_se (&lse, NULL);
2025 /* Associate the lss with the loop. */
2026 gfc_add_ss_to_loop (&loop1, lss);
2028 /* Calculate the bounds of the scalarization. */
2029 gfc_conv_ss_startstride (&loop1);
2030 /* Setup the scalarizing loops. */
2031 gfc_conv_loop_setup (&loop1, &expr->where);
2033 gfc_mark_ss_chain_used (lss, 1);
2035 /* Start the scalarized loop body. */
2036 gfc_start_scalarized_body (&loop1, &body);
2038 /* Setup the gfc_se structures. */
2039 gfc_copy_loopinfo_to_se (&lse, &loop1);
2042 /* Form the expression of the temporary. */
2043 if (lss != gfc_ss_terminator)
2044 rse.expr = gfc_build_array_ref (tmp1, count1, NULL);
2045 /* Translate expr. */
2046 gfc_conv_expr (&lse, expr);
2048 /* Use the scalar assignment. */
2049 rse.string_length = lse.string_length;
2050 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, false);
2052 /* Form the mask expression according to the mask tree list. */
2055 wheremaskexpr = gfc_build_array_ref (wheremask, count3, NULL);
2057 wheremaskexpr = fold_build1 (TRUTH_NOT_EXPR,
2058 TREE_TYPE (wheremaskexpr),
2060 tmp = fold_build3 (COND_EXPR, void_type_node,
2061 wheremaskexpr, tmp, build_empty_stmt ());
2064 gfc_add_expr_to_block (&body, tmp);
2066 /* Increment count1. */
2067 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2068 count1, gfc_index_one_node);
2069 gfc_add_modify (&body, count1, tmp);
2071 /* Increment count3. */
2074 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2075 count3, gfc_index_one_node);
2076 gfc_add_modify (&body, count3, tmp);
2079 /* Generate the copying loops. */
2080 gfc_trans_scalarizing_loops (&loop1, &body);
2081 gfc_add_block_to_block (&block, &loop1.pre);
2082 gfc_add_block_to_block (&block, &loop1.post);
2083 gfc_cleanup_loop (&loop1);
2085 tmp = gfc_finish_block (&block);
2091 /* Generate codes to copy rhs to the temporary. TMP1 is the address of
2092 temporary, LSS and RSS are formed in function compute_inner_temp_size(),
2093 and should not be freed. WHEREMASK is the conditional execution mask
2094 whose sense may be inverted by INVERT. */
2097 generate_loop_for_rhs_to_temp (gfc_expr *expr2, tree tmp1, tree count3,
2098 tree count1, gfc_ss *lss, gfc_ss *rss,
2099 tree wheremask, bool invert)
2101 stmtblock_t block, body1;
2108 gfc_start_block (&block);
2110 gfc_init_se (&rse, NULL);
2111 gfc_init_se (&lse, NULL);
2113 if (lss == gfc_ss_terminator)
2115 gfc_init_block (&body1);
2116 gfc_conv_expr (&rse, expr2);
2117 lse.expr = gfc_build_array_ref (tmp1, count1, NULL);
2121 /* Initialize the loop. */
2122 gfc_init_loopinfo (&loop);
2124 /* We may need LSS to determine the shape of the expression. */
2125 gfc_add_ss_to_loop (&loop, lss);
2126 gfc_add_ss_to_loop (&loop, rss);
2128 gfc_conv_ss_startstride (&loop);
2129 gfc_conv_loop_setup (&loop, &expr2->where);
2131 gfc_mark_ss_chain_used (rss, 1);
2132 /* Start the loop body. */
2133 gfc_start_scalarized_body (&loop, &body1);
2135 /* Translate the expression. */
2136 gfc_copy_loopinfo_to_se (&rse, &loop);
2138 gfc_conv_expr (&rse, expr2);
2140 /* Form the expression of the temporary. */
2141 lse.expr = gfc_build_array_ref (tmp1, count1, NULL);
2144 /* Use the scalar assignment. */
2145 lse.string_length = rse.string_length;
2146 tmp = gfc_trans_scalar_assign (&lse, &rse, expr2->ts, true,
2147 expr2->expr_type == EXPR_VARIABLE);
2149 /* Form the mask expression according to the mask tree list. */
2152 wheremaskexpr = gfc_build_array_ref (wheremask, count3, NULL);
2154 wheremaskexpr = fold_build1 (TRUTH_NOT_EXPR,
2155 TREE_TYPE (wheremaskexpr),
2157 tmp = fold_build3 (COND_EXPR, void_type_node,
2158 wheremaskexpr, tmp, build_empty_stmt ());
2161 gfc_add_expr_to_block (&body1, tmp);
2163 if (lss == gfc_ss_terminator)
2165 gfc_add_block_to_block (&block, &body1);
2167 /* Increment count1. */
2168 tmp = fold_build2 (PLUS_EXPR, TREE_TYPE (count1), count1,
2169 gfc_index_one_node);
2170 gfc_add_modify (&block, count1, tmp);
2174 /* Increment count1. */
2175 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2176 count1, gfc_index_one_node);
2177 gfc_add_modify (&body1, count1, tmp);
2179 /* Increment count3. */
2182 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2183 count3, gfc_index_one_node);
2184 gfc_add_modify (&body1, count3, tmp);
2187 /* Generate the copying loops. */
2188 gfc_trans_scalarizing_loops (&loop, &body1);
2190 gfc_add_block_to_block (&block, &loop.pre);
2191 gfc_add_block_to_block (&block, &loop.post);
2193 gfc_cleanup_loop (&loop);
2194 /* TODO: Reuse lss and rss when copying temp->lhs. Need to be careful
2195 as tree nodes in SS may not be valid in different scope. */
2198 tmp = gfc_finish_block (&block);
2203 /* Calculate the size of temporary needed in the assignment inside forall.
2204 LSS and RSS are filled in this function. */
2207 compute_inner_temp_size (gfc_expr *expr1, gfc_expr *expr2,
2208 stmtblock_t * pblock,
2209 gfc_ss **lss, gfc_ss **rss)
2217 *lss = gfc_walk_expr (expr1);
2220 size = gfc_index_one_node;
2221 if (*lss != gfc_ss_terminator)
2223 gfc_init_loopinfo (&loop);
2225 /* Walk the RHS of the expression. */
2226 *rss = gfc_walk_expr (expr2);
2227 if (*rss == gfc_ss_terminator)
2229 /* The rhs is scalar. Add a ss for the expression. */
2230 *rss = gfc_get_ss ();
2231 (*rss)->next = gfc_ss_terminator;
2232 (*rss)->type = GFC_SS_SCALAR;
2233 (*rss)->expr = expr2;
2236 /* Associate the SS with the loop. */
2237 gfc_add_ss_to_loop (&loop, *lss);
2238 /* We don't actually need to add the rhs at this point, but it might
2239 make guessing the loop bounds a bit easier. */
2240 gfc_add_ss_to_loop (&loop, *rss);
2242 /* We only want the shape of the expression, not rest of the junk
2243 generated by the scalarizer. */
2244 loop.array_parameter = 1;
2246 /* Calculate the bounds of the scalarization. */
2247 save_flag = flag_bounds_check;
2248 flag_bounds_check = 0;
2249 gfc_conv_ss_startstride (&loop);
2250 flag_bounds_check = save_flag;
2251 gfc_conv_loop_setup (&loop, &expr2->where);
2253 /* Figure out how many elements we need. */
2254 for (i = 0; i < loop.dimen; i++)
2256 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
2257 gfc_index_one_node, loop.from[i]);
2258 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2260 size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
2262 gfc_add_block_to_block (pblock, &loop.pre);
2263 size = gfc_evaluate_now (size, pblock);
2264 gfc_add_block_to_block (pblock, &loop.post);
2266 /* TODO: write a function that cleans up a loopinfo without freeing
2267 the SS chains. Currently a NOP. */
2274 /* Calculate the overall iterator number of the nested forall construct.
2275 This routine actually calculates the number of times the body of the
2276 nested forall specified by NESTED_FORALL_INFO is executed and multiplies
2277 that by the expression INNER_SIZE. The BLOCK argument specifies the
2278 block in which to calculate the result, and the optional INNER_SIZE_BODY
2279 argument contains any statements that need to executed (inside the loop)
2280 to initialize or calculate INNER_SIZE. */
2283 compute_overall_iter_number (forall_info *nested_forall_info, tree inner_size,
2284 stmtblock_t *inner_size_body, stmtblock_t *block)
2286 forall_info *forall_tmp = nested_forall_info;
2290 /* We can eliminate the innermost unconditional loops with constant
2292 if (INTEGER_CST_P (inner_size))
2295 && !forall_tmp->mask
2296 && INTEGER_CST_P (forall_tmp->size))
2298 inner_size = fold_build2 (MULT_EXPR, gfc_array_index_type,
2299 inner_size, forall_tmp->size);
2300 forall_tmp = forall_tmp->prev_nest;
2303 /* If there are no loops left, we have our constant result. */
2308 /* Otherwise, create a temporary variable to compute the result. */
2309 number = gfc_create_var (gfc_array_index_type, "num");
2310 gfc_add_modify (block, number, gfc_index_zero_node);
2312 gfc_start_block (&body);
2313 if (inner_size_body)
2314 gfc_add_block_to_block (&body, inner_size_body);
2316 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2317 number, inner_size);
2320 gfc_add_modify (&body, number, tmp);
2321 tmp = gfc_finish_block (&body);
2323 /* Generate loops. */
2324 if (forall_tmp != NULL)
2325 tmp = gfc_trans_nested_forall_loop (forall_tmp, tmp, 1);
2327 gfc_add_expr_to_block (block, tmp);
2333 /* Allocate temporary for forall construct. SIZE is the size of temporary
2334 needed. PTEMP1 is returned for space free. */
2337 allocate_temp_for_forall_nest_1 (tree type, tree size, stmtblock_t * block,
2344 unit = fold_convert (gfc_array_index_type, TYPE_SIZE_UNIT (type));
2345 if (!integer_onep (unit))
2346 bytesize = fold_build2 (MULT_EXPR, gfc_array_index_type, size, unit);
2351 tmp = gfc_do_allocate (bytesize, size, ptemp1, block, type);
2354 tmp = build_fold_indirect_ref (tmp);
2359 /* Allocate temporary for forall construct according to the information in
2360 nested_forall_info. INNER_SIZE is the size of temporary needed in the
2361 assignment inside forall. PTEMP1 is returned for space free. */
2364 allocate_temp_for_forall_nest (forall_info * nested_forall_info, tree type,
2365 tree inner_size, stmtblock_t * inner_size_body,
2366 stmtblock_t * block, tree * ptemp1)
2370 /* Calculate the total size of temporary needed in forall construct. */
2371 size = compute_overall_iter_number (nested_forall_info, inner_size,
2372 inner_size_body, block);
2374 return allocate_temp_for_forall_nest_1 (type, size, block, ptemp1);
2378 /* Handle assignments inside forall which need temporary.
2380 forall (i=start:end:stride; maskexpr)
2383 (where e,f<i> are arbitrary expressions possibly involving i
2384 and there is a dependency between e<i> and f<i>)
2386 masktmp(:) = maskexpr(:)
2391 for (i = start; i <= end; i += stride)
2395 for (i = start; i <= end; i += stride)
2397 if (masktmp[maskindex++])
2398 tmp[count1++] = f<i>
2402 for (i = start; i <= end; i += stride)
2404 if (masktmp[maskindex++])
2405 e<i> = tmp[count1++]
2410 gfc_trans_assign_need_temp (gfc_expr * expr1, gfc_expr * expr2,
2411 tree wheremask, bool invert,
2412 forall_info * nested_forall_info,
2413 stmtblock_t * block)
2421 stmtblock_t inner_size_body;
2423 /* Create vars. count1 is the current iterator number of the nested
2425 count1 = gfc_create_var (gfc_array_index_type, "count1");
2427 /* Count is the wheremask index. */
2430 count = gfc_create_var (gfc_array_index_type, "count");
2431 gfc_add_modify (block, count, gfc_index_zero_node);
2436 /* Initialize count1. */
2437 gfc_add_modify (block, count1, gfc_index_zero_node);
2439 /* Calculate the size of temporary needed in the assignment. Return loop, lss
2440 and rss which are used in function generate_loop_for_rhs_to_temp(). */
2441 gfc_init_block (&inner_size_body);
2442 inner_size = compute_inner_temp_size (expr1, expr2, &inner_size_body,
2445 /* The type of LHS. Used in function allocate_temp_for_forall_nest */
2446 if (expr1->ts.type == BT_CHARACTER && expr1->ts.cl->length)
2448 if (!expr1->ts.cl->backend_decl)
2451 gfc_init_se (&tse, NULL);
2452 gfc_conv_expr (&tse, expr1->ts.cl->length);
2453 expr1->ts.cl->backend_decl = tse.expr;
2455 type = gfc_get_character_type_len (gfc_default_character_kind,
2456 expr1->ts.cl->backend_decl);
2459 type = gfc_typenode_for_spec (&expr1->ts);
2461 /* Allocate temporary for nested forall construct according to the
2462 information in nested_forall_info and inner_size. */
2463 tmp1 = allocate_temp_for_forall_nest (nested_forall_info, type, inner_size,
2464 &inner_size_body, block, &ptemp1);
2466 /* Generate codes to copy rhs to the temporary . */
2467 tmp = generate_loop_for_rhs_to_temp (expr2, tmp1, count, count1, lss, rss,
2470 /* Generate body and loops according to the information in
2471 nested_forall_info. */
2472 tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1);
2473 gfc_add_expr_to_block (block, tmp);
2476 gfc_add_modify (block, count1, gfc_index_zero_node);
2480 gfc_add_modify (block, count, gfc_index_zero_node);
2482 /* Generate codes to copy the temporary to lhs. */
2483 tmp = generate_loop_for_temp_to_lhs (expr1, tmp1, count, count1,
2486 /* Generate body and loops according to the information in
2487 nested_forall_info. */
2488 tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1);
2489 gfc_add_expr_to_block (block, tmp);
2493 /* Free the temporary. */
2494 tmp = gfc_call_free (ptemp1);
2495 gfc_add_expr_to_block (block, tmp);
2500 /* Translate pointer assignment inside FORALL which need temporary. */
2503 gfc_trans_pointer_assign_need_temp (gfc_expr * expr1, gfc_expr * expr2,
2504 forall_info * nested_forall_info,
2505 stmtblock_t * block)
2519 tree tmp, tmp1, ptemp1;
2521 count = gfc_create_var (gfc_array_index_type, "count");
2522 gfc_add_modify (block, count, gfc_index_zero_node);
2524 inner_size = integer_one_node;
2525 lss = gfc_walk_expr (expr1);
2526 rss = gfc_walk_expr (expr2);
2527 if (lss == gfc_ss_terminator)
2529 type = gfc_typenode_for_spec (&expr1->ts);
2530 type = build_pointer_type (type);
2532 /* Allocate temporary for nested forall construct according to the
2533 information in nested_forall_info and inner_size. */
2534 tmp1 = allocate_temp_for_forall_nest (nested_forall_info, type,
2535 inner_size, NULL, block, &ptemp1);
2536 gfc_start_block (&body);
2537 gfc_init_se (&lse, NULL);
2538 lse.expr = gfc_build_array_ref (tmp1, count, NULL);
2539 gfc_init_se (&rse, NULL);
2540 rse.want_pointer = 1;
2541 gfc_conv_expr (&rse, expr2);
2542 gfc_add_block_to_block (&body, &rse.pre);
2543 gfc_add_modify (&body, lse.expr,
2544 fold_convert (TREE_TYPE (lse.expr), rse.expr));
2545 gfc_add_block_to_block (&body, &rse.post);
2547 /* Increment count. */
2548 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2549 count, gfc_index_one_node);
2550 gfc_add_modify (&body, count, tmp);
2552 tmp = gfc_finish_block (&body);
2554 /* Generate body and loops according to the information in
2555 nested_forall_info. */
2556 tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1);
2557 gfc_add_expr_to_block (block, tmp);
2560 gfc_add_modify (block, count, gfc_index_zero_node);
2562 gfc_start_block (&body);
2563 gfc_init_se (&lse, NULL);
2564 gfc_init_se (&rse, NULL);
2565 rse.expr = gfc_build_array_ref (tmp1, count, NULL);
2566 lse.want_pointer = 1;
2567 gfc_conv_expr (&lse, expr1);
2568 gfc_add_block_to_block (&body, &lse.pre);
2569 gfc_add_modify (&body, lse.expr, rse.expr);
2570 gfc_add_block_to_block (&body, &lse.post);
2571 /* Increment count. */
2572 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2573 count, gfc_index_one_node);
2574 gfc_add_modify (&body, count, tmp);
2575 tmp = gfc_finish_block (&body);
2577 /* Generate body and loops according to the information in
2578 nested_forall_info. */
2579 tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1);
2580 gfc_add_expr_to_block (block, tmp);
2584 gfc_init_loopinfo (&loop);
2586 /* Associate the SS with the loop. */
2587 gfc_add_ss_to_loop (&loop, rss);
2589 /* Setup the scalarizing loops and bounds. */
2590 gfc_conv_ss_startstride (&loop);
2592 gfc_conv_loop_setup (&loop, &expr2->where);
2594 info = &rss->data.info;
2595 desc = info->descriptor;
2597 /* Make a new descriptor. */
2598 parmtype = gfc_get_element_type (TREE_TYPE (desc));
2599 parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen,
2600 loop.from, loop.to, 1,
2603 /* Allocate temporary for nested forall construct. */
2604 tmp1 = allocate_temp_for_forall_nest (nested_forall_info, parmtype,
2605 inner_size, NULL, block, &ptemp1);
2606 gfc_start_block (&body);
2607 gfc_init_se (&lse, NULL);
2608 lse.expr = gfc_build_array_ref (tmp1, count, NULL);
2609 lse.direct_byref = 1;
2610 rss = gfc_walk_expr (expr2);
2611 gfc_conv_expr_descriptor (&lse, expr2, rss);
2613 gfc_add_block_to_block (&body, &lse.pre);
2614 gfc_add_block_to_block (&body, &lse.post);
2616 /* Increment count. */
2617 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2618 count, gfc_index_one_node);
2619 gfc_add_modify (&body, count, tmp);
2621 tmp = gfc_finish_block (&body);
2623 /* Generate body and loops according to the information in
2624 nested_forall_info. */
2625 tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1);
2626 gfc_add_expr_to_block (block, tmp);
2629 gfc_add_modify (block, count, gfc_index_zero_node);
2631 parm = gfc_build_array_ref (tmp1, count, NULL);
2632 lss = gfc_walk_expr (expr1);
2633 gfc_init_se (&lse, NULL);
2634 gfc_conv_expr_descriptor (&lse, expr1, lss);
2635 gfc_add_modify (&lse.pre, lse.expr, parm);
2636 gfc_start_block (&body);
2637 gfc_add_block_to_block (&body, &lse.pre);
2638 gfc_add_block_to_block (&body, &lse.post);
2640 /* Increment count. */
2641 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2642 count, gfc_index_one_node);
2643 gfc_add_modify (&body, count, tmp);
2645 tmp = gfc_finish_block (&body);
2647 tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1);
2648 gfc_add_expr_to_block (block, tmp);
2650 /* Free the temporary. */
2653 tmp = gfc_call_free (ptemp1);
2654 gfc_add_expr_to_block (block, tmp);
2659 /* FORALL and WHERE statements are really nasty, especially when you nest
2660 them. All the rhs of a forall assignment must be evaluated before the
2661 actual assignments are performed. Presumably this also applies to all the
2662 assignments in an inner where statement. */
2664 /* Generate code for a FORALL statement. Any temporaries are allocated as a
2665 linear array, relying on the fact that we process in the same order in all
2668 forall (i=start:end:stride; maskexpr)
2672 (where e,f,g,h<i> are arbitrary expressions possibly involving i)
2674 count = ((end + 1 - start) / stride)
2675 masktmp(:) = maskexpr(:)
2678 for (i = start; i <= end; i += stride)
2680 if (masktmp[maskindex++])
2684 for (i = start; i <= end; i += stride)
2686 if (masktmp[maskindex++])
2690 Note that this code only works when there are no dependencies.
2691 Forall loop with array assignments and data dependencies are a real pain,
2692 because the size of the temporary cannot always be determined before the
2693 loop is executed. This problem is compounded by the presence of nested
2698 gfc_trans_forall_1 (gfc_code * code, forall_info * nested_forall_info)
2718 gfc_forall_iterator *fa;
2721 gfc_saved_var *saved_vars;
2722 iter_info *this_forall;
2726 /* Do nothing if the mask is false. */
2728 && code->expr->expr_type == EXPR_CONSTANT
2729 && !code->expr->value.logical)
2730 return build_empty_stmt ();
2733 /* Count the FORALL index number. */
2734 for (fa = code->ext.forall_iterator; fa; fa = fa->next)
2738 /* Allocate the space for var, start, end, step, varexpr. */
2739 var = (tree *) gfc_getmem (nvar * sizeof (tree));
2740 start = (tree *) gfc_getmem (nvar * sizeof (tree));
2741 end = (tree *) gfc_getmem (nvar * sizeof (tree));
2742 step = (tree *) gfc_getmem (nvar * sizeof (tree));
2743 varexpr = (gfc_expr **) gfc_getmem (nvar * sizeof (gfc_expr *));
2744 saved_vars = (gfc_saved_var *) gfc_getmem (nvar * sizeof (gfc_saved_var));
2746 /* Allocate the space for info. */
2747 info = (forall_info *) gfc_getmem (sizeof (forall_info));
2749 gfc_start_block (&pre);
2750 gfc_init_block (&post);
2751 gfc_init_block (&block);
2754 for (fa = code->ext.forall_iterator; fa; fa = fa->next)
2756 gfc_symbol *sym = fa->var->symtree->n.sym;
2758 /* Allocate space for this_forall. */
2759 this_forall = (iter_info *) gfc_getmem (sizeof (iter_info));
2761 /* Create a temporary variable for the FORALL index. */
2762 tmp = gfc_typenode_for_spec (&sym->ts);
2763 var[n] = gfc_create_var (tmp, sym->name);
2764 gfc_shadow_sym (sym, var[n], &saved_vars[n]);
2766 /* Record it in this_forall. */
2767 this_forall->var = var[n];
2769 /* Replace the index symbol's backend_decl with the temporary decl. */
2770 sym->backend_decl = var[n];
2772 /* Work out the start, end and stride for the loop. */
2773 gfc_init_se (&se, NULL);
2774 gfc_conv_expr_val (&se, fa->start);
2775 /* Record it in this_forall. */
2776 this_forall->start = se.expr;
2777 gfc_add_block_to_block (&block, &se.pre);
2780 gfc_init_se (&se, NULL);
2781 gfc_conv_expr_val (&se, fa->end);
2782 /* Record it in this_forall. */
2783 this_forall->end = se.expr;
2784 gfc_make_safe_expr (&se);
2785 gfc_add_block_to_block (&block, &se.pre);
2788 gfc_init_se (&se, NULL);
2789 gfc_conv_expr_val (&se, fa->stride);
2790 /* Record it in this_forall. */
2791 this_forall->step = se.expr;
2792 gfc_make_safe_expr (&se);
2793 gfc_add_block_to_block (&block, &se.pre);
2796 /* Set the NEXT field of this_forall to NULL. */
2797 this_forall->next = NULL;
2798 /* Link this_forall to the info construct. */
2799 if (info->this_loop)
2801 iter_info *iter_tmp = info->this_loop;
2802 while (iter_tmp->next != NULL)
2803 iter_tmp = iter_tmp->next;
2804 iter_tmp->next = this_forall;
2807 info->this_loop = this_forall;
2813 /* Calculate the size needed for the current forall level. */
2814 size = gfc_index_one_node;
2815 for (n = 0; n < nvar; n++)
2817 /* size = (end + step - start) / step. */
2818 tmp = fold_build2 (MINUS_EXPR, TREE_TYPE (start[n]),
2820 tmp = fold_build2 (PLUS_EXPR, TREE_TYPE (end[n]), end[n], tmp);
2822 tmp = fold_build2 (FLOOR_DIV_EXPR, TREE_TYPE (tmp), tmp, step[n]);
2823 tmp = convert (gfc_array_index_type, tmp);
2825 size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
2828 /* Record the nvar and size of current forall level. */
2834 /* If the mask is .true., consider the FORALL unconditional. */
2835 if (code->expr->expr_type == EXPR_CONSTANT
2836 && code->expr->value.logical)
2844 /* First we need to allocate the mask. */
2847 /* As the mask array can be very big, prefer compact boolean types. */
2848 tree mask_type = gfc_get_logical_type (gfc_logical_kinds[0].kind);
2849 mask = allocate_temp_for_forall_nest (nested_forall_info, mask_type,
2850 size, NULL, &block, &pmask);
2851 maskindex = gfc_create_var_np (gfc_array_index_type, "mi");
2853 /* Record them in the info structure. */
2854 info->maskindex = maskindex;
2859 /* No mask was specified. */
2860 maskindex = NULL_TREE;
2861 mask = pmask = NULL_TREE;
2864 /* Link the current forall level to nested_forall_info. */
2865 info->prev_nest = nested_forall_info;
2866 nested_forall_info = info;
2868 /* Copy the mask into a temporary variable if required.
2869 For now we assume a mask temporary is needed. */
2872 /* As the mask array can be very big, prefer compact boolean types. */
2873 tree mask_type = gfc_get_logical_type (gfc_logical_kinds[0].kind);
2875 gfc_add_modify (&block, maskindex, gfc_index_zero_node);
2877 /* Start of mask assignment loop body. */
2878 gfc_start_block (&body);
2880 /* Evaluate the mask expression. */
2881 gfc_init_se (&se, NULL);
2882 gfc_conv_expr_val (&se, code->expr);
2883 gfc_add_block_to_block (&body, &se.pre);
2885 /* Store the mask. */
2886 se.expr = convert (mask_type, se.expr);
2888 tmp = gfc_build_array_ref (mask, maskindex, NULL);
2889 gfc_add_modify (&body, tmp, se.expr);
2891 /* Advance to the next mask element. */
2892 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2893 maskindex, gfc_index_one_node);
2894 gfc_add_modify (&body, maskindex, tmp);
2896 /* Generate the loops. */
2897 tmp = gfc_finish_block (&body);
2898 tmp = gfc_trans_nested_forall_loop (info, tmp, 0);
2899 gfc_add_expr_to_block (&block, tmp);
2902 c = code->block->next;
2904 /* TODO: loop merging in FORALL statements. */
2905 /* Now that we've got a copy of the mask, generate the assignment loops. */
2911 /* A scalar or array assignment. DO the simple check for
2912 lhs to rhs dependencies. These make a temporary for the
2913 rhs and form a second forall block to copy to variable. */
2914 need_temp = check_forall_dependencies(c, &pre, &post);
2916 /* Temporaries due to array assignment data dependencies introduce
2917 no end of problems. */
2919 gfc_trans_assign_need_temp (c->expr, c->expr2, NULL, false,
2920 nested_forall_info, &block);
2923 /* Use the normal assignment copying routines. */
2924 assign = gfc_trans_assignment (c->expr, c->expr2, false);
2926 /* Generate body and loops. */
2927 tmp = gfc_trans_nested_forall_loop (nested_forall_info,
2929 gfc_add_expr_to_block (&block, tmp);
2932 /* Cleanup any temporary symtrees that have been made to deal
2933 with dependencies. */
2935 cleanup_forall_symtrees (c);
2940 /* Translate WHERE or WHERE construct nested in FORALL. */
2941 gfc_trans_where_2 (c, NULL, false, nested_forall_info, &block);
2944 /* Pointer assignment inside FORALL. */
2945 case EXEC_POINTER_ASSIGN:
2946 need_temp = gfc_check_dependency (c->expr, c->expr2, 0);
2948 gfc_trans_pointer_assign_need_temp (c->expr, c->expr2,
2949 nested_forall_info, &block);
2952 /* Use the normal assignment copying routines. */
2953 assign = gfc_trans_pointer_assignment (c->expr, c->expr2);
2955 /* Generate body and loops. */
2956 tmp = gfc_trans_nested_forall_loop (nested_forall_info,
2958 gfc_add_expr_to_block (&block, tmp);
2963 tmp = gfc_trans_forall_1 (c, nested_forall_info);
2964 gfc_add_expr_to_block (&block, tmp);
2967 /* Explicit subroutine calls are prevented by the frontend but interface
2968 assignments can legitimately produce them. */
2969 case EXEC_ASSIGN_CALL:
2970 assign = gfc_trans_call (c, true);
2971 tmp = gfc_trans_nested_forall_loop (nested_forall_info, assign, 1);
2972 gfc_add_expr_to_block (&block, tmp);
2982 /* Restore the original index variables. */
2983 for (fa = code->ext.forall_iterator, n = 0; fa; fa = fa->next, n++)
2984 gfc_restore_sym (fa->var->symtree->n.sym, &saved_vars[n]);
2986 /* Free the space for var, start, end, step, varexpr. */
2992 gfc_free (saved_vars);
2994 /* Free the space for this forall_info. */
2999 /* Free the temporary for the mask. */
3000 tmp = gfc_call_free (pmask);
3001 gfc_add_expr_to_block (&block, tmp);
3004 pushdecl (maskindex);
3006 gfc_add_block_to_block (&pre, &block);
3007 gfc_add_block_to_block (&pre, &post);
3009 return gfc_finish_block (&pre);
3013 /* Translate the FORALL statement or construct. */
3015 tree gfc_trans_forall (gfc_code * code)
3017 return gfc_trans_forall_1 (code, NULL);
3021 /* Evaluate the WHERE mask expression, copy its value to a temporary.
3022 If the WHERE construct is nested in FORALL, compute the overall temporary
3023 needed by the WHERE mask expression multiplied by the iterator number of
3025 ME is the WHERE mask expression.
3026 MASK is the current execution mask upon input, whose sense may or may
3027 not be inverted as specified by the INVERT argument.
3028 CMASK is the updated execution mask on output, or NULL if not required.
3029 PMASK is the pending execution mask on output, or NULL if not required.
3030 BLOCK is the block in which to place the condition evaluation loops. */
3033 gfc_evaluate_where_mask (gfc_expr * me, forall_info * nested_forall_info,
3034 tree mask, bool invert, tree cmask, tree pmask,
3035 tree mask_type, stmtblock_t * block)
3040 stmtblock_t body, body1;
3041 tree count, cond, mtmp;
3044 gfc_init_loopinfo (&loop);
3046 lss = gfc_walk_expr (me);
3047 rss = gfc_walk_expr (me);
3049 /* Variable to index the temporary. */
3050 count = gfc_create_var (gfc_array_index_type, "count");
3051 /* Initialize count. */
3052 gfc_add_modify (block, count, gfc_index_zero_node);
3054 gfc_start_block (&body);
3056 gfc_init_se (&rse, NULL);
3057 gfc_init_se (&lse, NULL);
3059 if (lss == gfc_ss_terminator)
3061 gfc_init_block (&body1);
3065 /* Initialize the loop. */
3066 gfc_init_loopinfo (&loop);
3068 /* We may need LSS to determine the shape of the expression. */
3069 gfc_add_ss_to_loop (&loop, lss);
3070 gfc_add_ss_to_loop (&loop, rss);
3072 gfc_conv_ss_startstride (&loop);
3073 gfc_conv_loop_setup (&loop, &me->where);
3075 gfc_mark_ss_chain_used (rss, 1);
3076 /* Start the loop body. */
3077 gfc_start_scalarized_body (&loop, &body1);
3079 /* Translate the expression. */
3080 gfc_copy_loopinfo_to_se (&rse, &loop);
3082 gfc_conv_expr (&rse, me);
3085 /* Variable to evaluate mask condition. */
3086 cond = gfc_create_var (mask_type, "cond");
3087 if (mask && (cmask || pmask))
3088 mtmp = gfc_create_var (mask_type, "mask");
3089 else mtmp = NULL_TREE;
3091 gfc_add_block_to_block (&body1, &lse.pre);
3092 gfc_add_block_to_block (&body1, &rse.pre);
3094 gfc_add_modify (&body1, cond, fold_convert (mask_type, rse.expr));
3096 if (mask && (cmask || pmask))
3098 tmp = gfc_build_array_ref (mask, count, NULL);
3100 tmp = fold_build1 (TRUTH_NOT_EXPR, mask_type, tmp);
3101 gfc_add_modify (&body1, mtmp, tmp);
3106 tmp1 = gfc_build_array_ref (cmask, count, NULL);
3109 tmp = fold_build2 (TRUTH_AND_EXPR, mask_type, mtmp, tmp);
3110 gfc_add_modify (&body1, tmp1, tmp);
3115 tmp1 = gfc_build_array_ref (pmask, count, NULL);
3116 tmp = fold_build1 (TRUTH_NOT_EXPR, mask_type, cond);
3118 tmp = fold_build2 (TRUTH_AND_EXPR, mask_type, mtmp, tmp);
3119 gfc_add_modify (&body1, tmp1, tmp);
3122 gfc_add_block_to_block (&body1, &lse.post);
3123 gfc_add_block_to_block (&body1, &rse.post);
3125 if (lss == gfc_ss_terminator)
3127 gfc_add_block_to_block (&body, &body1);
3131 /* Increment count. */
3132 tmp1 = fold_build2 (PLUS_EXPR, gfc_array_index_type, count,
3133 gfc_index_one_node);
3134 gfc_add_modify (&body1, count, tmp1);
3136 /* Generate the copying loops. */
3137 gfc_trans_scalarizing_loops (&loop, &body1);
3139 gfc_add_block_to_block (&body, &loop.pre);
3140 gfc_add_block_to_block (&body, &loop.post);
3142 gfc_cleanup_loop (&loop);
3143 /* TODO: Reuse lss and rss when copying temp->lhs. Need to be careful
3144 as tree nodes in SS may not be valid in different scope. */
3147 tmp1 = gfc_finish_block (&body);
3148 /* If the WHERE construct is inside FORALL, fill the full temporary. */
3149 if (nested_forall_info != NULL)
3150 tmp1 = gfc_trans_nested_forall_loop (nested_forall_info, tmp1, 1);
3152 gfc_add_expr_to_block (block, tmp1);
3156 /* Translate an assignment statement in a WHERE statement or construct
3157 statement. The MASK expression is used to control which elements
3158 of EXPR1 shall be assigned. The sense of MASK is specified by
3162 gfc_trans_where_assign (gfc_expr *expr1, gfc_expr *expr2,
3163 tree mask, bool invert,
3164 tree count1, tree count2,
3170 gfc_ss *lss_section;
3177 tree index, maskexpr;
3180 /* TODO: handle this special case.
3181 Special case a single function returning an array. */
3182 if (expr2->expr_type == EXPR_FUNCTION && expr2->rank > 0)
3184 tmp = gfc_trans_arrayfunc_assign (expr1, expr2);
3190 /* Assignment of the form lhs = rhs. */
3191 gfc_start_block (&block);
3193 gfc_init_se (&lse, NULL);
3194 gfc_init_se (&rse, NULL);
3197 lss = gfc_walk_expr (expr1);
3200 /* In each where-assign-stmt, the mask-expr and the variable being
3201 defined shall be arrays of the same shape. */
3202 gcc_assert (lss != gfc_ss_terminator);
3204 /* The assignment needs scalarization. */
3207 /* Find a non-scalar SS from the lhs. */
3208 while (lss_section != gfc_ss_terminator
3209 && lss_section->type != GFC_SS_SECTION)
3210 lss_section = lss_section->next;
3212 gcc_assert (lss_section != gfc_ss_terminator);
3214 /* Initialize the scalarizer. */
3215 gfc_init_loopinfo (&loop);
3218 rss = gfc_walk_expr (expr2);
3219 if (rss == gfc_ss_terminator)
3221 /* The rhs is scalar. Add a ss for the expression. */
3222 rss = gfc_get_ss ();
3224 rss->next = gfc_ss_terminator;
3225 rss->type = GFC_SS_SCALAR;
3229 /* Associate the SS with the loop. */
3230 gfc_add_ss_to_loop (&loop, lss);
3231 gfc_add_ss_to_loop (&loop, rss);
3233 /* Calculate the bounds of the scalarization. */
3234 gfc_conv_ss_startstride (&loop);
3236 /* Resolve any data dependencies in the statement. */
3237 gfc_conv_resolve_dependencies (&loop, lss_section, rss);
3239 /* Setup the scalarizing loops. */
3240 gfc_conv_loop_setup (&loop, &expr2->where);
3242 /* Setup the gfc_se structures. */
3243 gfc_copy_loopinfo_to_se (&lse, &loop);
3244 gfc_copy_loopinfo_to_se (&rse, &loop);
3247 gfc_mark_ss_chain_used (rss, 1);
3248 if (loop.temp_ss == NULL)
3251 gfc_mark_ss_chain_used (lss, 1);
3255 lse.ss = loop.temp_ss;
3256 gfc_mark_ss_chain_used (lss, 3);
3257 gfc_mark_ss_chain_used (loop.temp_ss, 3);
3260 /* Start the scalarized loop body. */
3261 gfc_start_scalarized_body (&loop, &body);
3263 /* Translate the expression. */
3264 gfc_conv_expr (&rse, expr2);
3265 if (lss != gfc_ss_terminator && loop.temp_ss != NULL)
3267 gfc_conv_tmp_array_ref (&lse);
3268 gfc_advance_se_ss_chain (&lse);
3271 gfc_conv_expr (&lse, expr1);
3273 /* Form the mask expression according to the mask. */
3275 maskexpr = gfc_build_array_ref (mask, index, NULL);
3277 maskexpr = fold_build1 (TRUTH_NOT_EXPR, TREE_TYPE (maskexpr), maskexpr);
3279 /* Use the scalar assignment as is. */
3281 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
3282 loop.temp_ss != NULL, false);
3284 tmp = gfc_conv_operator_assign (&lse, &rse, sym);
3286 tmp = build3_v (COND_EXPR, maskexpr, tmp, build_empty_stmt ());
3288 gfc_add_expr_to_block (&body, tmp);
3290 if (lss == gfc_ss_terminator)
3292 /* Increment count1. */
3293 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
3294 count1, gfc_index_one_node);
3295 gfc_add_modify (&body, count1, tmp);
3297 /* Use the scalar assignment as is. */
3298 gfc_add_block_to_block (&block, &body);
3302 gcc_assert (lse.ss == gfc_ss_terminator
3303 && rse.ss == gfc_ss_terminator);
3305 if (loop.temp_ss != NULL)
3307 /* Increment count1 before finish the main body of a scalarized
3309 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
3310 count1, gfc_index_one_node);
3311 gfc_add_modify (&body, count1, tmp);
3312 gfc_trans_scalarized_loop_boundary (&loop, &body);
3314 /* We need to copy the temporary to the actual lhs. */
3315 gfc_init_se (&lse, NULL);
3316 gfc_init_se (&rse, NULL);
3317 gfc_copy_loopinfo_to_se (&lse, &loop);
3318 gfc_copy_loopinfo_to_se (&rse, &loop);
3320 rse.ss = loop.temp_ss;
3323 gfc_conv_tmp_array_ref (&rse);
3324 gfc_advance_se_ss_chain (&rse);
3325 gfc_conv_expr (&lse, expr1);
3327 gcc_assert (lse.ss == gfc_ss_terminator
3328 && rse.ss == gfc_ss_terminator);
3330 /* Form the mask expression according to the mask tree list. */
3332 maskexpr = gfc_build_array_ref (mask, index, NULL);
3334 maskexpr = fold_build1 (TRUTH_NOT_EXPR, TREE_TYPE (maskexpr),
3337 /* Use the scalar assignment as is. */
3338 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts, false, false);
3339 tmp = build3_v (COND_EXPR, maskexpr, tmp, build_empty_stmt ());
3340 gfc_add_expr_to_block (&body, tmp);
3342 /* Increment count2. */
3343 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
3344 count2, gfc_index_one_node);
3345 gfc_add_modify (&body, count2, tmp);
3349 /* Increment count1. */
3350 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
3351 count1, gfc_index_one_node);
3352 gfc_add_modify (&body, count1, tmp);
3355 /* Generate the copying loops. */
3356 gfc_trans_scalarizing_loops (&loop, &body);
3358 /* Wrap the whole thing up. */
3359 gfc_add_block_to_block (&block, &loop.pre);
3360 gfc_add_block_to_block (&block, &loop.post);
3361 gfc_cleanup_loop (&loop);
3364 return gfc_finish_block (&block);
3368 /* Translate the WHERE construct or statement.
3369 This function can be called iteratively to translate the nested WHERE
3370 construct or statement.
3371 MASK is the control mask. */
3374 gfc_trans_where_2 (gfc_code * code, tree mask, bool invert,
3375 forall_info * nested_forall_info, stmtblock_t * block)
3377 stmtblock_t inner_size_body;
3378 tree inner_size, size;
3387 tree count1, count2;
3391 tree pcmask = NULL_TREE;
3392 tree ppmask = NULL_TREE;
3393 tree cmask = NULL_TREE;
3394 tree pmask = NULL_TREE;
3395 gfc_actual_arglist *arg;
3397 /* the WHERE statement or the WHERE construct statement. */
3398 cblock = code->block;
3400 /* As the mask array can be very big, prefer compact boolean types. */
3401 mask_type = gfc_get_logical_type (gfc_logical_kinds[0].kind);
3403 /* Determine which temporary masks are needed. */
3406 /* One clause: No ELSEWHEREs. */
3407 need_cmask = (cblock->next != 0);
3410 else if (cblock->block->block)
3412 /* Three or more clauses: Conditional ELSEWHEREs. */
3416 else if (cblock->next)
3418 /* Two clauses, the first non-empty. */
3420 need_pmask = (mask != NULL_TREE
3421 && cblock->block->next != 0);
3423 else if (!cblock->block->next)
3425 /* Two clauses, both empty. */
3429 /* Two clauses, the first empty, the second non-empty. */
3432 need_cmask = (cblock->block->expr != 0);
3441 if (need_cmask || need_pmask)
3443 /* Calculate the size of temporary needed by the mask-expr. */
3444 gfc_init_block (&inner_size_body);
3445 inner_size = compute_inner_temp_size (cblock->expr, cblock->expr,
3446 &inner_size_body, &lss, &rss);
3448 /* Calculate the total size of temporary needed. */
3449 size = compute_overall_iter_number (nested_forall_info, inner_size,
3450 &inner_size_body, block);
3452 /* Check whether the size is negative. */
3453 cond = fold_build2 (LE_EXPR, boolean_type_node, size,
3454 gfc_index_zero_node);
3455 size = fold_build3 (COND_EXPR, gfc_array_index_type, cond,
3456 gfc_index_zero_node, size);
3457 size = gfc_evaluate_now (size, block);
3459 /* Allocate temporary for WHERE mask if needed. */
3461 cmask = allocate_temp_for_forall_nest_1 (mask_type, size, block,
3464 /* Allocate temporary for !mask if needed. */
3466 pmask = allocate_temp_for_forall_nest_1 (mask_type, size, block,
3472 /* Each time around this loop, the where clause is conditional
3473 on the value of mask and invert, which are updated at the
3474 bottom of the loop. */
3476 /* Has mask-expr. */
3479 /* Ensure that the WHERE mask will be evaluated exactly once.
3480 If there are no statements in this WHERE/ELSEWHERE clause,
3481 then we don't need to update the control mask (cmask).
3482 If this is the last clause of the WHERE construct, then
3483 we don't need to update the pending control mask (pmask). */
3485 gfc_evaluate_where_mask (cblock->expr, nested_forall_info,
3487 cblock->next ? cmask : NULL_TREE,
3488 cblock->block ? pmask : NULL_TREE,
3491 gfc_evaluate_where_mask (cblock->expr, nested_forall_info,
3493 (cblock->next || cblock->block)
3494 ? cmask : NULL_TREE,
3495 NULL_TREE, mask_type, block);
3499 /* It's a final elsewhere-stmt. No mask-expr is present. */
3503 /* The body of this where clause are controlled by cmask with
3504 sense specified by invert. */
3506 /* Get the assignment statement of a WHERE statement, or the first
3507 statement in where-body-construct of a WHERE construct. */
3508 cnext = cblock->next;
3513 /* WHERE assignment statement. */
3514 case EXEC_ASSIGN_CALL:
3516 arg = cnext->ext.actual;
3517 expr1 = expr2 = NULL;
3518 for (; arg; arg = arg->next)
3530 expr1 = cnext->expr;
3531 expr2 = cnext->expr2;
3533 if (nested_forall_info != NULL)
3535 need_temp = gfc_check_dependency (expr1, expr2, 0);
3536 if (need_temp && cnext->op != EXEC_ASSIGN_CALL)
3537 gfc_trans_assign_need_temp (expr1, expr2,
3539 nested_forall_info, block);
3542 /* Variables to control maskexpr. */
3543 count1 = gfc_create_var (gfc_array_index_type, "count1");
3544 count2 = gfc_create_var (gfc_array_index_type, "count2");
3545 gfc_add_modify (block, count1, gfc_index_zero_node);
3546 gfc_add_modify (block, count2, gfc_index_zero_node);
3548 tmp = gfc_trans_where_assign (expr1, expr2,
3551 cnext->resolved_sym);
3553 tmp = gfc_trans_nested_forall_loop (nested_forall_info,
3555 gfc_add_expr_to_block (block, tmp);
3560 /* Variables to control maskexpr. */
3561 count1 = gfc_create_var (gfc_array_index_type, "count1");
3562 count2 = gfc_create_var (gfc_array_index_type, "count2");
3563 gfc_add_modify (block, count1, gfc_index_zero_node);
3564 gfc_add_modify (block, count2, gfc_index_zero_node);
3566 tmp = gfc_trans_where_assign (expr1, expr2,
3569 cnext->resolved_sym);
3570 gfc_add_expr_to_block (block, tmp);
3575 /* WHERE or WHERE construct is part of a where-body-construct. */
3577 gfc_trans_where_2 (cnext, cmask, invert,
3578 nested_forall_info, block);
3585 /* The next statement within the same where-body-construct. */
3586 cnext = cnext->next;
3588 /* The next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt. */
3589 cblock = cblock->block;
3590 if (mask == NULL_TREE)
3592 /* If we're the initial WHERE, we can simply invert the sense
3593 of the current mask to obtain the "mask" for the remaining
3600 /* Otherwise, for nested WHERE's we need to use the pending mask. */
3606 /* If we allocated a pending mask array, deallocate it now. */
3609 tmp = gfc_call_free (ppmask);
3610 gfc_add_expr_to_block (block, tmp);
3613 /* If we allocated a current mask array, deallocate it now. */
3616 tmp = gfc_call_free (pcmask);
3617 gfc_add_expr_to_block (block, tmp);
3621 /* Translate a simple WHERE construct or statement without dependencies.
3622 CBLOCK is the "then" clause of the WHERE statement, where CBLOCK->EXPR
3623 is the mask condition, and EBLOCK if non-NULL is the "else" clause.
3624 Currently both CBLOCK and EBLOCK are restricted to single assignments. */
3627 gfc_trans_where_3 (gfc_code * cblock, gfc_code * eblock)
3629 stmtblock_t block, body;
3630 gfc_expr *cond, *tdst, *tsrc, *edst, *esrc;
3631 tree tmp, cexpr, tstmt, estmt;
3632 gfc_ss *css, *tdss, *tsss;
3633 gfc_se cse, tdse, tsse, edse, esse;
3638 cond = cblock->expr;
3639 tdst = cblock->next->expr;
3640 tsrc = cblock->next->expr2;
3641 edst = eblock ? eblock->next->expr : NULL;
3642 esrc = eblock ? eblock->next->expr2 : NULL;
3644 gfc_start_block (&block);
3645 gfc_init_loopinfo (&loop);
3647 /* Handle the condition. */
3648 gfc_init_se (&cse, NULL);
3649 css = gfc_walk_expr (cond);
3650 gfc_add_ss_to_loop (&loop, css);
3652 /* Handle the then-clause. */
3653 gfc_init_se (&tdse, NULL);
3654 gfc_init_se (&tsse, NULL);
3655 tdss = gfc_walk_expr (tdst);
3656 tsss = gfc_walk_expr (tsrc);
3657 if (tsss == gfc_ss_terminator)
3659 tsss = gfc_get_ss ();
3661 tsss->next = gfc_ss_terminator;
3662 tsss->type = GFC_SS_SCALAR;
3665 gfc_add_ss_to_loop (&loop, tdss);
3666 gfc_add_ss_to_loop (&loop, tsss);
3670 /* Handle the else clause. */
3671 gfc_init_se (&edse, NULL);
3672 gfc_init_se (&esse, NULL);
3673 edss = gfc_walk_expr (edst);
3674 esss = gfc_walk_expr (esrc);
3675 if (esss == gfc_ss_terminator)
3677 esss = gfc_get_ss ();
3679 esss->next = gfc_ss_terminator;
3680 esss->type = GFC_SS_SCALAR;
3683 gfc_add_ss_to_loop (&loop, edss);
3684 gfc_add_ss_to_loop (&loop, esss);
3687 gfc_conv_ss_startstride (&loop);
3688 gfc_conv_loop_setup (&loop, &tdst->where);
3690 gfc_mark_ss_chain_used (css, 1);
3691 gfc_mark_ss_chain_used (tdss, 1);
3692 gfc_mark_ss_chain_used (tsss, 1);
3695 gfc_mark_ss_chain_used (edss, 1);
3696 gfc_mark_ss_chain_used (esss, 1);
3699 gfc_start_scalarized_body (&loop, &body);
3701 gfc_copy_loopinfo_to_se (&cse, &loop);
3702 gfc_copy_loopinfo_to_se (&tdse, &loop);
3703 gfc_copy_loopinfo_to_se (&tsse, &loop);
3709 gfc_copy_loopinfo_to_se (&edse, &loop);
3710 gfc_copy_loopinfo_to_se (&esse, &loop);
3715 gfc_conv_expr (&cse, cond);
3716 gfc_add_block_to_block (&body, &cse.pre);
3719 gfc_conv_expr (&tsse, tsrc);
3720 if (tdss != gfc_ss_terminator && loop.temp_ss != NULL)
3722 gfc_conv_tmp_array_ref (&tdse);
3723 gfc_advance_se_ss_chain (&tdse);
3726 gfc_conv_expr (&tdse, tdst);
3730 gfc_conv_expr (&esse, esrc);
3731 if (edss != gfc_ss_terminator && loop.temp_ss != NULL)
3733 gfc_conv_tmp_array_ref (&edse);
3734 gfc_advance_se_ss_chain (&edse);
3737 gfc_conv_expr (&edse, edst);
3740 tstmt = gfc_trans_scalar_assign (&tdse, &tsse, tdst->ts, false, false);
3741 estmt = eblock ? gfc_trans_scalar_assign (&edse, &esse, edst->ts, false, false)
3742 : build_empty_stmt ();
3743 tmp = build3_v (COND_EXPR, cexpr, tstmt, estmt);
3744 gfc_add_expr_to_block (&body, tmp);
3745 gfc_add_block_to_block (&body, &cse.post);
3747 gfc_trans_scalarizing_loops (&loop, &body);
3748 gfc_add_block_to_block (&block, &loop.pre);
3749 gfc_add_block_to_block (&block, &loop.post);
3750 gfc_cleanup_loop (&loop);
3752 return gfc_finish_block (&block);
3755 /* As the WHERE or WHERE construct statement can be nested, we call
3756 gfc_trans_where_2 to do the translation, and pass the initial
3757 NULL values for both the control mask and the pending control mask. */
3760 gfc_trans_where (gfc_code * code)
3766 cblock = code->block;
3768 && cblock->next->op == EXEC_ASSIGN
3769 && !cblock->next->next)
3771 eblock = cblock->block;
3774 /* A simple "WHERE (cond) x = y" statement or block is
3775 dependence free if cond is not dependent upon writing x,
3776 and the source y is unaffected by the destination x. */
3777 if (!gfc_check_dependency (cblock->next->expr,
3779 && !gfc_check_dependency (cblock->next->expr,
3780 cblock->next->expr2, 0))
3781 return gfc_trans_where_3 (cblock, NULL);
3783 else if (!eblock->expr
3786 && eblock->next->op == EXEC_ASSIGN
3787 && !eblock->next->next)
3789 /* A simple "WHERE (cond) x1 = y1 ELSEWHERE x2 = y2 ENDWHERE"
3790 block is dependence free if cond is not dependent on writes
3791 to x1 and x2, y1 is not dependent on writes to x2, and y2
3792 is not dependent on writes to x1, and both y's are not
3793 dependent upon their own x's. In addition to this, the
3794 final two dependency checks below exclude all but the same
3795 array reference if the where and elswhere destinations
3796 are the same. In short, this is VERY conservative and this
3797 is needed because the two loops, required by the standard
3798 are coalesced in gfc_trans_where_3. */
3799 if (!gfc_check_dependency(cblock->next->expr,
3801 && !gfc_check_dependency(eblock->next->expr,
3803 && !gfc_check_dependency(cblock->next->expr,
3804 eblock->next->expr2, 1)
3805 && !gfc_check_dependency(eblock->next->expr,
3806 cblock->next->expr2, 1)
3807 && !gfc_check_dependency(cblock->next->expr,
3808 cblock->next->expr2, 1)
3809 && !gfc_check_dependency(eblock->next->expr,
3810 eblock->next->expr2, 1)
3811 && !gfc_check_dependency(cblock->next->expr,
3812 eblock->next->expr, 0)
3813 && !gfc_check_dependency(eblock->next->expr,
3814 cblock->next->expr, 0))
3815 return gfc_trans_where_3 (cblock, eblock);
3819 gfc_start_block (&block);
3821 gfc_trans_where_2 (code, NULL, false, NULL, &block);
3823 return gfc_finish_block (&block);
3827 /* CYCLE a DO loop. The label decl has already been created by
3828 gfc_trans_do(), it's in TREE_PURPOSE (backend_decl) of the gfc_code
3829 node at the head of the loop. We must mark the label as used. */
3832 gfc_trans_cycle (gfc_code * code)
3836 cycle_label = TREE_PURPOSE (code->ext.whichloop->backend_decl);
3837 TREE_USED (cycle_label) = 1;
3838 return build1_v (GOTO_EXPR, cycle_label);
3842 /* EXIT a DO loop. Similar to CYCLE, but now the label is in
3843 TREE_VALUE (backend_decl) of the gfc_code node at the head of the
3847 gfc_trans_exit (gfc_code * code)
3851 exit_label = TREE_VALUE (code->ext.whichloop->backend_decl);
3852 TREE_USED (exit_label) = 1;
3853 return build1_v (GOTO_EXPR, exit_label);
3857 /* Translate the ALLOCATE statement. */
3860 gfc_trans_allocate (gfc_code * code)
3872 if (!code->ext.alloc_list)
3875 gfc_start_block (&block);
3879 tree gfc_int4_type_node = gfc_get_int_type (4);
3881 stat = gfc_create_var (gfc_int4_type_node, "stat");
3882 pstat = build_fold_addr_expr (stat);
3884 error_label = gfc_build_label_decl (NULL_TREE);
3885 TREE_USED (error_label) = 1;
3888 pstat = stat = error_label = NULL_TREE;
3890 for (al = code->ext.alloc_list; al != NULL; al = al->next)
3894 gfc_init_se (&se, NULL);
3895 gfc_start_block (&se.pre);
3897 se.want_pointer = 1;
3898 se.descriptor_only = 1;
3899 gfc_conv_expr (&se, expr);
3901 if (!gfc_array_allocate (&se, expr, pstat))
3903 /* A scalar or derived type. */
3904 tmp = TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (se.expr)));
3906 if (expr->ts.type == BT_CHARACTER && tmp == NULL_TREE)
3907 tmp = se.string_length;
3909 tmp = gfc_allocate_with_status (&se.pre, tmp, pstat);
3910 tmp = fold_build2 (MODIFY_EXPR, void_type_node, se.expr,
3911 fold_convert (TREE_TYPE (se.expr), tmp));
3912 gfc_add_expr_to_block (&se.pre, tmp);
3916 tmp = build1_v (GOTO_EXPR, error_label);
3917 parm = fold_build2 (NE_EXPR, boolean_type_node,
3918 stat, build_int_cst (TREE_TYPE (stat), 0));
3919 tmp = fold_build3 (COND_EXPR, void_type_node,
3920 parm, tmp, build_empty_stmt ());
3921 gfc_add_expr_to_block (&se.pre, tmp);
3924 if (expr->ts.type == BT_DERIVED && expr->ts.derived->attr.alloc_comp)
3926 tmp = build_fold_indirect_ref (se.expr);
3927 tmp = gfc_nullify_alloc_comp (expr->ts.derived, tmp, 0);
3928 gfc_add_expr_to_block (&se.pre, tmp);
3933 tmp = gfc_finish_block (&se.pre);
3934 gfc_add_expr_to_block (&block, tmp);
3937 /* Assign the value to the status variable. */
3940 tmp = build1_v (LABEL_EXPR, error_label);
3941 gfc_add_expr_to_block (&block, tmp);
3943 gfc_init_se (&se, NULL);
3944 gfc_conv_expr_lhs (&se, code->expr);
3945 tmp = convert (TREE_TYPE (se.expr), stat);
3946 gfc_add_modify (&block, se.expr, tmp);
3949 return gfc_finish_block (&block);
3953 /* Translate a DEALLOCATE statement.
3954 There are two cases within the for loop:
3955 (1) deallocate(a1, a2, a3) is translated into the following sequence
3956 _gfortran_deallocate(a1, 0B)
3957 _gfortran_deallocate(a2, 0B)
3958 _gfortran_deallocate(a3, 0B)
3959 where the STAT= variable is passed a NULL pointer.
3960 (2) deallocate(a1, a2, a3, stat=i) is translated into the following
3962 _gfortran_deallocate(a1, &stat)
3963 astat = astat + stat
3964 _gfortran_deallocate(a2, &stat)
3965 astat = astat + stat
3966 _gfortran_deallocate(a3, &stat)
3967 astat = astat + stat
3968 In case (1), we simply return at the end of the for loop. In case (2)
3969 we set STAT= astat. */
3971 gfc_trans_deallocate (gfc_code * code)
3976 tree apstat, astat, pstat, stat, tmp;
3979 gfc_start_block (&block);
3981 /* Set up the optional STAT= */
3984 tree gfc_int4_type_node = gfc_get_int_type (4);
3986 /* Variable used with the library call. */
3987 stat = gfc_create_var (gfc_int4_type_node, "stat");
3988 pstat = build_fold_addr_expr (stat);
3990 /* Running total of possible deallocation failures. */
3991 astat = gfc_create_var (gfc_int4_type_node, "astat");
3992 apstat = build_fold_addr_expr (astat);
3994 /* Initialize astat to 0. */
3995 gfc_add_modify (&block, astat, build_int_cst (TREE_TYPE (astat), 0));
3998 pstat = apstat = stat = astat = NULL_TREE;
4000 for (al = code->ext.alloc_list; al != NULL; al = al->next)
4003 gcc_assert (expr->expr_type == EXPR_VARIABLE);
4005 gfc_init_se (&se, NULL);
4006 gfc_start_block (&se.pre);
4008 se.want_pointer = 1;
4009 se.descriptor_only = 1;
4010 gfc_conv_expr (&se, expr);
4012 if (expr->ts.type == BT_DERIVED
4013 && expr->ts.derived->attr.alloc_comp)
4016 gfc_ref *last = NULL;
4017 for (ref = expr->ref; ref; ref = ref->next)
4018 if (ref->type == REF_COMPONENT)
4021 /* Do not deallocate the components of a derived type
4022 ultimate pointer component. */
4023 if (!(last && last->u.c.component->attr.pointer)
4024 && !(!last && expr->symtree->n.sym->attr.pointer))
4026 tmp = gfc_deallocate_alloc_comp (expr->ts.derived, se.expr,
4028 gfc_add_expr_to_block (&se.pre, tmp);
4033 tmp = gfc_array_deallocate (se.expr, pstat, expr);
4036 tmp = gfc_deallocate_with_status (se.expr, pstat, false, expr);
4037 gfc_add_expr_to_block (&se.pre, tmp);
4039 tmp = fold_build2 (MODIFY_EXPR, void_type_node,
4040 se.expr, build_int_cst (TREE_TYPE (se.expr), 0));
4043 gfc_add_expr_to_block (&se.pre, tmp);
4045 /* Keep track of the number of failed deallocations by adding stat
4046 of the last deallocation to the running total. */
4049 apstat = fold_build2 (PLUS_EXPR, TREE_TYPE (stat), astat, stat);
4050 gfc_add_modify (&se.pre, astat, apstat);
4053 tmp = gfc_finish_block (&se.pre);
4054 gfc_add_expr_to_block (&block, tmp);
4058 /* Assign the value to the status variable. */
4061 gfc_init_se (&se, NULL);
4062 gfc_conv_expr_lhs (&se, code->expr);
4063 tmp = convert (TREE_TYPE (se.expr), astat);
4064 gfc_add_modify (&block, se.expr, tmp);
4067 return gfc_finish_block (&block);