1 /* Statement translation -- generate GCC trees from gfc_code.
2 Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007
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 2, 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 COPYING. If not, write to the Free
21 Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
27 #include "coretypes.h"
29 #include "tree-gimple.h"
36 #include "trans-stmt.h"
37 #include "trans-types.h"
38 #include "trans-array.h"
39 #include "trans-const.h"
41 #include "dependency.h"
43 typedef struct iter_info
49 struct iter_info *next;
53 typedef struct forall_info
60 struct forall_info *prev_nest;
64 static void gfc_trans_where_2 (gfc_code *, tree, bool,
65 forall_info *, stmtblock_t *);
67 /* Translate a F95 label number to a LABEL_EXPR. */
70 gfc_trans_label_here (gfc_code * code)
72 return build1_v (LABEL_EXPR, gfc_get_label_decl (code->here));
76 /* Given a variable expression which has been ASSIGNed to, find the decl
77 containing the auxiliary variables. For variables in common blocks this
81 gfc_conv_label_variable (gfc_se * se, gfc_expr * expr)
83 gcc_assert (expr->symtree->n.sym->attr.assign == 1);
84 gfc_conv_expr (se, expr);
85 /* Deals with variable in common block. Get the field declaration. */
86 if (TREE_CODE (se->expr) == COMPONENT_REF)
87 se->expr = TREE_OPERAND (se->expr, 1);
88 /* Deals with dummy argument. Get the parameter declaration. */
89 else if (TREE_CODE (se->expr) == INDIRECT_REF)
90 se->expr = TREE_OPERAND (se->expr, 0);
93 /* Translate a label assignment statement. */
96 gfc_trans_label_assign (gfc_code * code)
106 /* Start a new block. */
107 gfc_init_se (&se, NULL);
108 gfc_start_block (&se.pre);
109 gfc_conv_label_variable (&se, code->expr);
111 len = GFC_DECL_STRING_LEN (se.expr);
112 addr = GFC_DECL_ASSIGN_ADDR (se.expr);
114 label_tree = gfc_get_label_decl (code->label);
116 if (code->label->defined == ST_LABEL_TARGET)
118 label_tree = gfc_build_addr_expr (pvoid_type_node, label_tree);
119 len_tree = integer_minus_one_node;
123 label_str = code->label->format->value.character.string;
124 label_len = code->label->format->value.character.length;
125 len_tree = build_int_cst (NULL_TREE, label_len);
126 label_tree = gfc_build_string_const (label_len + 1, label_str);
127 label_tree = gfc_build_addr_expr (pvoid_type_node, label_tree);
130 gfc_add_modify_expr (&se.pre, len, len_tree);
131 gfc_add_modify_expr (&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 (tmp, "Assigned label is not a target label",
160 assigned_goto = GFC_DECL_ASSIGN_ADDR (se.expr);
165 target = 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 = build2 (EQ_EXPR, boolean_type_node, tmp, assigned_goto);
176 tmp = build3_v (COND_EXPR, tmp,
177 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 (boolean_true_node,
184 "Assigned label is not in the list", &se.pre, &loc);
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_OUT
251 && gfc_check_fncall_dependency (e, INTENT_OUT, sym, arg0))
253 /* Make a local loopinfo for the temporary creation, so that
254 none of the other ss->info's have to be renormalized. */
255 gfc_init_loopinfo (&tmp_loop);
256 for (n = 0; n < info->dimen; n++)
258 tmp_loop.to[n] = loopse->loop->to[n];
259 tmp_loop.from[n] = loopse->loop->from[n];
260 tmp_loop.order[n] = loopse->loop->order[n];
263 /* Generate the temporary. Merge the block so that the
264 declarations are put at the right binding level. */
265 size = gfc_create_var (gfc_array_index_type, NULL);
266 data = gfc_create_var (pvoid_type_node, NULL);
267 gfc_start_block (&block);
268 tmp = gfc_typenode_for_spec (&e->ts);
269 tmp = gfc_trans_create_temp_array (&se->pre, &se->post,
270 &tmp_loop, info, tmp,
271 false, true, false, false);
272 gfc_add_modify_expr (&se->pre, size, tmp);
273 tmp = fold_convert (pvoid_type_node, info->data);
274 gfc_add_modify_expr (&se->pre, data, tmp);
275 gfc_merge_block_scope (&block);
277 /* Obtain the argument descriptor for unpacking. */
278 gfc_init_se (&parmse, NULL);
279 parmse.want_pointer = 1;
280 gfc_conv_expr_descriptor (&parmse, e, gfc_walk_expr (e));
281 gfc_add_block_to_block (&se->pre, &parmse.pre);
283 /* Calculate the offset for the temporary. */
284 offset = gfc_index_zero_node;
285 for (n = 0; n < info->dimen; n++)
287 tmp = gfc_conv_descriptor_stride (info->descriptor,
289 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
290 loopse->loop->from[n], tmp);
291 offset = fold_build2 (MINUS_EXPR, gfc_array_index_type,
294 info->offset = gfc_create_var (gfc_array_index_type, NULL);
295 gfc_add_modify_expr (&se->pre, info->offset, offset);
297 /* Copy the result back using unpack. */
298 tmp = gfc_chainon_list (NULL_TREE, parmse.expr);
299 tmp = gfc_chainon_list (tmp, data);
300 tmp = build_function_call_expr (gfor_fndecl_in_unpack, tmp);
301 gfc_add_expr_to_block (&se->post, tmp);
303 gfc_add_block_to_block (&se->post, &parmse.post);
309 /* Translate the CALL statement. Builds a call to an F95 subroutine. */
312 gfc_trans_call (gfc_code * code, bool dependency_check)
316 int has_alternate_specifier;
318 /* A CALL starts a new block because the actual arguments may have to
319 be evaluated first. */
320 gfc_init_se (&se, NULL);
321 gfc_start_block (&se.pre);
323 gcc_assert (code->resolved_sym);
325 ss = gfc_ss_terminator;
326 if (code->resolved_sym->attr.elemental)
327 ss = gfc_walk_elemental_function_args (ss, code->ext.actual, GFC_SS_REFERENCE);
329 /* Is not an elemental subroutine call with array valued arguments. */
330 if (ss == gfc_ss_terminator)
333 /* Translate the call. */
334 has_alternate_specifier
335 = gfc_conv_function_call (&se, code->resolved_sym, code->ext.actual,
338 /* A subroutine without side-effect, by definition, does nothing! */
339 TREE_SIDE_EFFECTS (se.expr) = 1;
341 /* Chain the pieces together and return the block. */
342 if (has_alternate_specifier)
344 gfc_code *select_code;
346 select_code = code->next;
347 gcc_assert(select_code->op == EXEC_SELECT);
348 sym = select_code->expr->symtree->n.sym;
349 se.expr = convert (gfc_typenode_for_spec (&sym->ts), se.expr);
350 if (sym->backend_decl == NULL)
351 sym->backend_decl = gfc_get_symbol_decl (sym);
352 gfc_add_modify_expr (&se.pre, sym->backend_decl, se.expr);
355 gfc_add_expr_to_block (&se.pre, se.expr);
357 gfc_add_block_to_block (&se.pre, &se.post);
362 /* An elemental subroutine call with array valued arguments has
369 /* gfc_walk_elemental_function_args renders the ss chain in the
370 reverse order to the actual argument order. */
371 ss = gfc_reverse_ss (ss);
373 /* Initialize the loop. */
374 gfc_init_se (&loopse, NULL);
375 gfc_init_loopinfo (&loop);
376 gfc_add_ss_to_loop (&loop, ss);
378 gfc_conv_ss_startstride (&loop);
379 gfc_conv_loop_setup (&loop);
380 gfc_mark_ss_chain_used (ss, 1);
382 /* Convert the arguments, checking for dependencies. */
383 gfc_copy_loopinfo_to_se (&loopse, &loop);
386 /* For operator assignment, we need to do dependency checking.
387 We also check the intent of the parameters. */
388 if (dependency_check)
391 sym = code->resolved_sym;
392 gcc_assert (sym->formal->sym->attr.intent = INTENT_OUT);
393 gcc_assert (sym->formal->next->sym->attr.intent = INTENT_IN);
394 gfc_conv_elemental_dependencies (&se, &loopse, sym,
398 /* Generate the loop body. */
399 gfc_start_scalarized_body (&loop, &body);
400 gfc_init_block (&block);
402 /* Add the subroutine call to the block. */
403 gfc_conv_function_call (&loopse, code->resolved_sym, code->ext.actual,
405 gfc_add_expr_to_block (&loopse.pre, loopse.expr);
407 gfc_add_block_to_block (&block, &loopse.pre);
408 gfc_add_block_to_block (&block, &loopse.post);
410 /* Finish up the loop block and the loop. */
411 gfc_add_expr_to_block (&body, gfc_finish_block (&block));
412 gfc_trans_scalarizing_loops (&loop, &body);
413 gfc_add_block_to_block (&se.pre, &loop.pre);
414 gfc_add_block_to_block (&se.pre, &loop.post);
415 gfc_add_block_to_block (&se.pre, &se.post);
416 gfc_cleanup_loop (&loop);
419 return gfc_finish_block (&se.pre);
423 /* Translate the RETURN statement. */
426 gfc_trans_return (gfc_code * code ATTRIBUTE_UNUSED)
434 /* If code->expr is not NULL, this return statement must appear
435 in a subroutine and current_fake_result_decl has already
438 result = gfc_get_fake_result_decl (NULL, 0);
441 gfc_warning ("An alternate return at %L without a * dummy argument",
443 return build1_v (GOTO_EXPR, gfc_get_return_label ());
446 /* Start a new block for this statement. */
447 gfc_init_se (&se, NULL);
448 gfc_start_block (&se.pre);
450 gfc_conv_expr (&se, code->expr);
452 tmp = build2 (MODIFY_EXPR, TREE_TYPE (result), result, se.expr);
453 gfc_add_expr_to_block (&se.pre, tmp);
455 tmp = build1_v (GOTO_EXPR, gfc_get_return_label ());
456 gfc_add_expr_to_block (&se.pre, tmp);
457 gfc_add_block_to_block (&se.pre, &se.post);
458 return gfc_finish_block (&se.pre);
461 return build1_v (GOTO_EXPR, gfc_get_return_label ());
465 /* Translate the PAUSE statement. We have to translate this statement
466 to a runtime library call. */
469 gfc_trans_pause (gfc_code * code)
471 tree gfc_int4_type_node = gfc_get_int_type (4);
477 /* Start a new block for this statement. */
478 gfc_init_se (&se, NULL);
479 gfc_start_block (&se.pre);
482 if (code->expr == NULL)
484 tmp = build_int_cst (gfc_int4_type_node, code->ext.stop_code);
485 args = gfc_chainon_list (NULL_TREE, tmp);
486 fndecl = gfor_fndecl_pause_numeric;
490 gfc_conv_expr_reference (&se, code->expr);
491 args = gfc_chainon_list (NULL_TREE, se.expr);
492 args = gfc_chainon_list (args, se.string_length);
493 fndecl = gfor_fndecl_pause_string;
496 tmp = build_function_call_expr (fndecl, args);
497 gfc_add_expr_to_block (&se.pre, tmp);
499 gfc_add_block_to_block (&se.pre, &se.post);
501 return gfc_finish_block (&se.pre);
505 /* Translate the STOP statement. We have to translate this statement
506 to a runtime library call. */
509 gfc_trans_stop (gfc_code * code)
511 tree gfc_int4_type_node = gfc_get_int_type (4);
517 /* Start a new block for this statement. */
518 gfc_init_se (&se, NULL);
519 gfc_start_block (&se.pre);
522 if (code->expr == NULL)
524 tmp = build_int_cst (gfc_int4_type_node, code->ext.stop_code);
525 args = gfc_chainon_list (NULL_TREE, tmp);
526 fndecl = gfor_fndecl_stop_numeric;
530 gfc_conv_expr_reference (&se, code->expr);
531 args = gfc_chainon_list (NULL_TREE, se.expr);
532 args = gfc_chainon_list (args, se.string_length);
533 fndecl = gfor_fndecl_stop_string;
536 tmp = build_function_call_expr (fndecl, args);
537 gfc_add_expr_to_block (&se.pre, tmp);
539 gfc_add_block_to_block (&se.pre, &se.post);
541 return gfc_finish_block (&se.pre);
545 /* Generate GENERIC for the IF construct. This function also deals with
546 the simple IF statement, because the front end translates the IF
547 statement into an IF construct.
579 where COND_S is the simplified version of the predicate. PRE_COND_S
580 are the pre side-effects produced by the translation of the
582 We need to build the chain recursively otherwise we run into
583 problems with folding incomplete statements. */
586 gfc_trans_if_1 (gfc_code * code)
591 /* Check for an unconditional ELSE clause. */
593 return gfc_trans_code (code->next);
595 /* Initialize a statement builder for each block. Puts in NULL_TREEs. */
596 gfc_init_se (&if_se, NULL);
597 gfc_start_block (&if_se.pre);
599 /* Calculate the IF condition expression. */
600 gfc_conv_expr_val (&if_se, code->expr);
602 /* Translate the THEN clause. */
603 stmt = gfc_trans_code (code->next);
605 /* Translate the ELSE clause. */
607 elsestmt = gfc_trans_if_1 (code->block);
609 elsestmt = build_empty_stmt ();
611 /* Build the condition expression and add it to the condition block. */
612 stmt = fold_build3 (COND_EXPR, void_type_node, if_se.expr, stmt, elsestmt);
614 gfc_add_expr_to_block (&if_se.pre, stmt);
616 /* Finish off this statement. */
617 return gfc_finish_block (&if_se.pre);
621 gfc_trans_if (gfc_code * code)
623 /* Ignore the top EXEC_IF, it only announces an IF construct. The
624 actual code we must translate is in code->block. */
626 return gfc_trans_if_1 (code->block);
630 /* Translate an arithmetic IF expression.
632 IF (cond) label1, label2, label3 translates to
644 An optimized version can be generated in case of equal labels.
645 E.g., if label1 is equal to label2, we can translate it to
654 gfc_trans_arithmetic_if (gfc_code * code)
662 /* Start a new block. */
663 gfc_init_se (&se, NULL);
664 gfc_start_block (&se.pre);
666 /* Pre-evaluate COND. */
667 gfc_conv_expr_val (&se, code->expr);
668 se.expr = gfc_evaluate_now (se.expr, &se.pre);
670 /* Build something to compare with. */
671 zero = gfc_build_const (TREE_TYPE (se.expr), integer_zero_node);
673 if (code->label->value != code->label2->value)
675 /* If (cond < 0) take branch1 else take branch2.
676 First build jumps to the COND .LT. 0 and the COND .EQ. 0 cases. */
677 branch1 = build1_v (GOTO_EXPR, gfc_get_label_decl (code->label));
678 branch2 = build1_v (GOTO_EXPR, gfc_get_label_decl (code->label2));
680 if (code->label->value != code->label3->value)
681 tmp = fold_build2 (LT_EXPR, boolean_type_node, se.expr, zero);
683 tmp = fold_build2 (NE_EXPR, boolean_type_node, se.expr, zero);
685 branch1 = fold_build3 (COND_EXPR, void_type_node, tmp, branch1, branch2);
688 branch1 = build1_v (GOTO_EXPR, gfc_get_label_decl (code->label));
690 if (code->label->value != code->label3->value
691 && code->label2->value != code->label3->value)
693 /* if (cond <= 0) take branch1 else take branch2. */
694 branch2 = build1_v (GOTO_EXPR, gfc_get_label_decl (code->label3));
695 tmp = fold_build2 (LE_EXPR, boolean_type_node, se.expr, zero);
696 branch1 = fold_build3 (COND_EXPR, void_type_node, tmp, branch1, branch2);
699 /* Append the COND_EXPR to the evaluation of COND, and return. */
700 gfc_add_expr_to_block (&se.pre, branch1);
701 return gfc_finish_block (&se.pre);
705 /* Translate the simple DO construct. This is where the loop variable has
706 integer type and step +-1. We can't use this in the general case
707 because integer overflow and floating point errors could give incorrect
709 We translate a do loop from:
711 DO dovar = from, to, step
717 [Evaluate loop bounds and step]
719 if ((step > 0) ? (dovar <= to) : (dovar => to))
725 cond = (dovar == to);
727 if (cond) goto end_label;
732 This helps the optimizers by avoiding the extra induction variable
733 used in the general case. */
736 gfc_trans_simple_do (gfc_code * code, stmtblock_t *pblock, tree dovar,
737 tree from, tree to, tree step)
746 type = TREE_TYPE (dovar);
748 /* Initialize the DO variable: dovar = from. */
749 gfc_add_modify_expr (pblock, dovar, from);
751 /* Cycle and exit statements are implemented with gotos. */
752 cycle_label = gfc_build_label_decl (NULL_TREE);
753 exit_label = gfc_build_label_decl (NULL_TREE);
755 /* Put the labels where they can be found later. See gfc_trans_do(). */
756 code->block->backend_decl = tree_cons (cycle_label, exit_label, NULL);
759 gfc_start_block (&body);
761 /* Main loop body. */
762 tmp = gfc_trans_code (code->block->next);
763 gfc_add_expr_to_block (&body, tmp);
765 /* Label for cycle statements (if needed). */
766 if (TREE_USED (cycle_label))
768 tmp = build1_v (LABEL_EXPR, cycle_label);
769 gfc_add_expr_to_block (&body, tmp);
772 /* Evaluate the loop condition. */
773 cond = fold_build2 (EQ_EXPR, boolean_type_node, dovar, to);
774 cond = gfc_evaluate_now (cond, &body);
776 /* Increment the loop variable. */
777 tmp = fold_build2 (PLUS_EXPR, type, dovar, step);
778 gfc_add_modify_expr (&body, dovar, tmp);
781 tmp = build1_v (GOTO_EXPR, exit_label);
782 TREE_USED (exit_label) = 1;
783 tmp = fold_build3 (COND_EXPR, void_type_node,
784 cond, tmp, build_empty_stmt ());
785 gfc_add_expr_to_block (&body, tmp);
787 /* Finish the loop body. */
788 tmp = gfc_finish_block (&body);
789 tmp = build1_v (LOOP_EXPR, tmp);
791 /* Only execute the loop if the number of iterations is positive. */
792 if (tree_int_cst_sgn (step) > 0)
793 cond = fold_build2 (LE_EXPR, boolean_type_node, dovar, to);
795 cond = fold_build2 (GE_EXPR, boolean_type_node, dovar, to);
796 tmp = fold_build3 (COND_EXPR, void_type_node,
797 cond, tmp, build_empty_stmt ());
798 gfc_add_expr_to_block (pblock, tmp);
800 /* Add the exit label. */
801 tmp = build1_v (LABEL_EXPR, exit_label);
802 gfc_add_expr_to_block (pblock, tmp);
804 return gfc_finish_block (pblock);
807 /* Translate the DO construct. This obviously is one of the most
808 important ones to get right with any compiler, but especially
811 We special case some loop forms as described in gfc_trans_simple_do.
812 For other cases we implement them with a separate loop count,
813 as described in the standard.
815 We translate a do loop from:
817 DO dovar = from, to, step
823 [evaluate loop bounds and step]
824 count = (to + step - from) / step;
832 if (count <=0) goto exit_label;
836 TODO: Large loop counts
837 The code above assumes the loop count fits into a signed integer kind,
838 i.e. Does not work for loop counts > 2^31 for integer(kind=4) variables
839 We must support the full range. */
842 gfc_trans_do (gfc_code * code)
859 gfc_start_block (&block);
861 /* Evaluate all the expressions in the iterator. */
862 gfc_init_se (&se, NULL);
863 gfc_conv_expr_lhs (&se, code->ext.iterator->var);
864 gfc_add_block_to_block (&block, &se.pre);
866 type = TREE_TYPE (dovar);
868 gfc_init_se (&se, NULL);
869 gfc_conv_expr_val (&se, code->ext.iterator->start);
870 gfc_add_block_to_block (&block, &se.pre);
871 from = gfc_evaluate_now (se.expr, &block);
873 gfc_init_se (&se, NULL);
874 gfc_conv_expr_val (&se, code->ext.iterator->end);
875 gfc_add_block_to_block (&block, &se.pre);
876 to = gfc_evaluate_now (se.expr, &block);
878 gfc_init_se (&se, NULL);
879 gfc_conv_expr_val (&se, code->ext.iterator->step);
880 gfc_add_block_to_block (&block, &se.pre);
881 step = gfc_evaluate_now (se.expr, &block);
883 /* Special case simple loops. */
884 if (TREE_CODE (type) == INTEGER_TYPE
885 && (integer_onep (step)
886 || tree_int_cst_equal (step, integer_minus_one_node)))
887 return gfc_trans_simple_do (code, &block, dovar, from, to, step);
889 /* Initialize loop count. This code is executed before we enter the
890 loop body. We generate: count = (to + step - from) / step. */
892 tmp = fold_build2 (MINUS_EXPR, type, step, from);
893 tmp = fold_build2 (PLUS_EXPR, type, to, tmp);
894 if (TREE_CODE (type) == INTEGER_TYPE)
896 tmp = fold_build2 (TRUNC_DIV_EXPR, type, tmp, step);
897 count = gfc_create_var (type, "count");
901 /* TODO: We could use the same width as the real type.
902 This would probably cause more problems that it solves
903 when we implement "long double" types. */
904 tmp = fold_build2 (RDIV_EXPR, type, tmp, step);
905 tmp = fold_build1 (FIX_TRUNC_EXPR, gfc_array_index_type, tmp);
906 count = gfc_create_var (gfc_array_index_type, "count");
908 gfc_add_modify_expr (&block, count, tmp);
910 count_one = build_int_cst (TREE_TYPE (count), 1);
912 /* Initialize the DO variable: dovar = from. */
913 gfc_add_modify_expr (&block, dovar, from);
916 gfc_start_block (&body);
918 /* Cycle and exit statements are implemented with gotos. */
919 cycle_label = gfc_build_label_decl (NULL_TREE);
920 exit_label = gfc_build_label_decl (NULL_TREE);
922 /* Start with the loop condition. Loop until count <= 0. */
923 cond = fold_build2 (LE_EXPR, boolean_type_node, count,
924 build_int_cst (TREE_TYPE (count), 0));
925 tmp = build1_v (GOTO_EXPR, exit_label);
926 TREE_USED (exit_label) = 1;
927 tmp = fold_build3 (COND_EXPR, void_type_node,
928 cond, tmp, build_empty_stmt ());
929 gfc_add_expr_to_block (&body, tmp);
931 /* Put these labels where they can be found later. We put the
932 labels in a TREE_LIST node (because TREE_CHAIN is already
933 used). cycle_label goes in TREE_PURPOSE (backend_decl), exit
934 label in TREE_VALUE (backend_decl). */
936 code->block->backend_decl = tree_cons (cycle_label, exit_label, NULL);
938 /* Main loop body. */
939 tmp = gfc_trans_code (code->block->next);
940 gfc_add_expr_to_block (&body, tmp);
942 /* Label for cycle statements (if needed). */
943 if (TREE_USED (cycle_label))
945 tmp = build1_v (LABEL_EXPR, cycle_label);
946 gfc_add_expr_to_block (&body, tmp);
949 /* Increment the loop variable. */
950 tmp = build2 (PLUS_EXPR, type, dovar, step);
951 gfc_add_modify_expr (&body, dovar, tmp);
953 /* Decrement the loop count. */
954 tmp = build2 (MINUS_EXPR, TREE_TYPE (count), count, count_one);
955 gfc_add_modify_expr (&body, count, tmp);
957 /* End of loop body. */
958 tmp = gfc_finish_block (&body);
960 /* The for loop itself. */
961 tmp = build1_v (LOOP_EXPR, tmp);
962 gfc_add_expr_to_block (&block, tmp);
964 /* Add the exit label. */
965 tmp = build1_v (LABEL_EXPR, exit_label);
966 gfc_add_expr_to_block (&block, tmp);
968 return gfc_finish_block (&block);
972 /* Translate the DO WHILE construct.
985 if (! cond) goto exit_label;
991 Because the evaluation of the exit condition `cond' may have side
992 effects, we can't do much for empty loop bodies. The backend optimizers
993 should be smart enough to eliminate any dead loops. */
996 gfc_trans_do_while (gfc_code * code)
1004 /* Everything we build here is part of the loop body. */
1005 gfc_start_block (&block);
1007 /* Cycle and exit statements are implemented with gotos. */
1008 cycle_label = gfc_build_label_decl (NULL_TREE);
1009 exit_label = gfc_build_label_decl (NULL_TREE);
1011 /* Put the labels where they can be found later. See gfc_trans_do(). */
1012 code->block->backend_decl = tree_cons (cycle_label, exit_label, NULL);
1014 /* Create a GIMPLE version of the exit condition. */
1015 gfc_init_se (&cond, NULL);
1016 gfc_conv_expr_val (&cond, code->expr);
1017 gfc_add_block_to_block (&block, &cond.pre);
1018 cond.expr = fold_build1 (TRUTH_NOT_EXPR, boolean_type_node, cond.expr);
1020 /* Build "IF (! cond) GOTO exit_label". */
1021 tmp = build1_v (GOTO_EXPR, exit_label);
1022 TREE_USED (exit_label) = 1;
1023 tmp = fold_build3 (COND_EXPR, void_type_node,
1024 cond.expr, tmp, build_empty_stmt ());
1025 gfc_add_expr_to_block (&block, tmp);
1027 /* The main body of the loop. */
1028 tmp = gfc_trans_code (code->block->next);
1029 gfc_add_expr_to_block (&block, tmp);
1031 /* Label for cycle statements (if needed). */
1032 if (TREE_USED (cycle_label))
1034 tmp = build1_v (LABEL_EXPR, cycle_label);
1035 gfc_add_expr_to_block (&block, tmp);
1038 /* End of loop body. */
1039 tmp = gfc_finish_block (&block);
1041 gfc_init_block (&block);
1042 /* Build the loop. */
1043 tmp = build1_v (LOOP_EXPR, tmp);
1044 gfc_add_expr_to_block (&block, tmp);
1046 /* Add the exit label. */
1047 tmp = build1_v (LABEL_EXPR, exit_label);
1048 gfc_add_expr_to_block (&block, tmp);
1050 return gfc_finish_block (&block);
1054 /* Translate the SELECT CASE construct for INTEGER case expressions,
1055 without killing all potential optimizations. The problem is that
1056 Fortran allows unbounded cases, but the back-end does not, so we
1057 need to intercept those before we enter the equivalent SWITCH_EXPR
1060 For example, we translate this,
1063 CASE (:100,101,105:115)
1073 to the GENERIC equivalent,
1077 case (minimum value for typeof(expr) ... 100:
1083 case 200 ... (maximum value for typeof(expr):
1100 gfc_trans_integer_select (gfc_code * code)
1110 gfc_start_block (&block);
1112 /* Calculate the switch expression. */
1113 gfc_init_se (&se, NULL);
1114 gfc_conv_expr_val (&se, code->expr);
1115 gfc_add_block_to_block (&block, &se.pre);
1117 end_label = gfc_build_label_decl (NULL_TREE);
1119 gfc_init_block (&body);
1121 for (c = code->block; c; c = c->block)
1123 for (cp = c->ext.case_list; cp; cp = cp->next)
1128 /* Assume it's the default case. */
1129 low = high = NULL_TREE;
1133 low = gfc_conv_constant_to_tree (cp->low);
1135 /* If there's only a lower bound, set the high bound to the
1136 maximum value of the case expression. */
1138 high = TYPE_MAX_VALUE (TREE_TYPE (se.expr));
1143 /* Three cases are possible here:
1145 1) There is no lower bound, e.g. CASE (:N).
1146 2) There is a lower bound .NE. high bound, that is
1147 a case range, e.g. CASE (N:M) where M>N (we make
1148 sure that M>N during type resolution).
1149 3) There is a lower bound, and it has the same value
1150 as the high bound, e.g. CASE (N:N). This is our
1151 internal representation of CASE(N).
1153 In the first and second case, we need to set a value for
1154 high. In the third case, we don't because the GCC middle
1155 end represents a single case value by just letting high be
1156 a NULL_TREE. We can't do that because we need to be able
1157 to represent unbounded cases. */
1161 && mpz_cmp (cp->low->value.integer,
1162 cp->high->value.integer) != 0))
1163 high = gfc_conv_constant_to_tree (cp->high);
1165 /* Unbounded case. */
1167 low = TYPE_MIN_VALUE (TREE_TYPE (se.expr));
1170 /* Build a label. */
1171 label = gfc_build_label_decl (NULL_TREE);
1173 /* Add this case label.
1174 Add parameter 'label', make it match GCC backend. */
1175 tmp = build3 (CASE_LABEL_EXPR, void_type_node, low, high, label);
1176 gfc_add_expr_to_block (&body, tmp);
1179 /* Add the statements for this case. */
1180 tmp = gfc_trans_code (c->next);
1181 gfc_add_expr_to_block (&body, tmp);
1183 /* Break to the end of the construct. */
1184 tmp = build1_v (GOTO_EXPR, end_label);
1185 gfc_add_expr_to_block (&body, tmp);
1188 tmp = gfc_finish_block (&body);
1189 tmp = build3_v (SWITCH_EXPR, se.expr, tmp, NULL_TREE);
1190 gfc_add_expr_to_block (&block, tmp);
1192 tmp = build1_v (LABEL_EXPR, end_label);
1193 gfc_add_expr_to_block (&block, tmp);
1195 return gfc_finish_block (&block);
1199 /* Translate the SELECT CASE construct for LOGICAL case expressions.
1201 There are only two cases possible here, even though the standard
1202 does allow three cases in a LOGICAL SELECT CASE construct: .TRUE.,
1203 .FALSE., and DEFAULT.
1205 We never generate more than two blocks here. Instead, we always
1206 try to eliminate the DEFAULT case. This way, we can translate this
1207 kind of SELECT construct to a simple
1211 expression in GENERIC. */
1214 gfc_trans_logical_select (gfc_code * code)
1217 gfc_code *t, *f, *d;
1222 /* Assume we don't have any cases at all. */
1225 /* Now see which ones we actually do have. We can have at most two
1226 cases in a single case list: one for .TRUE. and one for .FALSE.
1227 The default case is always separate. If the cases for .TRUE. and
1228 .FALSE. are in the same case list, the block for that case list
1229 always executed, and we don't generate code a COND_EXPR. */
1230 for (c = code->block; c; c = c->block)
1232 for (cp = c->ext.case_list; cp; cp = cp->next)
1236 if (cp->low->value.logical == 0) /* .FALSE. */
1238 else /* if (cp->value.logical != 0), thus .TRUE. */
1246 /* Start a new block. */
1247 gfc_start_block (&block);
1249 /* Calculate the switch expression. We always need to do this
1250 because it may have side effects. */
1251 gfc_init_se (&se, NULL);
1252 gfc_conv_expr_val (&se, code->expr);
1253 gfc_add_block_to_block (&block, &se.pre);
1255 if (t == f && t != NULL)
1257 /* Cases for .TRUE. and .FALSE. are in the same block. Just
1258 translate the code for these cases, append it to the current
1260 gfc_add_expr_to_block (&block, gfc_trans_code (t->next));
1264 tree true_tree, false_tree, stmt;
1266 true_tree = build_empty_stmt ();
1267 false_tree = build_empty_stmt ();
1269 /* If we have a case for .TRUE. and for .FALSE., discard the default case.
1270 Otherwise, if .TRUE. or .FALSE. is missing and there is a default case,
1271 make the missing case the default case. */
1272 if (t != NULL && f != NULL)
1282 /* Translate the code for each of these blocks, and append it to
1283 the current block. */
1285 true_tree = gfc_trans_code (t->next);
1288 false_tree = gfc_trans_code (f->next);
1290 stmt = fold_build3 (COND_EXPR, void_type_node, se.expr,
1291 true_tree, false_tree);
1292 gfc_add_expr_to_block (&block, stmt);
1295 return gfc_finish_block (&block);
1299 /* Translate the SELECT CASE construct for CHARACTER case expressions.
1300 Instead of generating compares and jumps, it is far simpler to
1301 generate a data structure describing the cases in order and call a
1302 library subroutine that locates the right case.
1303 This is particularly true because this is the only case where we
1304 might have to dispose of a temporary.
1305 The library subroutine returns a pointer to jump to or NULL if no
1306 branches are to be taken. */
1309 gfc_trans_character_select (gfc_code *code)
1311 tree init, node, end_label, tmp, type, args, *labels;
1313 stmtblock_t block, body;
1319 static tree select_struct;
1320 static tree ss_string1, ss_string1_len;
1321 static tree ss_string2, ss_string2_len;
1322 static tree ss_target;
1324 if (select_struct == NULL)
1326 tree gfc_int4_type_node = gfc_get_int_type (4);
1328 select_struct = make_node (RECORD_TYPE);
1329 TYPE_NAME (select_struct) = get_identifier ("_jump_struct");
1332 #define ADD_FIELD(NAME, TYPE) \
1333 ss_##NAME = gfc_add_field_to_struct \
1334 (&(TYPE_FIELDS (select_struct)), select_struct, \
1335 get_identifier (stringize(NAME)), TYPE)
1337 ADD_FIELD (string1, pchar_type_node);
1338 ADD_FIELD (string1_len, gfc_int4_type_node);
1340 ADD_FIELD (string2, pchar_type_node);
1341 ADD_FIELD (string2_len, gfc_int4_type_node);
1343 ADD_FIELD (target, pvoid_type_node);
1346 gfc_finish_type (select_struct);
1349 cp = code->block->ext.case_list;
1350 while (cp->left != NULL)
1354 for (d = cp; d; d = d->right)
1358 labels = gfc_getmem (n * sizeof (tree));
1362 for(i = 0; i < n; i++)
1364 labels[i] = gfc_build_label_decl (NULL_TREE);
1365 TREE_USED (labels[i]) = 1;
1366 /* TODO: The gimplifier should do this for us, but it has
1367 inadequacies when dealing with static initializers. */
1368 FORCED_LABEL (labels[i]) = 1;
1371 end_label = gfc_build_label_decl (NULL_TREE);
1373 /* Generate the body */
1374 gfc_start_block (&block);
1375 gfc_init_block (&body);
1377 for (c = code->block; c; c = c->block)
1379 for (d = c->ext.case_list; d; d = d->next)
1381 tmp = build1_v (LABEL_EXPR, labels[d->n]);
1382 gfc_add_expr_to_block (&body, tmp);
1385 tmp = gfc_trans_code (c->next);
1386 gfc_add_expr_to_block (&body, tmp);
1388 tmp = build1_v (GOTO_EXPR, end_label);
1389 gfc_add_expr_to_block (&body, tmp);
1392 /* Generate the structure describing the branches */
1396 for(d = cp; d; d = d->right, i++)
1400 gfc_init_se (&se, NULL);
1404 node = tree_cons (ss_string1, null_pointer_node, node);
1405 node = tree_cons (ss_string1_len, integer_zero_node, node);
1409 gfc_conv_expr_reference (&se, d->low);
1411 node = tree_cons (ss_string1, se.expr, node);
1412 node = tree_cons (ss_string1_len, se.string_length, node);
1415 if (d->high == NULL)
1417 node = tree_cons (ss_string2, null_pointer_node, node);
1418 node = tree_cons (ss_string2_len, integer_zero_node, node);
1422 gfc_init_se (&se, NULL);
1423 gfc_conv_expr_reference (&se, d->high);
1425 node = tree_cons (ss_string2, se.expr, node);
1426 node = tree_cons (ss_string2_len, se.string_length, node);
1429 tmp = gfc_build_addr_expr (pvoid_type_node, labels[i]);
1430 node = tree_cons (ss_target, tmp, node);
1432 tmp = build_constructor_from_list (select_struct, nreverse (node));
1433 init = tree_cons (NULL_TREE, tmp, init);
1436 type = build_array_type (select_struct, build_index_type
1437 (build_int_cst (NULL_TREE, n - 1)));
1439 init = build_constructor_from_list (type, nreverse(init));
1440 TREE_CONSTANT (init) = 1;
1441 TREE_INVARIANT (init) = 1;
1442 TREE_STATIC (init) = 1;
1443 /* Create a static variable to hold the jump table. */
1444 tmp = gfc_create_var (type, "jumptable");
1445 TREE_CONSTANT (tmp) = 1;
1446 TREE_INVARIANT (tmp) = 1;
1447 TREE_STATIC (tmp) = 1;
1448 TREE_READONLY (tmp) = 1;
1449 DECL_INITIAL (tmp) = init;
1452 /* Build an argument list for the library call */
1453 init = gfc_build_addr_expr (pvoid_type_node, init);
1454 args = gfc_chainon_list (NULL_TREE, init);
1456 tmp = build_int_cst (NULL_TREE, n);
1457 args = gfc_chainon_list (args, tmp);
1459 tmp = gfc_build_addr_expr (pvoid_type_node, end_label);
1460 args = gfc_chainon_list (args, tmp);
1462 gfc_init_se (&se, NULL);
1463 gfc_conv_expr_reference (&se, code->expr);
1465 args = gfc_chainon_list (args, se.expr);
1466 args = gfc_chainon_list (args, se.string_length);
1468 gfc_add_block_to_block (&block, &se.pre);
1470 tmp = build_function_call_expr (gfor_fndecl_select_string, args);
1471 case_label = gfc_create_var (TREE_TYPE (tmp), "case_label");
1472 gfc_add_modify_expr (&block, case_label, tmp);
1474 gfc_add_block_to_block (&block, &se.post);
1476 tmp = build1 (GOTO_EXPR, void_type_node, case_label);
1477 gfc_add_expr_to_block (&block, tmp);
1479 tmp = gfc_finish_block (&body);
1480 gfc_add_expr_to_block (&block, tmp);
1481 tmp = build1_v (LABEL_EXPR, end_label);
1482 gfc_add_expr_to_block (&block, tmp);
1487 return gfc_finish_block (&block);
1491 /* Translate the three variants of the SELECT CASE construct.
1493 SELECT CASEs with INTEGER case expressions can be translated to an
1494 equivalent GENERIC switch statement, and for LOGICAL case
1495 expressions we build one or two if-else compares.
1497 SELECT CASEs with CHARACTER case expressions are a whole different
1498 story, because they don't exist in GENERIC. So we sort them and
1499 do a binary search at runtime.
1501 Fortran has no BREAK statement, and it does not allow jumps from
1502 one case block to another. That makes things a lot easier for
1506 gfc_trans_select (gfc_code * code)
1508 gcc_assert (code && code->expr);
1510 /* Empty SELECT constructs are legal. */
1511 if (code->block == NULL)
1512 return build_empty_stmt ();
1514 /* Select the correct translation function. */
1515 switch (code->expr->ts.type)
1517 case BT_LOGICAL: return gfc_trans_logical_select (code);
1518 case BT_INTEGER: return gfc_trans_integer_select (code);
1519 case BT_CHARACTER: return gfc_trans_character_select (code);
1521 gfc_internal_error ("gfc_trans_select(): Bad type for case expr.");
1527 /* Generate the loops for a FORALL block, specified by FORALL_TMP. BODY
1528 is the contents of the FORALL block/stmt to be iterated. MASK_FLAG
1529 indicates whether we should generate code to test the FORALLs mask
1530 array. OUTER is the loop header to be used for initializing mask
1533 The generated loop format is:
1534 count = (end - start + step) / step
1547 gfc_trans_forall_loop (forall_info *forall_tmp, tree body,
1548 int mask_flag, stmtblock_t *outer)
1556 tree var, start, end, step;
1559 /* Initialize the mask index outside the FORALL nest. */
1560 if (mask_flag && forall_tmp->mask)
1561 gfc_add_modify_expr (outer, forall_tmp->maskindex, gfc_index_zero_node);
1563 iter = forall_tmp->this_loop;
1564 nvar = forall_tmp->nvar;
1565 for (n = 0; n < nvar; n++)
1568 start = iter->start;
1572 exit_label = gfc_build_label_decl (NULL_TREE);
1573 TREE_USED (exit_label) = 1;
1575 /* The loop counter. */
1576 count = gfc_create_var (TREE_TYPE (var), "count");
1578 /* The body of the loop. */
1579 gfc_init_block (&block);
1581 /* The exit condition. */
1582 cond = fold_build2 (LE_EXPR, boolean_type_node,
1583 count, build_int_cst (TREE_TYPE (count), 0));
1584 tmp = build1_v (GOTO_EXPR, exit_label);
1585 tmp = fold_build3 (COND_EXPR, void_type_node,
1586 cond, tmp, build_empty_stmt ());
1587 gfc_add_expr_to_block (&block, tmp);
1589 /* The main loop body. */
1590 gfc_add_expr_to_block (&block, body);
1592 /* Increment the loop variable. */
1593 tmp = build2 (PLUS_EXPR, TREE_TYPE (var), var, step);
1594 gfc_add_modify_expr (&block, var, tmp);
1596 /* Advance to the next mask element. Only do this for the
1598 if (n == 0 && mask_flag && forall_tmp->mask)
1600 tree maskindex = forall_tmp->maskindex;
1601 tmp = build2 (PLUS_EXPR, gfc_array_index_type,
1602 maskindex, gfc_index_one_node);
1603 gfc_add_modify_expr (&block, maskindex, tmp);
1606 /* Decrement the loop counter. */
1607 tmp = build2 (MINUS_EXPR, TREE_TYPE (var), count, gfc_index_one_node);
1608 gfc_add_modify_expr (&block, count, tmp);
1610 body = gfc_finish_block (&block);
1612 /* Loop var initialization. */
1613 gfc_init_block (&block);
1614 gfc_add_modify_expr (&block, var, start);
1617 /* Initialize the loop counter. */
1618 tmp = fold_build2 (MINUS_EXPR, TREE_TYPE (var), step, start);
1619 tmp = fold_build2 (PLUS_EXPR, TREE_TYPE (var), end, tmp);
1620 tmp = fold_build2 (TRUNC_DIV_EXPR, TREE_TYPE (var), tmp, step);
1621 gfc_add_modify_expr (&block, count, tmp);
1623 /* The loop expression. */
1624 tmp = build1_v (LOOP_EXPR, body);
1625 gfc_add_expr_to_block (&block, tmp);
1627 /* The exit label. */
1628 tmp = build1_v (LABEL_EXPR, exit_label);
1629 gfc_add_expr_to_block (&block, tmp);
1631 body = gfc_finish_block (&block);
1638 /* Generate the body and loops according to MASK_FLAG. If MASK_FLAG
1639 is nonzero, the body is controlled by all masks in the forall nest.
1640 Otherwise, the innermost loop is not controlled by it's mask. This
1641 is used for initializing that mask. */
1644 gfc_trans_nested_forall_loop (forall_info * nested_forall_info, tree body,
1649 forall_info *forall_tmp;
1650 tree mask, maskindex;
1652 gfc_start_block (&header);
1654 forall_tmp = nested_forall_info;
1655 while (forall_tmp != NULL)
1657 /* Generate body with masks' control. */
1660 mask = forall_tmp->mask;
1661 maskindex = forall_tmp->maskindex;
1663 /* If a mask was specified make the assignment conditional. */
1666 tmp = gfc_build_array_ref (mask, maskindex);
1667 body = build3_v (COND_EXPR, tmp, body, build_empty_stmt ());
1670 body = gfc_trans_forall_loop (forall_tmp, body, mask_flag, &header);
1671 forall_tmp = forall_tmp->prev_nest;
1675 gfc_add_expr_to_block (&header, body);
1676 return gfc_finish_block (&header);
1680 /* Allocate data for holding a temporary array. Returns either a local
1681 temporary array or a pointer variable. */
1684 gfc_do_allocate (tree bytesize, tree size, tree * pdata, stmtblock_t * pblock,
1692 if (INTEGER_CST_P (size))
1694 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, size,
1695 gfc_index_one_node);
1700 type = build_range_type (gfc_array_index_type, gfc_index_zero_node, tmp);
1701 type = build_array_type (elem_type, type);
1702 if (gfc_can_put_var_on_stack (bytesize))
1704 gcc_assert (INTEGER_CST_P (size));
1705 tmpvar = gfc_create_var (type, "temp");
1710 tmpvar = gfc_create_var (build_pointer_type (type), "temp");
1711 *pdata = convert (pvoid_type_node, tmpvar);
1713 args = gfc_chainon_list (NULL_TREE, bytesize);
1714 if (gfc_index_integer_kind == 4)
1715 tmp = gfor_fndecl_internal_malloc;
1716 else if (gfc_index_integer_kind == 8)
1717 tmp = gfor_fndecl_internal_malloc64;
1720 tmp = build_function_call_expr (tmp, args);
1721 tmp = convert (TREE_TYPE (tmpvar), tmp);
1722 gfc_add_modify_expr (pblock, tmpvar, tmp);
1728 /* Generate codes to copy the temporary to the actual lhs. */
1731 generate_loop_for_temp_to_lhs (gfc_expr *expr, tree tmp1, tree count3,
1732 tree count1, tree wheremask, bool invert)
1736 stmtblock_t block, body;
1742 lss = gfc_walk_expr (expr);
1744 if (lss == gfc_ss_terminator)
1746 gfc_start_block (&block);
1748 gfc_init_se (&lse, NULL);
1750 /* Translate the expression. */
1751 gfc_conv_expr (&lse, expr);
1753 /* Form the expression for the temporary. */
1754 tmp = gfc_build_array_ref (tmp1, count1);
1756 /* Use the scalar assignment as is. */
1757 gfc_add_block_to_block (&block, &lse.pre);
1758 gfc_add_modify_expr (&block, lse.expr, tmp);
1759 gfc_add_block_to_block (&block, &lse.post);
1761 /* Increment the count1. */
1762 tmp = fold_build2 (PLUS_EXPR, TREE_TYPE (count1), count1,
1763 gfc_index_one_node);
1764 gfc_add_modify_expr (&block, count1, tmp);
1766 tmp = gfc_finish_block (&block);
1770 gfc_start_block (&block);
1772 gfc_init_loopinfo (&loop1);
1773 gfc_init_se (&rse, NULL);
1774 gfc_init_se (&lse, NULL);
1776 /* Associate the lss with the loop. */
1777 gfc_add_ss_to_loop (&loop1, lss);
1779 /* Calculate the bounds of the scalarization. */
1780 gfc_conv_ss_startstride (&loop1);
1781 /* Setup the scalarizing loops. */
1782 gfc_conv_loop_setup (&loop1);
1784 gfc_mark_ss_chain_used (lss, 1);
1786 /* Start the scalarized loop body. */
1787 gfc_start_scalarized_body (&loop1, &body);
1789 /* Setup the gfc_se structures. */
1790 gfc_copy_loopinfo_to_se (&lse, &loop1);
1793 /* Form the expression of the temporary. */
1794 if (lss != gfc_ss_terminator)
1795 rse.expr = gfc_build_array_ref (tmp1, count1);
1796 /* Translate expr. */
1797 gfc_conv_expr (&lse, expr);
1799 /* Use the scalar assignment. */
1800 rse.string_length = lse.string_length;
1801 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, false);
1803 /* Form the mask expression according to the mask tree list. */
1806 wheremaskexpr = gfc_build_array_ref (wheremask, count3);
1808 wheremaskexpr = fold_build1 (TRUTH_NOT_EXPR,
1809 TREE_TYPE (wheremaskexpr),
1811 tmp = fold_build3 (COND_EXPR, void_type_node,
1812 wheremaskexpr, tmp, build_empty_stmt ());
1815 gfc_add_expr_to_block (&body, tmp);
1817 /* Increment count1. */
1818 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1819 count1, gfc_index_one_node);
1820 gfc_add_modify_expr (&body, count1, tmp);
1822 /* Increment count3. */
1825 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1826 count3, gfc_index_one_node);
1827 gfc_add_modify_expr (&body, count3, tmp);
1830 /* Generate the copying loops. */
1831 gfc_trans_scalarizing_loops (&loop1, &body);
1832 gfc_add_block_to_block (&block, &loop1.pre);
1833 gfc_add_block_to_block (&block, &loop1.post);
1834 gfc_cleanup_loop (&loop1);
1836 tmp = gfc_finish_block (&block);
1842 /* Generate codes to copy rhs to the temporary. TMP1 is the address of
1843 temporary, LSS and RSS are formed in function compute_inner_temp_size(),
1844 and should not be freed. WHEREMASK is the conditional execution mask
1845 whose sense may be inverted by INVERT. */
1848 generate_loop_for_rhs_to_temp (gfc_expr *expr2, tree tmp1, tree count3,
1849 tree count1, gfc_ss *lss, gfc_ss *rss,
1850 tree wheremask, bool invert)
1852 stmtblock_t block, body1;
1859 gfc_start_block (&block);
1861 gfc_init_se (&rse, NULL);
1862 gfc_init_se (&lse, NULL);
1864 if (lss == gfc_ss_terminator)
1866 gfc_init_block (&body1);
1867 gfc_conv_expr (&rse, expr2);
1868 lse.expr = gfc_build_array_ref (tmp1, count1);
1872 /* Initialize the loop. */
1873 gfc_init_loopinfo (&loop);
1875 /* We may need LSS to determine the shape of the expression. */
1876 gfc_add_ss_to_loop (&loop, lss);
1877 gfc_add_ss_to_loop (&loop, rss);
1879 gfc_conv_ss_startstride (&loop);
1880 gfc_conv_loop_setup (&loop);
1882 gfc_mark_ss_chain_used (rss, 1);
1883 /* Start the loop body. */
1884 gfc_start_scalarized_body (&loop, &body1);
1886 /* Translate the expression. */
1887 gfc_copy_loopinfo_to_se (&rse, &loop);
1889 gfc_conv_expr (&rse, expr2);
1891 /* Form the expression of the temporary. */
1892 lse.expr = gfc_build_array_ref (tmp1, count1);
1895 /* Use the scalar assignment. */
1896 lse.string_length = rse.string_length;
1897 tmp = gfc_trans_scalar_assign (&lse, &rse, expr2->ts, true,
1898 expr2->expr_type == EXPR_VARIABLE);
1900 /* Form the mask expression according to the mask tree list. */
1903 wheremaskexpr = gfc_build_array_ref (wheremask, count3);
1905 wheremaskexpr = fold_build1 (TRUTH_NOT_EXPR,
1906 TREE_TYPE (wheremaskexpr),
1908 tmp = fold_build3 (COND_EXPR, void_type_node,
1909 wheremaskexpr, tmp, build_empty_stmt ());
1912 gfc_add_expr_to_block (&body1, tmp);
1914 if (lss == gfc_ss_terminator)
1916 gfc_add_block_to_block (&block, &body1);
1918 /* Increment count1. */
1919 tmp = fold_build2 (PLUS_EXPR, TREE_TYPE (count1), count1,
1920 gfc_index_one_node);
1921 gfc_add_modify_expr (&block, count1, tmp);
1925 /* Increment count1. */
1926 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1927 count1, gfc_index_one_node);
1928 gfc_add_modify_expr (&body1, count1, tmp);
1930 /* Increment count3. */
1933 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1934 count3, gfc_index_one_node);
1935 gfc_add_modify_expr (&body1, count3, tmp);
1938 /* Generate the copying loops. */
1939 gfc_trans_scalarizing_loops (&loop, &body1);
1941 gfc_add_block_to_block (&block, &loop.pre);
1942 gfc_add_block_to_block (&block, &loop.post);
1944 gfc_cleanup_loop (&loop);
1945 /* TODO: Reuse lss and rss when copying temp->lhs. Need to be careful
1946 as tree nodes in SS may not be valid in different scope. */
1949 tmp = gfc_finish_block (&block);
1954 /* Calculate the size of temporary needed in the assignment inside forall.
1955 LSS and RSS are filled in this function. */
1958 compute_inner_temp_size (gfc_expr *expr1, gfc_expr *expr2,
1959 stmtblock_t * pblock,
1960 gfc_ss **lss, gfc_ss **rss)
1968 *lss = gfc_walk_expr (expr1);
1971 size = gfc_index_one_node;
1972 if (*lss != gfc_ss_terminator)
1974 gfc_init_loopinfo (&loop);
1976 /* Walk the RHS of the expression. */
1977 *rss = gfc_walk_expr (expr2);
1978 if (*rss == gfc_ss_terminator)
1980 /* The rhs is scalar. Add a ss for the expression. */
1981 *rss = gfc_get_ss ();
1982 (*rss)->next = gfc_ss_terminator;
1983 (*rss)->type = GFC_SS_SCALAR;
1984 (*rss)->expr = expr2;
1987 /* Associate the SS with the loop. */
1988 gfc_add_ss_to_loop (&loop, *lss);
1989 /* We don't actually need to add the rhs at this point, but it might
1990 make guessing the loop bounds a bit easier. */
1991 gfc_add_ss_to_loop (&loop, *rss);
1993 /* We only want the shape of the expression, not rest of the junk
1994 generated by the scalarizer. */
1995 loop.array_parameter = 1;
1997 /* Calculate the bounds of the scalarization. */
1998 save_flag = flag_bounds_check;
1999 flag_bounds_check = 0;
2000 gfc_conv_ss_startstride (&loop);
2001 flag_bounds_check = save_flag;
2002 gfc_conv_loop_setup (&loop);
2004 /* Figure out how many elements we need. */
2005 for (i = 0; i < loop.dimen; i++)
2007 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
2008 gfc_index_one_node, loop.from[i]);
2009 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2011 size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
2013 gfc_add_block_to_block (pblock, &loop.pre);
2014 size = gfc_evaluate_now (size, pblock);
2015 gfc_add_block_to_block (pblock, &loop.post);
2017 /* TODO: write a function that cleans up a loopinfo without freeing
2018 the SS chains. Currently a NOP. */
2025 /* Calculate the overall iterator number of the nested forall construct.
2026 This routine actually calculates the number of times the body of the
2027 nested forall specified by NESTED_FORALL_INFO is executed and multiplies
2028 that by the expression INNER_SIZE. The BLOCK argument specifies the
2029 block in which to calculate the result, and the optional INNER_SIZE_BODY
2030 argument contains any statements that need to executed (inside the loop)
2031 to initialize or calculate INNER_SIZE. */
2034 compute_overall_iter_number (forall_info *nested_forall_info, tree inner_size,
2035 stmtblock_t *inner_size_body, stmtblock_t *block)
2037 forall_info *forall_tmp = nested_forall_info;
2041 /* We can eliminate the innermost unconditional loops with constant
2043 if (INTEGER_CST_P (inner_size))
2046 && !forall_tmp->mask
2047 && INTEGER_CST_P (forall_tmp->size))
2049 inner_size = fold_build2 (MULT_EXPR, gfc_array_index_type,
2050 inner_size, forall_tmp->size);
2051 forall_tmp = forall_tmp->prev_nest;
2054 /* If there are no loops left, we have our constant result. */
2059 /* Otherwise, create a temporary variable to compute the result. */
2060 number = gfc_create_var (gfc_array_index_type, "num");
2061 gfc_add_modify_expr (block, number, gfc_index_zero_node);
2063 gfc_start_block (&body);
2064 if (inner_size_body)
2065 gfc_add_block_to_block (&body, inner_size_body);
2067 tmp = build2 (PLUS_EXPR, gfc_array_index_type, number,
2071 gfc_add_modify_expr (&body, number, tmp);
2072 tmp = gfc_finish_block (&body);
2074 /* Generate loops. */
2075 if (forall_tmp != NULL)
2076 tmp = gfc_trans_nested_forall_loop (forall_tmp, tmp, 1);
2078 gfc_add_expr_to_block (block, tmp);
2084 /* Allocate temporary for forall construct. SIZE is the size of temporary
2085 needed. PTEMP1 is returned for space free. */
2088 allocate_temp_for_forall_nest_1 (tree type, tree size, stmtblock_t * block,
2095 unit = TYPE_SIZE_UNIT (type);
2096 if (!integer_onep (unit))
2097 bytesize = fold_build2 (MULT_EXPR, gfc_array_index_type, size, unit);
2102 tmp = gfc_do_allocate (bytesize, size, ptemp1, block, type);
2105 tmp = build_fold_indirect_ref (tmp);
2110 /* Allocate temporary for forall construct according to the information in
2111 nested_forall_info. INNER_SIZE is the size of temporary needed in the
2112 assignment inside forall. PTEMP1 is returned for space free. */
2115 allocate_temp_for_forall_nest (forall_info * nested_forall_info, tree type,
2116 tree inner_size, stmtblock_t * inner_size_body,
2117 stmtblock_t * block, tree * ptemp1)
2121 /* Calculate the total size of temporary needed in forall construct. */
2122 size = compute_overall_iter_number (nested_forall_info, inner_size,
2123 inner_size_body, block);
2125 return allocate_temp_for_forall_nest_1 (type, size, block, ptemp1);
2129 /* Handle assignments inside forall which need temporary.
2131 forall (i=start:end:stride; maskexpr)
2134 (where e,f<i> are arbitrary expressions possibly involving i
2135 and there is a dependency between e<i> and f<i>)
2137 masktmp(:) = maskexpr(:)
2142 for (i = start; i <= end; i += stride)
2146 for (i = start; i <= end; i += stride)
2148 if (masktmp[maskindex++])
2149 tmp[count1++] = f<i>
2153 for (i = start; i <= end; i += stride)
2155 if (masktmp[maskindex++])
2156 e<i> = tmp[count1++]
2161 gfc_trans_assign_need_temp (gfc_expr * expr1, gfc_expr * expr2,
2162 tree wheremask, bool invert,
2163 forall_info * nested_forall_info,
2164 stmtblock_t * block)
2172 stmtblock_t inner_size_body;
2174 /* Create vars. count1 is the current iterator number of the nested
2176 count1 = gfc_create_var (gfc_array_index_type, "count1");
2178 /* Count is the wheremask index. */
2181 count = gfc_create_var (gfc_array_index_type, "count");
2182 gfc_add_modify_expr (block, count, gfc_index_zero_node);
2187 /* Initialize count1. */
2188 gfc_add_modify_expr (block, count1, gfc_index_zero_node);
2190 /* Calculate the size of temporary needed in the assignment. Return loop, lss
2191 and rss which are used in function generate_loop_for_rhs_to_temp(). */
2192 gfc_init_block (&inner_size_body);
2193 inner_size = compute_inner_temp_size (expr1, expr2, &inner_size_body,
2196 /* The type of LHS. Used in function allocate_temp_for_forall_nest */
2197 type = gfc_typenode_for_spec (&expr1->ts);
2199 /* Allocate temporary for nested forall construct according to the
2200 information in nested_forall_info and inner_size. */
2201 tmp1 = allocate_temp_for_forall_nest (nested_forall_info, type, inner_size,
2202 &inner_size_body, block, &ptemp1);
2204 /* Generate codes to copy rhs to the temporary . */
2205 tmp = generate_loop_for_rhs_to_temp (expr2, tmp1, count, count1, lss, rss,
2208 /* Generate body and loops according to the information in
2209 nested_forall_info. */
2210 tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1);
2211 gfc_add_expr_to_block (block, tmp);
2214 gfc_add_modify_expr (block, count1, gfc_index_zero_node);
2218 gfc_add_modify_expr (block, count, gfc_index_zero_node);
2220 /* Generate codes to copy the temporary to lhs. */
2221 tmp = generate_loop_for_temp_to_lhs (expr1, tmp1, count, count1,
2224 /* Generate body and loops according to the information in
2225 nested_forall_info. */
2226 tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1);
2227 gfc_add_expr_to_block (block, tmp);
2231 /* Free the temporary. */
2232 tmp = gfc_chainon_list (NULL_TREE, ptemp1);
2233 tmp = build_function_call_expr (gfor_fndecl_internal_free, tmp);
2234 gfc_add_expr_to_block (block, tmp);
2239 /* Translate pointer assignment inside FORALL which need temporary. */
2242 gfc_trans_pointer_assign_need_temp (gfc_expr * expr1, gfc_expr * expr2,
2243 forall_info * nested_forall_info,
2244 stmtblock_t * block)
2258 tree tmp, tmp1, ptemp1;
2260 count = gfc_create_var (gfc_array_index_type, "count");
2261 gfc_add_modify_expr (block, count, gfc_index_zero_node);
2263 inner_size = integer_one_node;
2264 lss = gfc_walk_expr (expr1);
2265 rss = gfc_walk_expr (expr2);
2266 if (lss == gfc_ss_terminator)
2268 type = gfc_typenode_for_spec (&expr1->ts);
2269 type = build_pointer_type (type);
2271 /* Allocate temporary for nested forall construct according to the
2272 information in nested_forall_info and inner_size. */
2273 tmp1 = allocate_temp_for_forall_nest (nested_forall_info, type,
2274 inner_size, NULL, block, &ptemp1);
2275 gfc_start_block (&body);
2276 gfc_init_se (&lse, NULL);
2277 lse.expr = gfc_build_array_ref (tmp1, count);
2278 gfc_init_se (&rse, NULL);
2279 rse.want_pointer = 1;
2280 gfc_conv_expr (&rse, expr2);
2281 gfc_add_block_to_block (&body, &rse.pre);
2282 gfc_add_modify_expr (&body, lse.expr,
2283 fold_convert (TREE_TYPE (lse.expr), rse.expr));
2284 gfc_add_block_to_block (&body, &rse.post);
2286 /* Increment count. */
2287 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2288 count, gfc_index_one_node);
2289 gfc_add_modify_expr (&body, count, tmp);
2291 tmp = gfc_finish_block (&body);
2293 /* Generate body and loops according to the information in
2294 nested_forall_info. */
2295 tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1);
2296 gfc_add_expr_to_block (block, tmp);
2299 gfc_add_modify_expr (block, count, gfc_index_zero_node);
2301 gfc_start_block (&body);
2302 gfc_init_se (&lse, NULL);
2303 gfc_init_se (&rse, NULL);
2304 rse.expr = gfc_build_array_ref (tmp1, count);
2305 lse.want_pointer = 1;
2306 gfc_conv_expr (&lse, expr1);
2307 gfc_add_block_to_block (&body, &lse.pre);
2308 gfc_add_modify_expr (&body, lse.expr, rse.expr);
2309 gfc_add_block_to_block (&body, &lse.post);
2310 /* Increment count. */
2311 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2312 count, gfc_index_one_node);
2313 gfc_add_modify_expr (&body, count, tmp);
2314 tmp = gfc_finish_block (&body);
2316 /* Generate body and loops according to the information in
2317 nested_forall_info. */
2318 tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1);
2319 gfc_add_expr_to_block (block, tmp);
2323 gfc_init_loopinfo (&loop);
2325 /* Associate the SS with the loop. */
2326 gfc_add_ss_to_loop (&loop, rss);
2328 /* Setup the scalarizing loops and bounds. */
2329 gfc_conv_ss_startstride (&loop);
2331 gfc_conv_loop_setup (&loop);
2333 info = &rss->data.info;
2334 desc = info->descriptor;
2336 /* Make a new descriptor. */
2337 parmtype = gfc_get_element_type (TREE_TYPE (desc));
2338 parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen,
2339 loop.from, loop.to, 1);
2341 /* Allocate temporary for nested forall construct. */
2342 tmp1 = allocate_temp_for_forall_nest (nested_forall_info, parmtype,
2343 inner_size, NULL, block, &ptemp1);
2344 gfc_start_block (&body);
2345 gfc_init_se (&lse, NULL);
2346 lse.expr = gfc_build_array_ref (tmp1, count);
2347 lse.direct_byref = 1;
2348 rss = gfc_walk_expr (expr2);
2349 gfc_conv_expr_descriptor (&lse, expr2, rss);
2351 gfc_add_block_to_block (&body, &lse.pre);
2352 gfc_add_block_to_block (&body, &lse.post);
2354 /* Increment count. */
2355 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2356 count, gfc_index_one_node);
2357 gfc_add_modify_expr (&body, count, tmp);
2359 tmp = gfc_finish_block (&body);
2361 /* Generate body and loops according to the information in
2362 nested_forall_info. */
2363 tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1);
2364 gfc_add_expr_to_block (block, tmp);
2367 gfc_add_modify_expr (block, count, gfc_index_zero_node);
2369 parm = gfc_build_array_ref (tmp1, count);
2370 lss = gfc_walk_expr (expr1);
2371 gfc_init_se (&lse, NULL);
2372 gfc_conv_expr_descriptor (&lse, expr1, lss);
2373 gfc_add_modify_expr (&lse.pre, lse.expr, parm);
2374 gfc_start_block (&body);
2375 gfc_add_block_to_block (&body, &lse.pre);
2376 gfc_add_block_to_block (&body, &lse.post);
2378 /* Increment count. */
2379 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2380 count, gfc_index_one_node);
2381 gfc_add_modify_expr (&body, count, tmp);
2383 tmp = gfc_finish_block (&body);
2385 tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1);
2386 gfc_add_expr_to_block (block, tmp);
2388 /* Free the temporary. */
2391 tmp = gfc_chainon_list (NULL_TREE, ptemp1);
2392 tmp = build_function_call_expr (gfor_fndecl_internal_free, tmp);
2393 gfc_add_expr_to_block (block, tmp);
2398 /* FORALL and WHERE statements are really nasty, especially when you nest
2399 them. All the rhs of a forall assignment must be evaluated before the
2400 actual assignments are performed. Presumably this also applies to all the
2401 assignments in an inner where statement. */
2403 /* Generate code for a FORALL statement. Any temporaries are allocated as a
2404 linear array, relying on the fact that we process in the same order in all
2407 forall (i=start:end:stride; maskexpr)
2411 (where e,f,g,h<i> are arbitrary expressions possibly involving i)
2413 count = ((end + 1 - start) / stride)
2414 masktmp(:) = maskexpr(:)
2417 for (i = start; i <= end; i += stride)
2419 if (masktmp[maskindex++])
2423 for (i = start; i <= end; i += stride)
2425 if (masktmp[maskindex++])
2429 Note that this code only works when there are no dependencies.
2430 Forall loop with array assignments and data dependencies are a real pain,
2431 because the size of the temporary cannot always be determined before the
2432 loop is executed. This problem is compounded by the presence of nested
2437 gfc_trans_forall_1 (gfc_code * code, forall_info * nested_forall_info)
2455 gfc_forall_iterator *fa;
2458 gfc_saved_var *saved_vars;
2459 iter_info *this_forall;
2463 /* Count the FORALL index number. */
2464 for (fa = code->ext.forall_iterator; fa; fa = fa->next)
2468 /* Allocate the space for var, start, end, step, varexpr. */
2469 var = (tree *) gfc_getmem (nvar * sizeof (tree));
2470 start = (tree *) gfc_getmem (nvar * sizeof (tree));
2471 end = (tree *) gfc_getmem (nvar * sizeof (tree));
2472 step = (tree *) gfc_getmem (nvar * sizeof (tree));
2473 varexpr = (gfc_expr **) gfc_getmem (nvar * sizeof (gfc_expr *));
2474 saved_vars = (gfc_saved_var *) gfc_getmem (nvar * sizeof (gfc_saved_var));
2476 /* Allocate the space for info. */
2477 info = (forall_info *) gfc_getmem (sizeof (forall_info));
2479 gfc_start_block (&block);
2482 for (fa = code->ext.forall_iterator; fa; fa = fa->next)
2484 gfc_symbol *sym = fa->var->symtree->n.sym;
2486 /* Allocate space for this_forall. */
2487 this_forall = (iter_info *) gfc_getmem (sizeof (iter_info));
2489 /* Create a temporary variable for the FORALL index. */
2490 tmp = gfc_typenode_for_spec (&sym->ts);
2491 var[n] = gfc_create_var (tmp, sym->name);
2492 gfc_shadow_sym (sym, var[n], &saved_vars[n]);
2494 /* Record it in this_forall. */
2495 this_forall->var = var[n];
2497 /* Replace the index symbol's backend_decl with the temporary decl. */
2498 sym->backend_decl = var[n];
2500 /* Work out the start, end and stride for the loop. */
2501 gfc_init_se (&se, NULL);
2502 gfc_conv_expr_val (&se, fa->start);
2503 /* Record it in this_forall. */
2504 this_forall->start = se.expr;
2505 gfc_add_block_to_block (&block, &se.pre);
2508 gfc_init_se (&se, NULL);
2509 gfc_conv_expr_val (&se, fa->end);
2510 /* Record it in this_forall. */
2511 this_forall->end = se.expr;
2512 gfc_make_safe_expr (&se);
2513 gfc_add_block_to_block (&block, &se.pre);
2516 gfc_init_se (&se, NULL);
2517 gfc_conv_expr_val (&se, fa->stride);
2518 /* Record it in this_forall. */
2519 this_forall->step = se.expr;
2520 gfc_make_safe_expr (&se);
2521 gfc_add_block_to_block (&block, &se.pre);
2524 /* Set the NEXT field of this_forall to NULL. */
2525 this_forall->next = NULL;
2526 /* Link this_forall to the info construct. */
2527 if (info->this_loop)
2529 iter_info *iter_tmp = info->this_loop;
2530 while (iter_tmp->next != NULL)
2531 iter_tmp = iter_tmp->next;
2532 iter_tmp->next = this_forall;
2535 info->this_loop = this_forall;
2541 /* Calculate the size needed for the current forall level. */
2542 size = gfc_index_one_node;
2543 for (n = 0; n < nvar; n++)
2545 /* size = (end + step - start) / step. */
2546 tmp = fold_build2 (MINUS_EXPR, TREE_TYPE (start[n]),
2548 tmp = fold_build2 (PLUS_EXPR, TREE_TYPE (end[n]), end[n], tmp);
2550 tmp = fold_build2 (FLOOR_DIV_EXPR, TREE_TYPE (tmp), tmp, step[n]);
2551 tmp = convert (gfc_array_index_type, tmp);
2553 size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
2556 /* Record the nvar and size of current forall level. */
2560 /* First we need to allocate the mask. */
2563 /* As the mask array can be very big, prefer compact boolean types. */
2564 tree mask_type = gfc_get_logical_type (gfc_logical_kinds[0].kind);
2565 mask = allocate_temp_for_forall_nest (nested_forall_info, mask_type,
2566 size, NULL, &block, &pmask);
2567 maskindex = gfc_create_var_np (gfc_array_index_type, "mi");
2569 /* Record them in the info structure. */
2570 info->maskindex = maskindex;
2575 /* No mask was specified. */
2576 maskindex = NULL_TREE;
2577 mask = pmask = NULL_TREE;
2580 /* Link the current forall level to nested_forall_info. */
2581 info->prev_nest = nested_forall_info;
2582 nested_forall_info = info;
2584 /* Copy the mask into a temporary variable if required.
2585 For now we assume a mask temporary is needed. */
2588 /* As the mask array can be very big, prefer compact boolean types. */
2589 tree mask_type = gfc_get_logical_type (gfc_logical_kinds[0].kind);
2591 gfc_add_modify_expr (&block, maskindex, gfc_index_zero_node);
2593 /* Start of mask assignment loop body. */
2594 gfc_start_block (&body);
2596 /* Evaluate the mask expression. */
2597 gfc_init_se (&se, NULL);
2598 gfc_conv_expr_val (&se, code->expr);
2599 gfc_add_block_to_block (&body, &se.pre);
2601 /* Store the mask. */
2602 se.expr = convert (mask_type, se.expr);
2604 tmp = gfc_build_array_ref (mask, maskindex);
2605 gfc_add_modify_expr (&body, tmp, se.expr);
2607 /* Advance to the next mask element. */
2608 tmp = build2 (PLUS_EXPR, gfc_array_index_type,
2609 maskindex, gfc_index_one_node);
2610 gfc_add_modify_expr (&body, maskindex, tmp);
2612 /* Generate the loops. */
2613 tmp = gfc_finish_block (&body);
2614 tmp = gfc_trans_nested_forall_loop (info, tmp, 0);
2615 gfc_add_expr_to_block (&block, tmp);
2618 c = code->block->next;
2620 /* TODO: loop merging in FORALL statements. */
2621 /* Now that we've got a copy of the mask, generate the assignment loops. */
2627 /* A scalar or array assignment. */
2628 need_temp = gfc_check_dependency (c->expr, c->expr2, 0);
2629 /* Temporaries due to array assignment data dependencies introduce
2630 no end of problems. */
2632 gfc_trans_assign_need_temp (c->expr, c->expr2, NULL, false,
2633 nested_forall_info, &block);
2636 /* Use the normal assignment copying routines. */
2637 assign = gfc_trans_assignment (c->expr, c->expr2, false);
2639 /* Generate body and loops. */
2640 tmp = gfc_trans_nested_forall_loop (nested_forall_info,
2642 gfc_add_expr_to_block (&block, tmp);
2648 /* Translate WHERE or WHERE construct nested in FORALL. */
2649 gfc_trans_where_2 (c, NULL, false, nested_forall_info, &block);
2652 /* Pointer assignment inside FORALL. */
2653 case EXEC_POINTER_ASSIGN:
2654 need_temp = gfc_check_dependency (c->expr, c->expr2, 0);
2656 gfc_trans_pointer_assign_need_temp (c->expr, c->expr2,
2657 nested_forall_info, &block);
2660 /* Use the normal assignment copying routines. */
2661 assign = gfc_trans_pointer_assignment (c->expr, c->expr2);
2663 /* Generate body and loops. */
2664 tmp = gfc_trans_nested_forall_loop (nested_forall_info,
2666 gfc_add_expr_to_block (&block, tmp);
2671 tmp = gfc_trans_forall_1 (c, nested_forall_info);
2672 gfc_add_expr_to_block (&block, tmp);
2675 /* Explicit subroutine calls are prevented by the frontend but interface
2676 assignments can legitimately produce them. */
2677 case EXEC_ASSIGN_CALL:
2678 assign = gfc_trans_call (c, true);
2679 tmp = gfc_trans_nested_forall_loop (nested_forall_info, assign, 1);
2680 gfc_add_expr_to_block (&block, tmp);
2690 /* Restore the original index variables. */
2691 for (fa = code->ext.forall_iterator, n = 0; fa; fa = fa->next, n++)
2692 gfc_restore_sym (fa->var->symtree->n.sym, &saved_vars[n]);
2694 /* Free the space for var, start, end, step, varexpr. */
2700 gfc_free (saved_vars);
2702 /* Free the space for this forall_info. */
2707 /* Free the temporary for the mask. */
2708 tmp = gfc_chainon_list (NULL_TREE, pmask);
2709 tmp = build_function_call_expr (gfor_fndecl_internal_free, tmp);
2710 gfc_add_expr_to_block (&block, tmp);
2713 pushdecl (maskindex);
2715 return gfc_finish_block (&block);
2719 /* Translate the FORALL statement or construct. */
2721 tree gfc_trans_forall (gfc_code * code)
2723 return gfc_trans_forall_1 (code, NULL);
2727 /* Evaluate the WHERE mask expression, copy its value to a temporary.
2728 If the WHERE construct is nested in FORALL, compute the overall temporary
2729 needed by the WHERE mask expression multiplied by the iterator number of
2731 ME is the WHERE mask expression.
2732 MASK is the current execution mask upon input, whose sense may or may
2733 not be inverted as specified by the INVERT argument.
2734 CMASK is the updated execution mask on output, or NULL if not required.
2735 PMASK is the pending execution mask on output, or NULL if not required.
2736 BLOCK is the block in which to place the condition evaluation loops. */
2739 gfc_evaluate_where_mask (gfc_expr * me, forall_info * nested_forall_info,
2740 tree mask, bool invert, tree cmask, tree pmask,
2741 tree mask_type, stmtblock_t * block)
2746 stmtblock_t body, body1;
2747 tree count, cond, mtmp;
2750 gfc_init_loopinfo (&loop);
2752 lss = gfc_walk_expr (me);
2753 rss = gfc_walk_expr (me);
2755 /* Variable to index the temporary. */
2756 count = gfc_create_var (gfc_array_index_type, "count");
2757 /* Initialize count. */
2758 gfc_add_modify_expr (block, count, gfc_index_zero_node);
2760 gfc_start_block (&body);
2762 gfc_init_se (&rse, NULL);
2763 gfc_init_se (&lse, NULL);
2765 if (lss == gfc_ss_terminator)
2767 gfc_init_block (&body1);
2771 /* Initialize the loop. */
2772 gfc_init_loopinfo (&loop);
2774 /* We may need LSS to determine the shape of the expression. */
2775 gfc_add_ss_to_loop (&loop, lss);
2776 gfc_add_ss_to_loop (&loop, rss);
2778 gfc_conv_ss_startstride (&loop);
2779 gfc_conv_loop_setup (&loop);
2781 gfc_mark_ss_chain_used (rss, 1);
2782 /* Start the loop body. */
2783 gfc_start_scalarized_body (&loop, &body1);
2785 /* Translate the expression. */
2786 gfc_copy_loopinfo_to_se (&rse, &loop);
2788 gfc_conv_expr (&rse, me);
2791 /* Variable to evaluate mask condition. */
2792 cond = gfc_create_var (mask_type, "cond");
2793 if (mask && (cmask || pmask))
2794 mtmp = gfc_create_var (mask_type, "mask");
2795 else mtmp = NULL_TREE;
2797 gfc_add_block_to_block (&body1, &lse.pre);
2798 gfc_add_block_to_block (&body1, &rse.pre);
2800 gfc_add_modify_expr (&body1, cond, fold_convert (mask_type, rse.expr));
2802 if (mask && (cmask || pmask))
2804 tmp = gfc_build_array_ref (mask, count);
2806 tmp = fold_build1 (TRUTH_NOT_EXPR, mask_type, tmp);
2807 gfc_add_modify_expr (&body1, mtmp, tmp);
2812 tmp1 = gfc_build_array_ref (cmask, count);
2815 tmp = build2 (TRUTH_AND_EXPR, mask_type, mtmp, tmp);
2816 gfc_add_modify_expr (&body1, tmp1, tmp);
2821 tmp1 = gfc_build_array_ref (pmask, count);
2822 tmp = build1 (TRUTH_NOT_EXPR, mask_type, cond);
2824 tmp = build2 (TRUTH_AND_EXPR, mask_type, mtmp, tmp);
2825 gfc_add_modify_expr (&body1, tmp1, tmp);
2828 gfc_add_block_to_block (&body1, &lse.post);
2829 gfc_add_block_to_block (&body1, &rse.post);
2831 if (lss == gfc_ss_terminator)
2833 gfc_add_block_to_block (&body, &body1);
2837 /* Increment count. */
2838 tmp1 = fold_build2 (PLUS_EXPR, gfc_array_index_type, count,
2839 gfc_index_one_node);
2840 gfc_add_modify_expr (&body1, count, tmp1);
2842 /* Generate the copying loops. */
2843 gfc_trans_scalarizing_loops (&loop, &body1);
2845 gfc_add_block_to_block (&body, &loop.pre);
2846 gfc_add_block_to_block (&body, &loop.post);
2848 gfc_cleanup_loop (&loop);
2849 /* TODO: Reuse lss and rss when copying temp->lhs. Need to be careful
2850 as tree nodes in SS may not be valid in different scope. */
2853 tmp1 = gfc_finish_block (&body);
2854 /* If the WHERE construct is inside FORALL, fill the full temporary. */
2855 if (nested_forall_info != NULL)
2856 tmp1 = gfc_trans_nested_forall_loop (nested_forall_info, tmp1, 1);
2858 gfc_add_expr_to_block (block, tmp1);
2862 /* Translate an assignment statement in a WHERE statement or construct
2863 statement. The MASK expression is used to control which elements
2864 of EXPR1 shall be assigned. The sense of MASK is specified by
2868 gfc_trans_where_assign (gfc_expr *expr1, gfc_expr *expr2,
2869 tree mask, bool invert,
2870 tree count1, tree count2,
2876 gfc_ss *lss_section;
2883 tree index, maskexpr;
2886 /* TODO: handle this special case.
2887 Special case a single function returning an array. */
2888 if (expr2->expr_type == EXPR_FUNCTION && expr2->rank > 0)
2890 tmp = gfc_trans_arrayfunc_assign (expr1, expr2);
2896 /* Assignment of the form lhs = rhs. */
2897 gfc_start_block (&block);
2899 gfc_init_se (&lse, NULL);
2900 gfc_init_se (&rse, NULL);
2903 lss = gfc_walk_expr (expr1);
2906 /* In each where-assign-stmt, the mask-expr and the variable being
2907 defined shall be arrays of the same shape. */
2908 gcc_assert (lss != gfc_ss_terminator);
2910 /* The assignment needs scalarization. */
2913 /* Find a non-scalar SS from the lhs. */
2914 while (lss_section != gfc_ss_terminator
2915 && lss_section->type != GFC_SS_SECTION)
2916 lss_section = lss_section->next;
2918 gcc_assert (lss_section != gfc_ss_terminator);
2920 /* Initialize the scalarizer. */
2921 gfc_init_loopinfo (&loop);
2924 rss = gfc_walk_expr (expr2);
2925 if (rss == gfc_ss_terminator)
2927 /* The rhs is scalar. Add a ss for the expression. */
2928 rss = gfc_get_ss ();
2929 rss->next = gfc_ss_terminator;
2930 rss->type = GFC_SS_SCALAR;
2934 /* Associate the SS with the loop. */
2935 gfc_add_ss_to_loop (&loop, lss);
2936 gfc_add_ss_to_loop (&loop, rss);
2938 /* Calculate the bounds of the scalarization. */
2939 gfc_conv_ss_startstride (&loop);
2941 /* Resolve any data dependencies in the statement. */
2942 gfc_conv_resolve_dependencies (&loop, lss_section, rss);
2944 /* Setup the scalarizing loops. */
2945 gfc_conv_loop_setup (&loop);
2947 /* Setup the gfc_se structures. */
2948 gfc_copy_loopinfo_to_se (&lse, &loop);
2949 gfc_copy_loopinfo_to_se (&rse, &loop);
2952 gfc_mark_ss_chain_used (rss, 1);
2953 if (loop.temp_ss == NULL)
2956 gfc_mark_ss_chain_used (lss, 1);
2960 lse.ss = loop.temp_ss;
2961 gfc_mark_ss_chain_used (lss, 3);
2962 gfc_mark_ss_chain_used (loop.temp_ss, 3);
2965 /* Start the scalarized loop body. */
2966 gfc_start_scalarized_body (&loop, &body);
2968 /* Translate the expression. */
2969 gfc_conv_expr (&rse, expr2);
2970 if (lss != gfc_ss_terminator && loop.temp_ss != NULL)
2972 gfc_conv_tmp_array_ref (&lse);
2973 gfc_advance_se_ss_chain (&lse);
2976 gfc_conv_expr (&lse, expr1);
2978 /* Form the mask expression according to the mask. */
2980 maskexpr = gfc_build_array_ref (mask, index);
2982 maskexpr = fold_build1 (TRUTH_NOT_EXPR, TREE_TYPE (maskexpr), maskexpr);
2984 /* Use the scalar assignment as is. */
2986 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
2987 loop.temp_ss != NULL, false);
2989 tmp = gfc_conv_operator_assign (&lse, &rse, sym);
2991 tmp = build3_v (COND_EXPR, maskexpr, tmp, build_empty_stmt ());
2993 gfc_add_expr_to_block (&body, tmp);
2995 if (lss == gfc_ss_terminator)
2997 /* Increment count1. */
2998 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2999 count1, gfc_index_one_node);
3000 gfc_add_modify_expr (&body, count1, tmp);
3002 /* Use the scalar assignment as is. */
3003 gfc_add_block_to_block (&block, &body);
3007 gcc_assert (lse.ss == gfc_ss_terminator
3008 && rse.ss == gfc_ss_terminator);
3010 if (loop.temp_ss != NULL)
3012 /* Increment count1 before finish the main body of a scalarized
3014 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
3015 count1, gfc_index_one_node);
3016 gfc_add_modify_expr (&body, count1, tmp);
3017 gfc_trans_scalarized_loop_boundary (&loop, &body);
3019 /* We need to copy the temporary to the actual lhs. */
3020 gfc_init_se (&lse, NULL);
3021 gfc_init_se (&rse, NULL);
3022 gfc_copy_loopinfo_to_se (&lse, &loop);
3023 gfc_copy_loopinfo_to_se (&rse, &loop);
3025 rse.ss = loop.temp_ss;
3028 gfc_conv_tmp_array_ref (&rse);
3029 gfc_advance_se_ss_chain (&rse);
3030 gfc_conv_expr (&lse, expr1);
3032 gcc_assert (lse.ss == gfc_ss_terminator
3033 && rse.ss == gfc_ss_terminator);
3035 /* Form the mask expression according to the mask tree list. */
3037 maskexpr = gfc_build_array_ref (mask, index);
3039 maskexpr = fold_build1 (TRUTH_NOT_EXPR, TREE_TYPE (maskexpr),
3042 /* Use the scalar assignment as is. */
3043 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts, false, false);
3044 tmp = build3_v (COND_EXPR, maskexpr, tmp, build_empty_stmt ());
3045 gfc_add_expr_to_block (&body, tmp);
3047 /* Increment count2. */
3048 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
3049 count2, gfc_index_one_node);
3050 gfc_add_modify_expr (&body, count2, tmp);
3054 /* Increment count1. */
3055 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
3056 count1, gfc_index_one_node);
3057 gfc_add_modify_expr (&body, count1, tmp);
3060 /* Generate the copying loops. */
3061 gfc_trans_scalarizing_loops (&loop, &body);
3063 /* Wrap the whole thing up. */
3064 gfc_add_block_to_block (&block, &loop.pre);
3065 gfc_add_block_to_block (&block, &loop.post);
3066 gfc_cleanup_loop (&loop);
3069 return gfc_finish_block (&block);
3073 /* Translate the WHERE construct or statement.
3074 This function can be called iteratively to translate the nested WHERE
3075 construct or statement.
3076 MASK is the control mask. */
3079 gfc_trans_where_2 (gfc_code * code, tree mask, bool invert,
3080 forall_info * nested_forall_info, stmtblock_t * block)
3082 stmtblock_t inner_size_body;
3083 tree inner_size, size;
3091 tree count1, count2;
3095 tree pcmask = NULL_TREE;
3096 tree ppmask = NULL_TREE;
3097 tree cmask = NULL_TREE;
3098 tree pmask = NULL_TREE;
3099 gfc_actual_arglist *arg;
3101 /* the WHERE statement or the WHERE construct statement. */
3102 cblock = code->block;
3104 /* As the mask array can be very big, prefer compact boolean types. */
3105 mask_type = gfc_get_logical_type (gfc_logical_kinds[0].kind);
3107 /* Determine which temporary masks are needed. */
3110 /* One clause: No ELSEWHEREs. */
3111 need_cmask = (cblock->next != 0);
3114 else if (cblock->block->block)
3116 /* Three or more clauses: Conditional ELSEWHEREs. */
3120 else if (cblock->next)
3122 /* Two clauses, the first non-empty. */
3124 need_pmask = (mask != NULL_TREE
3125 && cblock->block->next != 0);
3127 else if (!cblock->block->next)
3129 /* Two clauses, both empty. */
3133 /* Two clauses, the first empty, the second non-empty. */
3136 need_cmask = (cblock->block->expr != 0);
3145 if (need_cmask || need_pmask)
3147 /* Calculate the size of temporary needed by the mask-expr. */
3148 gfc_init_block (&inner_size_body);
3149 inner_size = compute_inner_temp_size (cblock->expr, cblock->expr,
3150 &inner_size_body, &lss, &rss);
3152 /* Calculate the total size of temporary needed. */
3153 size = compute_overall_iter_number (nested_forall_info, inner_size,
3154 &inner_size_body, block);
3156 /* Allocate temporary for WHERE mask if needed. */
3158 cmask = allocate_temp_for_forall_nest_1 (mask_type, size, block,
3161 /* Allocate temporary for !mask if needed. */
3163 pmask = allocate_temp_for_forall_nest_1 (mask_type, size, block,
3169 /* Each time around this loop, the where clause is conditional
3170 on the value of mask and invert, which are updated at the
3171 bottom of the loop. */
3173 /* Has mask-expr. */
3176 /* Ensure that the WHERE mask will be evaluated exactly once.
3177 If there are no statements in this WHERE/ELSEWHERE clause,
3178 then we don't need to update the control mask (cmask).
3179 If this is the last clause of the WHERE construct, then
3180 we don't need to update the pending control mask (pmask). */
3182 gfc_evaluate_where_mask (cblock->expr, nested_forall_info,
3184 cblock->next ? cmask : NULL_TREE,
3185 cblock->block ? pmask : NULL_TREE,
3188 gfc_evaluate_where_mask (cblock->expr, nested_forall_info,
3190 (cblock->next || cblock->block)
3191 ? cmask : NULL_TREE,
3192 NULL_TREE, mask_type, block);
3196 /* It's a final elsewhere-stmt. No mask-expr is present. */
3200 /* The body of this where clause are controlled by cmask with
3201 sense specified by invert. */
3203 /* Get the assignment statement of a WHERE statement, or the first
3204 statement in where-body-construct of a WHERE construct. */
3205 cnext = cblock->next;
3210 /* WHERE assignment statement. */
3211 case EXEC_ASSIGN_CALL:
3213 arg = cnext->ext.actual;
3214 expr1 = expr2 = NULL;
3215 for (; arg; arg = arg->next)
3227 expr1 = cnext->expr;
3228 expr2 = cnext->expr2;
3230 if (nested_forall_info != NULL)
3232 need_temp = gfc_check_dependency (expr1, expr2, 0);
3233 if (need_temp && cnext->op != EXEC_ASSIGN_CALL)
3234 gfc_trans_assign_need_temp (expr1, expr2,
3236 nested_forall_info, block);
3239 /* Variables to control maskexpr. */
3240 count1 = gfc_create_var (gfc_array_index_type, "count1");
3241 count2 = gfc_create_var (gfc_array_index_type, "count2");
3242 gfc_add_modify_expr (block, count1, gfc_index_zero_node);
3243 gfc_add_modify_expr (block, count2, gfc_index_zero_node);
3245 tmp = gfc_trans_where_assign (expr1, expr2,
3248 cnext->resolved_sym);
3250 tmp = gfc_trans_nested_forall_loop (nested_forall_info,
3252 gfc_add_expr_to_block (block, tmp);
3257 /* Variables to control maskexpr. */
3258 count1 = gfc_create_var (gfc_array_index_type, "count1");
3259 count2 = gfc_create_var (gfc_array_index_type, "count2");
3260 gfc_add_modify_expr (block, count1, gfc_index_zero_node);
3261 gfc_add_modify_expr (block, count2, gfc_index_zero_node);
3263 tmp = gfc_trans_where_assign (expr1, expr2,
3266 cnext->resolved_sym);
3267 gfc_add_expr_to_block (block, tmp);
3272 /* WHERE or WHERE construct is part of a where-body-construct. */
3274 gfc_trans_where_2 (cnext, cmask, invert,
3275 nested_forall_info, block);
3282 /* The next statement within the same where-body-construct. */
3283 cnext = cnext->next;
3285 /* The next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt. */
3286 cblock = cblock->block;
3287 if (mask == NULL_TREE)
3289 /* If we're the initial WHERE, we can simply invert the sense
3290 of the current mask to obtain the "mask" for the remaining
3297 /* Otherwise, for nested WHERE's we need to use the pending mask. */
3303 /* If we allocated a pending mask array, deallocate it now. */
3306 tree args = gfc_chainon_list (NULL_TREE, ppmask);
3307 tmp = build_function_call_expr (gfor_fndecl_internal_free, args);
3308 gfc_add_expr_to_block (block, tmp);
3311 /* If we allocated a current mask array, deallocate it now. */
3314 tree args = gfc_chainon_list (NULL_TREE, pcmask);
3315 tmp = build_function_call_expr (gfor_fndecl_internal_free, args);
3316 gfc_add_expr_to_block (block, tmp);
3320 /* Translate a simple WHERE construct or statement without dependencies.
3321 CBLOCK is the "then" clause of the WHERE statement, where CBLOCK->EXPR
3322 is the mask condition, and EBLOCK if non-NULL is the "else" clause.
3323 Currently both CBLOCK and EBLOCK are restricted to single assignments. */
3326 gfc_trans_where_3 (gfc_code * cblock, gfc_code * eblock)
3328 stmtblock_t block, body;
3329 gfc_expr *cond, *tdst, *tsrc, *edst, *esrc;
3330 tree tmp, cexpr, tstmt, estmt;
3331 gfc_ss *css, *tdss, *tsss;
3332 gfc_se cse, tdse, tsse, edse, esse;
3337 cond = cblock->expr;
3338 tdst = cblock->next->expr;
3339 tsrc = cblock->next->expr2;
3340 edst = eblock ? eblock->next->expr : NULL;
3341 esrc = eblock ? eblock->next->expr2 : NULL;
3343 gfc_start_block (&block);
3344 gfc_init_loopinfo (&loop);
3346 /* Handle the condition. */
3347 gfc_init_se (&cse, NULL);
3348 css = gfc_walk_expr (cond);
3349 gfc_add_ss_to_loop (&loop, css);
3351 /* Handle the then-clause. */
3352 gfc_init_se (&tdse, NULL);
3353 gfc_init_se (&tsse, NULL);
3354 tdss = gfc_walk_expr (tdst);
3355 tsss = gfc_walk_expr (tsrc);
3356 if (tsss == gfc_ss_terminator)
3358 tsss = gfc_get_ss ();
3359 tsss->next = gfc_ss_terminator;
3360 tsss->type = GFC_SS_SCALAR;
3363 gfc_add_ss_to_loop (&loop, tdss);
3364 gfc_add_ss_to_loop (&loop, tsss);
3368 /* Handle the else clause. */
3369 gfc_init_se (&edse, NULL);
3370 gfc_init_se (&esse, NULL);
3371 edss = gfc_walk_expr (edst);
3372 esss = gfc_walk_expr (esrc);
3373 if (esss == gfc_ss_terminator)
3375 esss = gfc_get_ss ();
3376 esss->next = gfc_ss_terminator;
3377 esss->type = GFC_SS_SCALAR;
3380 gfc_add_ss_to_loop (&loop, edss);
3381 gfc_add_ss_to_loop (&loop, esss);
3384 gfc_conv_ss_startstride (&loop);
3385 gfc_conv_loop_setup (&loop);
3387 gfc_mark_ss_chain_used (css, 1);
3388 gfc_mark_ss_chain_used (tdss, 1);
3389 gfc_mark_ss_chain_used (tsss, 1);
3392 gfc_mark_ss_chain_used (edss, 1);
3393 gfc_mark_ss_chain_used (esss, 1);
3396 gfc_start_scalarized_body (&loop, &body);
3398 gfc_copy_loopinfo_to_se (&cse, &loop);
3399 gfc_copy_loopinfo_to_se (&tdse, &loop);
3400 gfc_copy_loopinfo_to_se (&tsse, &loop);
3406 gfc_copy_loopinfo_to_se (&edse, &loop);
3407 gfc_copy_loopinfo_to_se (&esse, &loop);
3412 gfc_conv_expr (&cse, cond);
3413 gfc_add_block_to_block (&body, &cse.pre);
3416 gfc_conv_expr (&tsse, tsrc);
3417 if (tdss != gfc_ss_terminator && loop.temp_ss != NULL)
3419 gfc_conv_tmp_array_ref (&tdse);
3420 gfc_advance_se_ss_chain (&tdse);
3423 gfc_conv_expr (&tdse, tdst);
3427 gfc_conv_expr (&esse, esrc);
3428 if (edss != gfc_ss_terminator && loop.temp_ss != NULL)
3430 gfc_conv_tmp_array_ref (&edse);
3431 gfc_advance_se_ss_chain (&edse);
3434 gfc_conv_expr (&edse, edst);
3437 tstmt = gfc_trans_scalar_assign (&tdse, &tsse, tdst->ts, false, false);
3438 estmt = eblock ? gfc_trans_scalar_assign (&edse, &esse, edst->ts, false, false)
3439 : build_empty_stmt ();
3440 tmp = build3_v (COND_EXPR, cexpr, tstmt, estmt);
3441 gfc_add_expr_to_block (&body, tmp);
3442 gfc_add_block_to_block (&body, &cse.post);
3444 gfc_trans_scalarizing_loops (&loop, &body);
3445 gfc_add_block_to_block (&block, &loop.pre);
3446 gfc_add_block_to_block (&block, &loop.post);
3447 gfc_cleanup_loop (&loop);
3449 return gfc_finish_block (&block);
3452 /* As the WHERE or WHERE construct statement can be nested, we call
3453 gfc_trans_where_2 to do the translation, and pass the initial
3454 NULL values for both the control mask and the pending control mask. */
3457 gfc_trans_where (gfc_code * code)
3463 cblock = code->block;
3465 && cblock->next->op == EXEC_ASSIGN
3466 && !cblock->next->next)
3468 eblock = cblock->block;
3471 /* A simple "WHERE (cond) x = y" statement or block is
3472 dependence free if cond is not dependent upon writing x,
3473 and the source y is unaffected by the destination x. */
3474 if (!gfc_check_dependency (cblock->next->expr,
3476 && !gfc_check_dependency (cblock->next->expr,
3477 cblock->next->expr2, 0))
3478 return gfc_trans_where_3 (cblock, NULL);
3480 else if (!eblock->expr
3483 && eblock->next->op == EXEC_ASSIGN
3484 && !eblock->next->next)
3486 /* A simple "WHERE (cond) x1 = y1 ELSEWHERE x2 = y2 ENDWHERE"
3487 block is dependence free if cond is not dependent on writes
3488 to x1 and x2, y1 is not dependent on writes to x2, and y2
3489 is not dependent on writes to x1, and both y's are not
3490 dependent upon their own x's. */
3491 if (!gfc_check_dependency(cblock->next->expr,
3493 && !gfc_check_dependency(eblock->next->expr,
3495 && !gfc_check_dependency(cblock->next->expr,
3496 eblock->next->expr2, 0)
3497 && !gfc_check_dependency(eblock->next->expr,
3498 cblock->next->expr2, 0)
3499 && !gfc_check_dependency(cblock->next->expr,
3500 cblock->next->expr2, 0)
3501 && !gfc_check_dependency(eblock->next->expr,
3502 eblock->next->expr2, 0))
3503 return gfc_trans_where_3 (cblock, eblock);
3507 gfc_start_block (&block);
3509 gfc_trans_where_2 (code, NULL, false, NULL, &block);
3511 return gfc_finish_block (&block);
3515 /* CYCLE a DO loop. The label decl has already been created by
3516 gfc_trans_do(), it's in TREE_PURPOSE (backend_decl) of the gfc_code
3517 node at the head of the loop. We must mark the label as used. */
3520 gfc_trans_cycle (gfc_code * code)
3524 cycle_label = TREE_PURPOSE (code->ext.whichloop->backend_decl);
3525 TREE_USED (cycle_label) = 1;
3526 return build1_v (GOTO_EXPR, cycle_label);
3530 /* EXIT a DO loop. Similar to CYCLE, but now the label is in
3531 TREE_VALUE (backend_decl) of the gfc_code node at the head of the
3535 gfc_trans_exit (gfc_code * code)
3539 exit_label = TREE_VALUE (code->ext.whichloop->backend_decl);
3540 TREE_USED (exit_label) = 1;
3541 return build1_v (GOTO_EXPR, exit_label);
3545 /* Translate the ALLOCATE statement. */
3548 gfc_trans_allocate (gfc_code * code)
3560 if (!code->ext.alloc_list)
3563 gfc_start_block (&block);
3567 tree gfc_int4_type_node = gfc_get_int_type (4);
3569 stat = gfc_create_var (gfc_int4_type_node, "stat");
3570 pstat = build_fold_addr_expr (stat);
3572 error_label = gfc_build_label_decl (NULL_TREE);
3573 TREE_USED (error_label) = 1;
3577 pstat = integer_zero_node;
3578 stat = error_label = NULL_TREE;
3582 for (al = code->ext.alloc_list; al != NULL; al = al->next)
3586 gfc_init_se (&se, NULL);
3587 gfc_start_block (&se.pre);
3589 se.want_pointer = 1;
3590 se.descriptor_only = 1;
3591 gfc_conv_expr (&se, expr);
3593 if (!gfc_array_allocate (&se, expr, pstat))
3595 /* A scalar or derived type. */
3596 tmp = TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (se.expr)));
3598 if (expr->ts.type == BT_CHARACTER && tmp == NULL_TREE)
3599 tmp = se.string_length;
3601 parm = gfc_chainon_list (NULL_TREE, tmp);
3602 parm = gfc_chainon_list (parm, pstat);
3603 tmp = build_function_call_expr (gfor_fndecl_allocate, parm);
3604 tmp = build2 (MODIFY_EXPR, void_type_node, se.expr, tmp);
3605 gfc_add_expr_to_block (&se.pre, tmp);
3609 tmp = build1_v (GOTO_EXPR, error_label);
3610 parm = fold_build2 (NE_EXPR, boolean_type_node,
3611 stat, build_int_cst (TREE_TYPE (stat), 0));
3612 tmp = fold_build3 (COND_EXPR, void_type_node,
3613 parm, tmp, build_empty_stmt ());
3614 gfc_add_expr_to_block (&se.pre, tmp);
3617 if (expr->ts.type == BT_DERIVED && expr->ts.derived->attr.alloc_comp)
3619 tmp = build_fold_indirect_ref (se.expr);
3620 tmp = gfc_nullify_alloc_comp (expr->ts.derived, tmp, 0);
3621 gfc_add_expr_to_block (&se.pre, tmp);
3626 tmp = gfc_finish_block (&se.pre);
3627 gfc_add_expr_to_block (&block, tmp);
3630 /* Assign the value to the status variable. */
3633 tmp = build1_v (LABEL_EXPR, error_label);
3634 gfc_add_expr_to_block (&block, tmp);
3636 gfc_init_se (&se, NULL);
3637 gfc_conv_expr_lhs (&se, code->expr);
3638 tmp = convert (TREE_TYPE (se.expr), stat);
3639 gfc_add_modify_expr (&block, se.expr, tmp);
3642 return gfc_finish_block (&block);
3646 /* Translate a DEALLOCATE statement.
3647 There are two cases within the for loop:
3648 (1) deallocate(a1, a2, a3) is translated into the following sequence
3649 _gfortran_deallocate(a1, 0B)
3650 _gfortran_deallocate(a2, 0B)
3651 _gfortran_deallocate(a3, 0B)
3652 where the STAT= variable is passed a NULL pointer.
3653 (2) deallocate(a1, a2, a3, stat=i) is translated into the following
3655 _gfortran_deallocate(a1, &stat)
3656 astat = astat + stat
3657 _gfortran_deallocate(a2, &stat)
3658 astat = astat + stat
3659 _gfortran_deallocate(a3, &stat)
3660 astat = astat + stat
3661 In case (1), we simply return at the end of the for loop. In case (2)
3662 we set STAT= astat. */
3664 gfc_trans_deallocate (gfc_code * code)
3669 tree apstat, astat, parm, pstat, stat, tmp;
3672 gfc_start_block (&block);
3674 /* Set up the optional STAT= */
3677 tree gfc_int4_type_node = gfc_get_int_type (4);
3679 /* Variable used with the library call. */
3680 stat = gfc_create_var (gfc_int4_type_node, "stat");
3681 pstat = build_fold_addr_expr (stat);
3683 /* Running total of possible deallocation failures. */
3684 astat = gfc_create_var (gfc_int4_type_node, "astat");
3685 apstat = build_fold_addr_expr (astat);
3687 /* Initialize astat to 0. */
3688 gfc_add_modify_expr (&block, astat, build_int_cst (TREE_TYPE (astat), 0));
3692 pstat = apstat = null_pointer_node;
3693 stat = astat = NULL_TREE;
3696 for (al = code->ext.alloc_list; al != NULL; al = al->next)
3699 gcc_assert (expr->expr_type == EXPR_VARIABLE);
3701 gfc_init_se (&se, NULL);
3702 gfc_start_block (&se.pre);
3704 se.want_pointer = 1;
3705 se.descriptor_only = 1;
3706 gfc_conv_expr (&se, expr);
3708 if (expr->ts.type == BT_DERIVED
3709 && expr->ts.derived->attr.alloc_comp)
3712 gfc_ref *last = NULL;
3713 for (ref = expr->ref; ref; ref = ref->next)
3714 if (ref->type == REF_COMPONENT)
3717 /* Do not deallocate the components of a derived type
3718 ultimate pointer component. */
3719 if (!(last && last->u.c.component->pointer)
3720 && !(!last && expr->symtree->n.sym->attr.pointer))
3722 tmp = gfc_deallocate_alloc_comp (expr->ts.derived, se.expr,
3724 gfc_add_expr_to_block (&se.pre, tmp);
3729 tmp = gfc_array_deallocate (se.expr, pstat);
3732 parm = gfc_chainon_list (NULL_TREE, se.expr);
3733 parm = gfc_chainon_list (parm, pstat);
3734 tmp = build_function_call_expr (gfor_fndecl_deallocate, parm);
3735 gfc_add_expr_to_block (&se.pre, tmp);
3737 tmp = build2 (MODIFY_EXPR, void_type_node,
3738 se.expr, build_int_cst (TREE_TYPE (se.expr), 0));
3741 gfc_add_expr_to_block (&se.pre, tmp);
3743 /* Keep track of the number of failed deallocations by adding stat
3744 of the last deallocation to the running total. */
3747 apstat = build2 (PLUS_EXPR, TREE_TYPE (stat), astat, stat);
3748 gfc_add_modify_expr (&se.pre, astat, apstat);
3751 tmp = gfc_finish_block (&se.pre);
3752 gfc_add_expr_to_block (&block, tmp);
3756 /* Assign the value to the status variable. */
3759 gfc_init_se (&se, NULL);
3760 gfc_conv_expr_lhs (&se, code->expr);
3761 tmp = convert (TREE_TYPE (se.expr), astat);
3762 gfc_add_modify_expr (&block, se.expr, tmp);
3765 return gfc_finish_block (&block);