1 /* Statement translation -- generate GCC trees from gfc_code.
2 Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009
3 Free Software Foundation, Inc.
4 Contributed by Paul Brook <paul@nowt.org>
5 and Steven Bosscher <s.bosscher@student.tudelft.nl>
7 This file is part of GCC.
9 GCC is free software; you can redistribute it and/or modify it under
10 the terms of the GNU General Public License as published by the Free
11 Software Foundation; either version 3, or (at your option) any later
14 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
15 WARRANTY; without even the implied warranty of MERCHANTABILITY or
16 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
19 You should have received a copy of the GNU General Public License
20 along with GCC; see the file COPYING3. If not see
21 <http://www.gnu.org/licenses/>. */
26 #include "coretypes.h"
35 #include "trans-stmt.h"
36 #include "trans-types.h"
37 #include "trans-array.h"
38 #include "trans-const.h"
40 #include "dependency.h"
42 typedef struct iter_info
48 struct iter_info *next;
52 typedef struct forall_info
59 struct forall_info *prev_nest;
63 static void gfc_trans_where_2 (gfc_code *, tree, bool,
64 forall_info *, stmtblock_t *);
66 /* Translate a F95 label number to a LABEL_EXPR. */
69 gfc_trans_label_here (gfc_code * code)
71 return build1_v (LABEL_EXPR, gfc_get_label_decl (code->here));
75 /* Given a variable expression which has been ASSIGNed to, find the decl
76 containing the auxiliary variables. For variables in common blocks this
80 gfc_conv_label_variable (gfc_se * se, gfc_expr * expr)
82 gcc_assert (expr->symtree->n.sym->attr.assign == 1);
83 gfc_conv_expr (se, expr);
84 /* Deals with variable in common block. Get the field declaration. */
85 if (TREE_CODE (se->expr) == COMPONENT_REF)
86 se->expr = TREE_OPERAND (se->expr, 1);
87 /* Deals with dummy argument. Get the parameter declaration. */
88 else if (TREE_CODE (se->expr) == INDIRECT_REF)
89 se->expr = TREE_OPERAND (se->expr, 0);
92 /* Translate a label assignment statement. */
95 gfc_trans_label_assign (gfc_code * code)
104 /* Start a new block. */
105 gfc_init_se (&se, NULL);
106 gfc_start_block (&se.pre);
107 gfc_conv_label_variable (&se, code->expr1);
109 len = GFC_DECL_STRING_LEN (se.expr);
110 addr = GFC_DECL_ASSIGN_ADDR (se.expr);
112 label_tree = gfc_get_label_decl (code->label1);
114 if (code->label1->defined == ST_LABEL_TARGET)
116 label_tree = gfc_build_addr_expr (pvoid_type_node, label_tree);
117 len_tree = integer_minus_one_node;
121 gfc_expr *format = code->label1->format;
123 label_len = format->value.character.length;
124 len_tree = build_int_cst (NULL_TREE, label_len);
125 label_tree = gfc_build_wide_string_const (format->ts.kind, label_len + 1,
126 format->value.character.string);
127 label_tree = gfc_build_addr_expr (pvoid_type_node, label_tree);
130 gfc_add_modify (&se.pre, len, len_tree);
131 gfc_add_modify (&se.pre, addr, label_tree);
133 return gfc_finish_block (&se.pre);
136 /* Translate a GOTO statement. */
139 gfc_trans_goto (gfc_code * code)
141 locus loc = code->loc;
147 if (code->label1 != NULL)
148 return build1_v (GOTO_EXPR, gfc_get_label_decl (code->label1));
151 gfc_init_se (&se, NULL);
152 gfc_start_block (&se.pre);
153 gfc_conv_label_variable (&se, code->expr1);
154 tmp = GFC_DECL_STRING_LEN (se.expr);
155 tmp = fold_build2 (NE_EXPR, boolean_type_node, tmp,
156 build_int_cst (TREE_TYPE (tmp), -1));
157 gfc_trans_runtime_check (true, false, tmp, &se.pre, &loc,
158 "Assigned label is not a target label");
160 assigned_goto = GFC_DECL_ASSIGN_ADDR (se.expr);
165 target = fold_build1 (GOTO_EXPR, void_type_node, assigned_goto);
166 gfc_add_expr_to_block (&se.pre, target);
167 return gfc_finish_block (&se.pre);
170 /* Check the label list. */
173 target = gfc_get_label_decl (code->label1);
174 tmp = gfc_build_addr_expr (pvoid_type_node, target);
175 tmp = fold_build2 (EQ_EXPR, boolean_type_node, tmp, assigned_goto);
176 tmp = build3_v (COND_EXPR, tmp,
177 fold_build1 (GOTO_EXPR, void_type_node, target),
178 build_empty_stmt ());
179 gfc_add_expr_to_block (&se.pre, tmp);
182 while (code != NULL);
183 gfc_trans_runtime_check (true, false, boolean_true_node, &se.pre, &loc,
184 "Assigned label is not in the list");
186 return gfc_finish_block (&se.pre);
190 /* Translate an ENTRY statement. Just adds a label for this entry point. */
192 gfc_trans_entry (gfc_code * code)
194 return build1_v (LABEL_EXPR, code->ext.entry->label);
198 /* Check for dependencies between INTENT(IN) and INTENT(OUT) arguments of
199 elemental subroutines. Make temporaries for output arguments if any such
200 dependencies are found. Output arguments are chosen because internal_unpack
201 can be used, as is, to copy the result back to the variable. */
203 gfc_conv_elemental_dependencies (gfc_se * se, gfc_se * loopse,
204 gfc_symbol * sym, gfc_actual_arglist * arg,
205 gfc_dep_check check_variable)
207 gfc_actual_arglist *arg0;
209 gfc_formal_arglist *formal;
210 gfc_loopinfo tmp_loop;
221 if (loopse->ss == NULL)
226 formal = sym->formal;
228 /* Loop over all the arguments testing for dependencies. */
229 for (; arg != NULL; arg = arg->next, formal = formal ? formal->next : NULL)
235 /* Obtain the info structure for the current argument. */
237 for (ss = loopse->ss; ss && ss != gfc_ss_terminator; ss = ss->next)
241 info = &ss->data.info;
245 /* If there is a dependency, create a temporary and use it
246 instead of the variable. */
247 fsym = formal ? formal->sym : NULL;
248 if (e->expr_type == EXPR_VARIABLE
250 && fsym->attr.intent != INTENT_IN
251 && gfc_check_fncall_dependency (e, fsym->attr.intent,
252 sym, arg0, check_variable))
254 tree initial, temptype;
255 stmtblock_t temp_post;
257 /* Make a local loopinfo for the temporary creation, so that
258 none of the other ss->info's have to be renormalized. */
259 gfc_init_loopinfo (&tmp_loop);
260 for (n = 0; n < info->dimen; n++)
262 tmp_loop.to[n] = loopse->loop->to[n];
263 tmp_loop.from[n] = loopse->loop->from[n];
264 tmp_loop.order[n] = loopse->loop->order[n];
267 /* Obtain the argument descriptor for unpacking. */
268 gfc_init_se (&parmse, NULL);
269 parmse.want_pointer = 1;
270 gfc_conv_expr_descriptor (&parmse, e, gfc_walk_expr (e));
271 gfc_add_block_to_block (&se->pre, &parmse.pre);
273 /* If we've got INTENT(INOUT) or a derived type with INTENT(OUT),
274 initialize the array temporary with a copy of the values. */
275 if (fsym->attr.intent == INTENT_INOUT
276 || (fsym->ts.type ==BT_DERIVED
277 && fsym->attr.intent == INTENT_OUT))
278 initial = parmse.expr;
282 /* Find the type of the temporary to create; we don't use the type
283 of e itself as this breaks for subcomponent-references in e (where
284 the type of e is that of the final reference, but parmse.expr's
285 type corresponds to the full derived-type). */
286 /* TODO: Fix this somehow so we don't need a temporary of the whole
287 array but instead only the components referenced. */
288 temptype = TREE_TYPE (parmse.expr); /* Pointer to descriptor. */
289 gcc_assert (TREE_CODE (temptype) == POINTER_TYPE);
290 temptype = TREE_TYPE (temptype);
291 temptype = gfc_get_element_type (temptype);
293 /* Generate the temporary. Cleaning up the temporary should be the
294 very last thing done, so we add the code to a new block and add it
295 to se->post as last instructions. */
296 size = gfc_create_var (gfc_array_index_type, NULL);
297 data = gfc_create_var (pvoid_type_node, NULL);
298 gfc_init_block (&temp_post);
299 tmp = gfc_trans_create_temp_array (&se->pre, &temp_post,
300 &tmp_loop, info, temptype,
304 gfc_add_modify (&se->pre, size, tmp);
305 tmp = fold_convert (pvoid_type_node, info->data);
306 gfc_add_modify (&se->pre, data, tmp);
308 /* Calculate the offset for the temporary. */
309 offset = gfc_index_zero_node;
310 for (n = 0; n < info->dimen; n++)
312 tmp = gfc_conv_descriptor_stride_get (info->descriptor,
314 tmp = fold_build2 (MULT_EXPR, gfc_array_index_type,
315 loopse->loop->from[n], tmp);
316 offset = fold_build2 (MINUS_EXPR, gfc_array_index_type,
319 info->offset = gfc_create_var (gfc_array_index_type, NULL);
320 gfc_add_modify (&se->pre, info->offset, offset);
322 /* Copy the result back using unpack. */
323 tmp = build_call_expr (gfor_fndecl_in_unpack, 2, parmse.expr, data);
324 gfc_add_expr_to_block (&se->post, tmp);
326 /* parmse.pre is already added above. */
327 gfc_add_block_to_block (&se->post, &parmse.post);
328 gfc_add_block_to_block (&se->post, &temp_post);
334 /* Translate the CALL statement. Builds a call to an F95 subroutine. */
337 gfc_trans_call (gfc_code * code, bool dependency_check,
338 tree mask, tree count1, bool invert)
342 int has_alternate_specifier;
343 gfc_dep_check check_variable;
344 tree index = NULL_TREE;
345 tree maskexpr = NULL_TREE;
348 /* A CALL starts a new block because the actual arguments may have to
349 be evaluated first. */
350 gfc_init_se (&se, NULL);
351 gfc_start_block (&se.pre);
353 gcc_assert (code->resolved_sym);
355 ss = gfc_ss_terminator;
356 if (code->resolved_sym->attr.elemental)
357 ss = gfc_walk_elemental_function_args (ss, code->ext.actual, GFC_SS_REFERENCE);
359 /* Is not an elemental subroutine call with array valued arguments. */
360 if (ss == gfc_ss_terminator)
363 /* Translate the call. */
364 has_alternate_specifier
365 = gfc_conv_procedure_call (&se, code->resolved_sym, code->ext.actual,
366 code->expr1, NULL_TREE);
368 /* A subroutine without side-effect, by definition, does nothing! */
369 TREE_SIDE_EFFECTS (se.expr) = 1;
371 /* Chain the pieces together and return the block. */
372 if (has_alternate_specifier)
374 gfc_code *select_code;
376 select_code = code->next;
377 gcc_assert(select_code->op == EXEC_SELECT);
378 sym = select_code->expr1->symtree->n.sym;
379 se.expr = convert (gfc_typenode_for_spec (&sym->ts), se.expr);
380 if (sym->backend_decl == NULL)
381 sym->backend_decl = gfc_get_symbol_decl (sym);
382 gfc_add_modify (&se.pre, sym->backend_decl, se.expr);
385 gfc_add_expr_to_block (&se.pre, se.expr);
387 gfc_add_block_to_block (&se.pre, &se.post);
392 /* An elemental subroutine call with array valued arguments has
400 /* gfc_walk_elemental_function_args renders the ss chain in the
401 reverse order to the actual argument order. */
402 ss = gfc_reverse_ss (ss);
404 /* Initialize the loop. */
405 gfc_init_se (&loopse, NULL);
406 gfc_init_loopinfo (&loop);
407 gfc_add_ss_to_loop (&loop, ss);
409 gfc_conv_ss_startstride (&loop);
410 /* TODO: gfc_conv_loop_setup generates a temporary for vector
411 subscripts. This could be prevented in the elemental case
412 as temporaries are handled separatedly
413 (below in gfc_conv_elemental_dependencies). */
414 gfc_conv_loop_setup (&loop, &code->expr1->where);
415 gfc_mark_ss_chain_used (ss, 1);
417 /* Convert the arguments, checking for dependencies. */
418 gfc_copy_loopinfo_to_se (&loopse, &loop);
421 /* For operator assignment, do dependency checking. */
422 if (dependency_check)
423 check_variable = ELEM_CHECK_VARIABLE;
425 check_variable = ELEM_DONT_CHECK_VARIABLE;
427 gfc_init_se (&depse, NULL);
428 gfc_conv_elemental_dependencies (&depse, &loopse, code->resolved_sym,
429 code->ext.actual, check_variable);
431 gfc_add_block_to_block (&loop.pre, &depse.pre);
432 gfc_add_block_to_block (&loop.post, &depse.post);
434 /* Generate the loop body. */
435 gfc_start_scalarized_body (&loop, &body);
436 gfc_init_block (&block);
440 /* Form the mask expression according to the mask. */
442 maskexpr = gfc_build_array_ref (mask, index, NULL);
444 maskexpr = fold_build1 (TRUTH_NOT_EXPR, TREE_TYPE (maskexpr),
448 /* Add the subroutine call to the block. */
449 gfc_conv_procedure_call (&loopse, code->resolved_sym,
450 code->ext.actual, code->expr1,
455 tmp = build3_v (COND_EXPR, maskexpr, loopse.expr,
456 build_empty_stmt ());
457 gfc_add_expr_to_block (&loopse.pre, tmp);
458 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
459 count1, gfc_index_one_node);
460 gfc_add_modify (&loopse.pre, count1, tmp);
463 gfc_add_expr_to_block (&loopse.pre, loopse.expr);
465 gfc_add_block_to_block (&block, &loopse.pre);
466 gfc_add_block_to_block (&block, &loopse.post);
468 /* Finish up the loop block and the loop. */
469 gfc_add_expr_to_block (&body, gfc_finish_block (&block));
470 gfc_trans_scalarizing_loops (&loop, &body);
471 gfc_add_block_to_block (&se.pre, &loop.pre);
472 gfc_add_block_to_block (&se.pre, &loop.post);
473 gfc_add_block_to_block (&se.pre, &se.post);
474 gfc_cleanup_loop (&loop);
477 return gfc_finish_block (&se.pre);
481 /* Translate the RETURN statement. */
484 gfc_trans_return (gfc_code * code ATTRIBUTE_UNUSED)
492 /* If code->expr is not NULL, this return statement must appear
493 in a subroutine and current_fake_result_decl has already
496 result = gfc_get_fake_result_decl (NULL, 0);
499 gfc_warning ("An alternate return at %L without a * dummy argument",
500 &code->expr1->where);
501 return build1_v (GOTO_EXPR, gfc_get_return_label ());
504 /* Start a new block for this statement. */
505 gfc_init_se (&se, NULL);
506 gfc_start_block (&se.pre);
508 gfc_conv_expr (&se, code->expr1);
510 tmp = fold_build2 (MODIFY_EXPR, TREE_TYPE (result), result,
511 fold_convert (TREE_TYPE (result), se.expr));
512 gfc_add_expr_to_block (&se.pre, tmp);
514 tmp = build1_v (GOTO_EXPR, gfc_get_return_label ());
515 gfc_add_expr_to_block (&se.pre, tmp);
516 gfc_add_block_to_block (&se.pre, &se.post);
517 return gfc_finish_block (&se.pre);
520 return build1_v (GOTO_EXPR, gfc_get_return_label ());
524 /* Translate the PAUSE statement. We have to translate this statement
525 to a runtime library call. */
528 gfc_trans_pause (gfc_code * code)
530 tree gfc_int4_type_node = gfc_get_int_type (4);
534 /* Start a new block for this statement. */
535 gfc_init_se (&se, NULL);
536 gfc_start_block (&se.pre);
539 if (code->expr1 == NULL)
541 tmp = build_int_cst (gfc_int4_type_node, code->ext.stop_code);
542 tmp = build_call_expr (gfor_fndecl_pause_numeric, 1, tmp);
546 gfc_conv_expr_reference (&se, code->expr1);
547 tmp = build_call_expr (gfor_fndecl_pause_string, 2,
548 se.expr, se.string_length);
551 gfc_add_expr_to_block (&se.pre, tmp);
553 gfc_add_block_to_block (&se.pre, &se.post);
555 return gfc_finish_block (&se.pre);
559 /* Translate the STOP statement. We have to translate this statement
560 to a runtime library call. */
563 gfc_trans_stop (gfc_code * code)
565 tree gfc_int4_type_node = gfc_get_int_type (4);
569 /* Start a new block for this statement. */
570 gfc_init_se (&se, NULL);
571 gfc_start_block (&se.pre);
574 if (code->expr1 == NULL)
576 tmp = build_int_cst (gfc_int4_type_node, code->ext.stop_code);
577 tmp = build_call_expr (gfor_fndecl_stop_numeric, 1, tmp);
581 gfc_conv_expr_reference (&se, code->expr1);
582 tmp = build_call_expr (gfor_fndecl_stop_string, 2,
583 se.expr, se.string_length);
586 gfc_add_expr_to_block (&se.pre, tmp);
588 gfc_add_block_to_block (&se.pre, &se.post);
590 return gfc_finish_block (&se.pre);
594 /* Generate GENERIC for the IF construct. This function also deals with
595 the simple IF statement, because the front end translates the IF
596 statement into an IF construct.
628 where COND_S is the simplified version of the predicate. PRE_COND_S
629 are the pre side-effects produced by the translation of the
631 We need to build the chain recursively otherwise we run into
632 problems with folding incomplete statements. */
635 gfc_trans_if_1 (gfc_code * code)
640 /* Check for an unconditional ELSE clause. */
642 return gfc_trans_code (code->next);
644 /* Initialize a statement builder for each block. Puts in NULL_TREEs. */
645 gfc_init_se (&if_se, NULL);
646 gfc_start_block (&if_se.pre);
648 /* Calculate the IF condition expression. */
649 gfc_conv_expr_val (&if_se, code->expr1);
651 /* Translate the THEN clause. */
652 stmt = gfc_trans_code (code->next);
654 /* Translate the ELSE clause. */
656 elsestmt = gfc_trans_if_1 (code->block);
658 elsestmt = build_empty_stmt ();
660 /* Build the condition expression and add it to the condition block. */
661 stmt = fold_build3 (COND_EXPR, void_type_node, if_se.expr, stmt, elsestmt);
663 gfc_add_expr_to_block (&if_se.pre, stmt);
665 /* Finish off this statement. */
666 return gfc_finish_block (&if_se.pre);
670 gfc_trans_if (gfc_code * code)
672 /* Ignore the top EXEC_IF, it only announces an IF construct. The
673 actual code we must translate is in code->block. */
675 return gfc_trans_if_1 (code->block);
679 /* Translate an arithmetic IF expression.
681 IF (cond) label1, label2, label3 translates to
693 An optimized version can be generated in case of equal labels.
694 E.g., if label1 is equal to label2, we can translate it to
703 gfc_trans_arithmetic_if (gfc_code * code)
711 /* Start a new block. */
712 gfc_init_se (&se, NULL);
713 gfc_start_block (&se.pre);
715 /* Pre-evaluate COND. */
716 gfc_conv_expr_val (&se, code->expr1);
717 se.expr = gfc_evaluate_now (se.expr, &se.pre);
719 /* Build something to compare with. */
720 zero = gfc_build_const (TREE_TYPE (se.expr), integer_zero_node);
722 if (code->label1->value != code->label2->value)
724 /* If (cond < 0) take branch1 else take branch2.
725 First build jumps to the COND .LT. 0 and the COND .EQ. 0 cases. */
726 branch1 = build1_v (GOTO_EXPR, gfc_get_label_decl (code->label1));
727 branch2 = build1_v (GOTO_EXPR, gfc_get_label_decl (code->label2));
729 if (code->label1->value != code->label3->value)
730 tmp = fold_build2 (LT_EXPR, boolean_type_node, se.expr, zero);
732 tmp = fold_build2 (NE_EXPR, boolean_type_node, se.expr, zero);
734 branch1 = fold_build3 (COND_EXPR, void_type_node, tmp, branch1, branch2);
737 branch1 = build1_v (GOTO_EXPR, gfc_get_label_decl (code->label1));
739 if (code->label1->value != code->label3->value
740 && code->label2->value != code->label3->value)
742 /* if (cond <= 0) take branch1 else take branch2. */
743 branch2 = build1_v (GOTO_EXPR, gfc_get_label_decl (code->label3));
744 tmp = fold_build2 (LE_EXPR, boolean_type_node, se.expr, zero);
745 branch1 = fold_build3 (COND_EXPR, void_type_node, tmp, branch1, branch2);
748 /* Append the COND_EXPR to the evaluation of COND, and return. */
749 gfc_add_expr_to_block (&se.pre, branch1);
750 return gfc_finish_block (&se.pre);
754 /* Translate the simple DO construct. This is where the loop variable has
755 integer type and step +-1. We can't use this in the general case
756 because integer overflow and floating point errors could give incorrect
758 We translate a do loop from:
760 DO dovar = from, to, step
766 [Evaluate loop bounds and step]
768 if ((step > 0) ? (dovar <= to) : (dovar => to))
774 cond = (dovar == to);
776 if (cond) goto end_label;
781 This helps the optimizers by avoiding the extra induction variable
782 used in the general case. */
785 gfc_trans_simple_do (gfc_code * code, stmtblock_t *pblock, tree dovar,
786 tree from, tree to, tree step)
792 tree saved_dovar = NULL;
796 type = TREE_TYPE (dovar);
798 /* Initialize the DO variable: dovar = from. */
799 gfc_add_modify (pblock, dovar, from);
801 /* Save value for do-tinkering checking. */
802 if (gfc_option.rtcheck & GFC_RTCHECK_DO)
804 saved_dovar = gfc_create_var (type, ".saved_dovar");
805 gfc_add_modify (pblock, saved_dovar, dovar);
808 /* Cycle and exit statements are implemented with gotos. */
809 cycle_label = gfc_build_label_decl (NULL_TREE);
810 exit_label = gfc_build_label_decl (NULL_TREE);
812 /* Put the labels where they can be found later. See gfc_trans_do(). */
813 code->block->backend_decl = tree_cons (cycle_label, exit_label, NULL);
816 gfc_start_block (&body);
818 /* Main loop body. */
819 tmp = gfc_trans_code (code->block->next);
820 gfc_add_expr_to_block (&body, tmp);
822 /* Label for cycle statements (if needed). */
823 if (TREE_USED (cycle_label))
825 tmp = build1_v (LABEL_EXPR, cycle_label);
826 gfc_add_expr_to_block (&body, tmp);
829 /* Check whether someone has modified the loop variable. */
830 if (gfc_option.rtcheck & GFC_RTCHECK_DO)
832 tmp = fold_build2 (NE_EXPR, boolean_type_node, dovar, saved_dovar);
833 gfc_trans_runtime_check (true, false, tmp, &body, &code->loc,
834 "Loop variable has been modified");
837 /* Evaluate the loop condition. */
838 cond = fold_build2 (EQ_EXPR, boolean_type_node, dovar, to);
839 cond = gfc_evaluate_now (cond, &body);
841 /* Increment the loop variable. */
842 tmp = fold_build2 (PLUS_EXPR, type, dovar, step);
843 gfc_add_modify (&body, dovar, tmp);
845 if (gfc_option.rtcheck & GFC_RTCHECK_DO)
846 gfc_add_modify (&body, saved_dovar, dovar);
849 tmp = build1_v (GOTO_EXPR, exit_label);
850 TREE_USED (exit_label) = 1;
851 tmp = fold_build3 (COND_EXPR, void_type_node,
852 cond, tmp, build_empty_stmt ());
853 gfc_add_expr_to_block (&body, tmp);
855 /* Finish the loop body. */
856 tmp = gfc_finish_block (&body);
857 tmp = build1_v (LOOP_EXPR, tmp);
859 /* Only execute the loop if the number of iterations is positive. */
860 if (tree_int_cst_sgn (step) > 0)
861 cond = fold_build2 (LE_EXPR, boolean_type_node, dovar, to);
863 cond = fold_build2 (GE_EXPR, boolean_type_node, dovar, to);
864 tmp = fold_build3 (COND_EXPR, void_type_node,
865 cond, tmp, build_empty_stmt ());
866 gfc_add_expr_to_block (pblock, tmp);
868 /* Add the exit label. */
869 tmp = build1_v (LABEL_EXPR, exit_label);
870 gfc_add_expr_to_block (pblock, tmp);
872 return gfc_finish_block (pblock);
875 /* Translate the DO construct. This obviously is one of the most
876 important ones to get right with any compiler, but especially
879 We special case some loop forms as described in gfc_trans_simple_do.
880 For other cases we implement them with a separate loop count,
881 as described in the standard.
883 We translate a do loop from:
885 DO dovar = from, to, step
891 [evaluate loop bounds and step]
892 empty = (step > 0 ? to < from : to > from);
893 countm1 = (to - from) / step;
895 if (empty) goto exit_label;
901 if (countm1 ==0) goto exit_label;
906 countm1 is an unsigned integer. It is equal to the loop count minus one,
907 because the loop count itself can overflow. */
910 gfc_trans_do (gfc_code * code)
914 tree saved_dovar = NULL;
929 gfc_start_block (&block);
931 /* Evaluate all the expressions in the iterator. */
932 gfc_init_se (&se, NULL);
933 gfc_conv_expr_lhs (&se, code->ext.iterator->var);
934 gfc_add_block_to_block (&block, &se.pre);
936 type = TREE_TYPE (dovar);
938 gfc_init_se (&se, NULL);
939 gfc_conv_expr_val (&se, code->ext.iterator->start);
940 gfc_add_block_to_block (&block, &se.pre);
941 from = gfc_evaluate_now (se.expr, &block);
943 gfc_init_se (&se, NULL);
944 gfc_conv_expr_val (&se, code->ext.iterator->end);
945 gfc_add_block_to_block (&block, &se.pre);
946 to = gfc_evaluate_now (se.expr, &block);
948 gfc_init_se (&se, NULL);
949 gfc_conv_expr_val (&se, code->ext.iterator->step);
950 gfc_add_block_to_block (&block, &se.pre);
951 step = gfc_evaluate_now (se.expr, &block);
953 if (gfc_option.rtcheck & GFC_RTCHECK_DO)
955 tmp = fold_build2 (EQ_EXPR, boolean_type_node, step,
956 fold_convert (type, integer_zero_node));
957 gfc_trans_runtime_check (true, false, tmp, &block, &code->loc,
958 "DO step value is zero");
961 /* Special case simple loops. */
962 if (TREE_CODE (type) == INTEGER_TYPE
963 && (integer_onep (step)
964 || tree_int_cst_equal (step, integer_minus_one_node)))
965 return gfc_trans_simple_do (code, &block, dovar, from, to, step);
967 pos_step = fold_build2 (GT_EXPR, boolean_type_node, step,
968 fold_convert (type, integer_zero_node));
970 if (TREE_CODE (type) == INTEGER_TYPE)
971 utype = unsigned_type_for (type);
973 utype = unsigned_type_for (gfc_array_index_type);
974 countm1 = gfc_create_var (utype, "countm1");
976 /* Cycle and exit statements are implemented with gotos. */
977 cycle_label = gfc_build_label_decl (NULL_TREE);
978 exit_label = gfc_build_label_decl (NULL_TREE);
979 TREE_USED (exit_label) = 1;
981 /* Initialize the DO variable: dovar = from. */
982 gfc_add_modify (&block, dovar, from);
984 /* Save value for do-tinkering checking. */
985 if (gfc_option.rtcheck & GFC_RTCHECK_DO)
987 saved_dovar = gfc_create_var (type, ".saved_dovar");
988 gfc_add_modify (&block, saved_dovar, dovar);
991 /* Initialize loop count and jump to exit label if the loop is empty.
992 This code is executed before we enter the loop body. We generate:
995 if (to < from) goto exit_label;
996 countm1 = (to - from) / step;
1000 if (to > from) goto exit_label;
1001 countm1 = (from - to) / -step;
1003 if (TREE_CODE (type) == INTEGER_TYPE)
1007 tmp = fold_build2 (LT_EXPR, boolean_type_node, to, from);
1008 pos = fold_build3 (COND_EXPR, void_type_node, tmp,
1009 build1_v (GOTO_EXPR, exit_label),
1010 build_empty_stmt ());
1011 tmp = fold_build2 (MINUS_EXPR, type, to, from);
1012 tmp = fold_convert (utype, tmp);
1013 tmp = fold_build2 (TRUNC_DIV_EXPR, utype, tmp,
1014 fold_convert (utype, step));
1015 tmp = build2 (MODIFY_EXPR, void_type_node, countm1, tmp);
1016 pos = build2 (COMPOUND_EXPR, void_type_node, pos, tmp);
1018 tmp = fold_build2 (GT_EXPR, boolean_type_node, to, from);
1019 neg = fold_build3 (COND_EXPR, void_type_node, tmp,
1020 build1_v (GOTO_EXPR, exit_label),
1021 build_empty_stmt ());
1022 tmp = fold_build2 (MINUS_EXPR, type, from, to);
1023 tmp = fold_convert (utype, tmp);
1024 tmp = fold_build2 (TRUNC_DIV_EXPR, utype, tmp,
1025 fold_convert (utype, fold_build1 (NEGATE_EXPR,
1027 tmp = build2 (MODIFY_EXPR, void_type_node, countm1, tmp);
1028 neg = build2 (COMPOUND_EXPR, void_type_node, neg, tmp);
1030 tmp = fold_build3 (COND_EXPR, void_type_node, pos_step, pos, neg);
1031 gfc_add_expr_to_block (&block, tmp);
1035 /* TODO: We could use the same width as the real type.
1036 This would probably cause more problems that it solves
1037 when we implement "long double" types. */
1039 tmp = fold_build2 (MINUS_EXPR, type, to, from);
1040 tmp = fold_build2 (RDIV_EXPR, type, tmp, step);
1041 tmp = fold_build1 (FIX_TRUNC_EXPR, utype, tmp);
1042 gfc_add_modify (&block, countm1, tmp);
1044 /* We need a special check for empty loops:
1045 empty = (step > 0 ? to < from : to > from); */
1046 tmp = fold_build3 (COND_EXPR, boolean_type_node, pos_step,
1047 fold_build2 (LT_EXPR, boolean_type_node, to, from),
1048 fold_build2 (GT_EXPR, boolean_type_node, to, from));
1049 /* If the loop is empty, go directly to the exit label. */
1050 tmp = fold_build3 (COND_EXPR, void_type_node, tmp,
1051 build1_v (GOTO_EXPR, exit_label),
1052 build_empty_stmt ());
1053 gfc_add_expr_to_block (&block, tmp);
1057 gfc_start_block (&body);
1059 /* Put these labels where they can be found later. We put the
1060 labels in a TREE_LIST node (because TREE_CHAIN is already
1061 used). cycle_label goes in TREE_PURPOSE (backend_decl), exit
1062 label in TREE_VALUE (backend_decl). */
1064 code->block->backend_decl = tree_cons (cycle_label, exit_label, NULL);
1066 /* Main loop body. */
1067 tmp = gfc_trans_code (code->block->next);
1068 gfc_add_expr_to_block (&body, tmp);
1070 /* Label for cycle statements (if needed). */
1071 if (TREE_USED (cycle_label))
1073 tmp = build1_v (LABEL_EXPR, cycle_label);
1074 gfc_add_expr_to_block (&body, tmp);
1077 /* Check whether someone has modified the loop variable. */
1078 if (gfc_option.rtcheck & GFC_RTCHECK_DO)
1080 tmp = fold_build2 (NE_EXPR, boolean_type_node, dovar, saved_dovar);
1081 gfc_trans_runtime_check (true, false, tmp, &body, &code->loc,
1082 "Loop variable has been modified");
1085 /* Increment the loop variable. */
1086 tmp = fold_build2 (PLUS_EXPR, type, dovar, step);
1087 gfc_add_modify (&body, dovar, tmp);
1089 if (gfc_option.rtcheck & GFC_RTCHECK_DO)
1090 gfc_add_modify (&body, saved_dovar, dovar);
1092 /* End with the loop condition. Loop until countm1 == 0. */
1093 cond = fold_build2 (EQ_EXPR, boolean_type_node, countm1,
1094 build_int_cst (utype, 0));
1095 tmp = build1_v (GOTO_EXPR, exit_label);
1096 tmp = fold_build3 (COND_EXPR, void_type_node,
1097 cond, tmp, build_empty_stmt ());
1098 gfc_add_expr_to_block (&body, tmp);
1100 /* Decrement the loop count. */
1101 tmp = fold_build2 (MINUS_EXPR, utype, countm1, build_int_cst (utype, 1));
1102 gfc_add_modify (&body, countm1, tmp);
1104 /* End of loop body. */
1105 tmp = gfc_finish_block (&body);
1107 /* The for loop itself. */
1108 tmp = build1_v (LOOP_EXPR, tmp);
1109 gfc_add_expr_to_block (&block, tmp);
1111 /* Add the exit label. */
1112 tmp = build1_v (LABEL_EXPR, exit_label);
1113 gfc_add_expr_to_block (&block, tmp);
1115 return gfc_finish_block (&block);
1119 /* Translate the DO WHILE construct.
1132 if (! cond) goto exit_label;
1138 Because the evaluation of the exit condition `cond' may have side
1139 effects, we can't do much for empty loop bodies. The backend optimizers
1140 should be smart enough to eliminate any dead loops. */
1143 gfc_trans_do_while (gfc_code * code)
1151 /* Everything we build here is part of the loop body. */
1152 gfc_start_block (&block);
1154 /* Cycle and exit statements are implemented with gotos. */
1155 cycle_label = gfc_build_label_decl (NULL_TREE);
1156 exit_label = gfc_build_label_decl (NULL_TREE);
1158 /* Put the labels where they can be found later. See gfc_trans_do(). */
1159 code->block->backend_decl = tree_cons (cycle_label, exit_label, NULL);
1161 /* Create a GIMPLE version of the exit condition. */
1162 gfc_init_se (&cond, NULL);
1163 gfc_conv_expr_val (&cond, code->expr1);
1164 gfc_add_block_to_block (&block, &cond.pre);
1165 cond.expr = fold_build1 (TRUTH_NOT_EXPR, boolean_type_node, cond.expr);
1167 /* Build "IF (! cond) GOTO exit_label". */
1168 tmp = build1_v (GOTO_EXPR, exit_label);
1169 TREE_USED (exit_label) = 1;
1170 tmp = fold_build3 (COND_EXPR, void_type_node,
1171 cond.expr, tmp, build_empty_stmt ());
1172 gfc_add_expr_to_block (&block, tmp);
1174 /* The main body of the loop. */
1175 tmp = gfc_trans_code (code->block->next);
1176 gfc_add_expr_to_block (&block, tmp);
1178 /* Label for cycle statements (if needed). */
1179 if (TREE_USED (cycle_label))
1181 tmp = build1_v (LABEL_EXPR, cycle_label);
1182 gfc_add_expr_to_block (&block, tmp);
1185 /* End of loop body. */
1186 tmp = gfc_finish_block (&block);
1188 gfc_init_block (&block);
1189 /* Build the loop. */
1190 tmp = build1_v (LOOP_EXPR, tmp);
1191 gfc_add_expr_to_block (&block, tmp);
1193 /* Add the exit label. */
1194 tmp = build1_v (LABEL_EXPR, exit_label);
1195 gfc_add_expr_to_block (&block, tmp);
1197 return gfc_finish_block (&block);
1201 /* Translate the SELECT CASE construct for INTEGER case expressions,
1202 without killing all potential optimizations. The problem is that
1203 Fortran allows unbounded cases, but the back-end does not, so we
1204 need to intercept those before we enter the equivalent SWITCH_EXPR
1207 For example, we translate this,
1210 CASE (:100,101,105:115)
1220 to the GENERIC equivalent,
1224 case (minimum value for typeof(expr) ... 100:
1230 case 200 ... (maximum value for typeof(expr):
1247 gfc_trans_integer_select (gfc_code * code)
1257 gfc_start_block (&block);
1259 /* Calculate the switch expression. */
1260 gfc_init_se (&se, NULL);
1261 gfc_conv_expr_val (&se, code->expr1);
1262 gfc_add_block_to_block (&block, &se.pre);
1264 end_label = gfc_build_label_decl (NULL_TREE);
1266 gfc_init_block (&body);
1268 for (c = code->block; c; c = c->block)
1270 for (cp = c->ext.case_list; cp; cp = cp->next)
1275 /* Assume it's the default case. */
1276 low = high = NULL_TREE;
1280 low = gfc_conv_mpz_to_tree (cp->low->value.integer,
1283 /* If there's only a lower bound, set the high bound to the
1284 maximum value of the case expression. */
1286 high = TYPE_MAX_VALUE (TREE_TYPE (se.expr));
1291 /* Three cases are possible here:
1293 1) There is no lower bound, e.g. CASE (:N).
1294 2) There is a lower bound .NE. high bound, that is
1295 a case range, e.g. CASE (N:M) where M>N (we make
1296 sure that M>N during type resolution).
1297 3) There is a lower bound, and it has the same value
1298 as the high bound, e.g. CASE (N:N). This is our
1299 internal representation of CASE(N).
1301 In the first and second case, we need to set a value for
1302 high. In the third case, we don't because the GCC middle
1303 end represents a single case value by just letting high be
1304 a NULL_TREE. We can't do that because we need to be able
1305 to represent unbounded cases. */
1309 && mpz_cmp (cp->low->value.integer,
1310 cp->high->value.integer) != 0))
1311 high = gfc_conv_mpz_to_tree (cp->high->value.integer,
1314 /* Unbounded case. */
1316 low = TYPE_MIN_VALUE (TREE_TYPE (se.expr));
1319 /* Build a label. */
1320 label = gfc_build_label_decl (NULL_TREE);
1322 /* Add this case label.
1323 Add parameter 'label', make it match GCC backend. */
1324 tmp = fold_build3 (CASE_LABEL_EXPR, void_type_node,
1326 gfc_add_expr_to_block (&body, tmp);
1329 /* Add the statements for this case. */
1330 tmp = gfc_trans_code (c->next);
1331 gfc_add_expr_to_block (&body, tmp);
1333 /* Break to the end of the construct. */
1334 tmp = build1_v (GOTO_EXPR, end_label);
1335 gfc_add_expr_to_block (&body, tmp);
1338 tmp = gfc_finish_block (&body);
1339 tmp = build3_v (SWITCH_EXPR, se.expr, tmp, NULL_TREE);
1340 gfc_add_expr_to_block (&block, tmp);
1342 tmp = build1_v (LABEL_EXPR, end_label);
1343 gfc_add_expr_to_block (&block, tmp);
1345 return gfc_finish_block (&block);
1349 /* Translate the SELECT CASE construct for LOGICAL case expressions.
1351 There are only two cases possible here, even though the standard
1352 does allow three cases in a LOGICAL SELECT CASE construct: .TRUE.,
1353 .FALSE., and DEFAULT.
1355 We never generate more than two blocks here. Instead, we always
1356 try to eliminate the DEFAULT case. This way, we can translate this
1357 kind of SELECT construct to a simple
1361 expression in GENERIC. */
1364 gfc_trans_logical_select (gfc_code * code)
1367 gfc_code *t, *f, *d;
1372 /* Assume we don't have any cases at all. */
1375 /* Now see which ones we actually do have. We can have at most two
1376 cases in a single case list: one for .TRUE. and one for .FALSE.
1377 The default case is always separate. If the cases for .TRUE. and
1378 .FALSE. are in the same case list, the block for that case list
1379 always executed, and we don't generate code a COND_EXPR. */
1380 for (c = code->block; c; c = c->block)
1382 for (cp = c->ext.case_list; cp; cp = cp->next)
1386 if (cp->low->value.logical == 0) /* .FALSE. */
1388 else /* if (cp->value.logical != 0), thus .TRUE. */
1396 /* Start a new block. */
1397 gfc_start_block (&block);
1399 /* Calculate the switch expression. We always need to do this
1400 because it may have side effects. */
1401 gfc_init_se (&se, NULL);
1402 gfc_conv_expr_val (&se, code->expr1);
1403 gfc_add_block_to_block (&block, &se.pre);
1405 if (t == f && t != NULL)
1407 /* Cases for .TRUE. and .FALSE. are in the same block. Just
1408 translate the code for these cases, append it to the current
1410 gfc_add_expr_to_block (&block, gfc_trans_code (t->next));
1414 tree true_tree, false_tree, stmt;
1416 true_tree = build_empty_stmt ();
1417 false_tree = build_empty_stmt ();
1419 /* If we have a case for .TRUE. and for .FALSE., discard the default case.
1420 Otherwise, if .TRUE. or .FALSE. is missing and there is a default case,
1421 make the missing case the default case. */
1422 if (t != NULL && f != NULL)
1432 /* Translate the code for each of these blocks, and append it to
1433 the current block. */
1435 true_tree = gfc_trans_code (t->next);
1438 false_tree = gfc_trans_code (f->next);
1440 stmt = fold_build3 (COND_EXPR, void_type_node, se.expr,
1441 true_tree, false_tree);
1442 gfc_add_expr_to_block (&block, stmt);
1445 return gfc_finish_block (&block);
1449 /* Translate the SELECT CASE construct for CHARACTER case expressions.
1450 Instead of generating compares and jumps, it is far simpler to
1451 generate a data structure describing the cases in order and call a
1452 library subroutine that locates the right case.
1453 This is particularly true because this is the only case where we
1454 might have to dispose of a temporary.
1455 The library subroutine returns a pointer to jump to or NULL if no
1456 branches are to be taken. */
1459 gfc_trans_character_select (gfc_code *code)
1461 tree init, node, end_label, tmp, type, case_num, label, fndecl;
1462 stmtblock_t block, body;
1468 /* The jump table types are stored in static variables to avoid
1469 constructing them from scratch every single time. */
1470 static tree select_struct[2];
1471 static tree ss_string1[2], ss_string1_len[2];
1472 static tree ss_string2[2], ss_string2_len[2];
1473 static tree ss_target[2];
1475 tree pchartype = gfc_get_pchar_type (code->expr1->ts.kind);
1477 if (code->expr1->ts.kind == 1)
1479 else if (code->expr1->ts.kind == 4)
1484 if (select_struct[k] == NULL)
1486 select_struct[k] = make_node (RECORD_TYPE);
1488 if (code->expr1->ts.kind == 1)
1489 TYPE_NAME (select_struct[k]) = get_identifier ("_jump_struct_char1");
1490 else if (code->expr1->ts.kind == 4)
1491 TYPE_NAME (select_struct[k]) = get_identifier ("_jump_struct_char4");
1496 #define ADD_FIELD(NAME, TYPE) \
1497 ss_##NAME[k] = gfc_add_field_to_struct \
1498 (&(TYPE_FIELDS (select_struct[k])), select_struct[k], \
1499 get_identifier (stringize(NAME)), TYPE)
1501 ADD_FIELD (string1, pchartype);
1502 ADD_FIELD (string1_len, gfc_charlen_type_node);
1504 ADD_FIELD (string2, pchartype);
1505 ADD_FIELD (string2_len, gfc_charlen_type_node);
1507 ADD_FIELD (target, integer_type_node);
1510 gfc_finish_type (select_struct[k]);
1513 cp = code->block->ext.case_list;
1514 while (cp->left != NULL)
1518 for (d = cp; d; d = d->right)
1521 end_label = gfc_build_label_decl (NULL_TREE);
1523 /* Generate the body */
1524 gfc_start_block (&block);
1525 gfc_init_block (&body);
1527 for (c = code->block; c; c = c->block)
1529 for (d = c->ext.case_list; d; d = d->next)
1531 label = gfc_build_label_decl (NULL_TREE);
1532 tmp = fold_build3 (CASE_LABEL_EXPR, void_type_node,
1533 build_int_cst (NULL_TREE, d->n),
1534 build_int_cst (NULL_TREE, d->n), label);
1535 gfc_add_expr_to_block (&body, tmp);
1538 tmp = gfc_trans_code (c->next);
1539 gfc_add_expr_to_block (&body, tmp);
1541 tmp = build1_v (GOTO_EXPR, end_label);
1542 gfc_add_expr_to_block (&body, tmp);
1545 /* Generate the structure describing the branches */
1548 for(d = cp; d; d = d->right)
1552 gfc_init_se (&se, NULL);
1556 node = tree_cons (ss_string1[k], null_pointer_node, node);
1557 node = tree_cons (ss_string1_len[k], integer_zero_node, node);
1561 gfc_conv_expr_reference (&se, d->low);
1563 node = tree_cons (ss_string1[k], se.expr, node);
1564 node = tree_cons (ss_string1_len[k], se.string_length, node);
1567 if (d->high == NULL)
1569 node = tree_cons (ss_string2[k], null_pointer_node, node);
1570 node = tree_cons (ss_string2_len[k], integer_zero_node, node);
1574 gfc_init_se (&se, NULL);
1575 gfc_conv_expr_reference (&se, d->high);
1577 node = tree_cons (ss_string2[k], se.expr, node);
1578 node = tree_cons (ss_string2_len[k], se.string_length, node);
1581 node = tree_cons (ss_target[k], build_int_cst (integer_type_node, d->n),
1584 tmp = build_constructor_from_list (select_struct[k], nreverse (node));
1585 init = tree_cons (NULL_TREE, tmp, init);
1588 type = build_array_type (select_struct[k],
1589 build_index_type (build_int_cst (NULL_TREE, n-1)));
1591 init = build_constructor_from_list (type, nreverse(init));
1592 TREE_CONSTANT (init) = 1;
1593 TREE_STATIC (init) = 1;
1594 /* Create a static variable to hold the jump table. */
1595 tmp = gfc_create_var (type, "jumptable");
1596 TREE_CONSTANT (tmp) = 1;
1597 TREE_STATIC (tmp) = 1;
1598 TREE_READONLY (tmp) = 1;
1599 DECL_INITIAL (tmp) = init;
1602 /* Build the library call */
1603 init = gfc_build_addr_expr (pvoid_type_node, init);
1605 gfc_init_se (&se, NULL);
1606 gfc_conv_expr_reference (&se, code->expr1);
1608 gfc_add_block_to_block (&block, &se.pre);
1610 if (code->expr1->ts.kind == 1)
1611 fndecl = gfor_fndecl_select_string;
1612 else if (code->expr1->ts.kind == 4)
1613 fndecl = gfor_fndecl_select_string_char4;
1617 tmp = build_call_expr (fndecl, 4, init, build_int_cst (NULL_TREE, n),
1618 se.expr, se.string_length);
1619 case_num = gfc_create_var (integer_type_node, "case_num");
1620 gfc_add_modify (&block, case_num, tmp);
1622 gfc_add_block_to_block (&block, &se.post);
1624 tmp = gfc_finish_block (&body);
1625 tmp = build3_v (SWITCH_EXPR, case_num, tmp, NULL_TREE);
1626 gfc_add_expr_to_block (&block, tmp);
1628 tmp = build1_v (LABEL_EXPR, end_label);
1629 gfc_add_expr_to_block (&block, tmp);
1631 return gfc_finish_block (&block);
1635 /* Translate the three variants of the SELECT CASE construct.
1637 SELECT CASEs with INTEGER case expressions can be translated to an
1638 equivalent GENERIC switch statement, and for LOGICAL case
1639 expressions we build one or two if-else compares.
1641 SELECT CASEs with CHARACTER case expressions are a whole different
1642 story, because they don't exist in GENERIC. So we sort them and
1643 do a binary search at runtime.
1645 Fortran has no BREAK statement, and it does not allow jumps from
1646 one case block to another. That makes things a lot easier for
1650 gfc_trans_select (gfc_code * code)
1652 gcc_assert (code && code->expr1);
1654 /* Empty SELECT constructs are legal. */
1655 if (code->block == NULL)
1656 return build_empty_stmt ();
1658 /* Select the correct translation function. */
1659 switch (code->expr1->ts.type)
1661 case BT_LOGICAL: return gfc_trans_logical_select (code);
1662 case BT_INTEGER: return gfc_trans_integer_select (code);
1663 case BT_CHARACTER: return gfc_trans_character_select (code);
1665 gfc_internal_error ("gfc_trans_select(): Bad type for case expr.");
1671 /* Traversal function to substitute a replacement symtree if the symbol
1672 in the expression is the same as that passed. f == 2 signals that
1673 that variable itself is not to be checked - only the references.
1674 This group of functions is used when the variable expression in a
1675 FORALL assignment has internal references. For example:
1676 FORALL (i = 1:4) p(p(i)) = i
1677 The only recourse here is to store a copy of 'p' for the index
1680 static gfc_symtree *new_symtree;
1681 static gfc_symtree *old_symtree;
1684 forall_replace (gfc_expr *expr, gfc_symbol *sym, int *f)
1686 if (expr->expr_type != EXPR_VARIABLE)
1691 else if (expr->symtree->n.sym == sym)
1692 expr->symtree = new_symtree;
1698 forall_replace_symtree (gfc_expr *e, gfc_symbol *sym, int f)
1700 gfc_traverse_expr (e, sym, forall_replace, f);
1704 forall_restore (gfc_expr *expr,
1705 gfc_symbol *sym ATTRIBUTE_UNUSED,
1706 int *f ATTRIBUTE_UNUSED)
1708 if (expr->expr_type != EXPR_VARIABLE)
1711 if (expr->symtree == new_symtree)
1712 expr->symtree = old_symtree;
1718 forall_restore_symtree (gfc_expr *e)
1720 gfc_traverse_expr (e, NULL, forall_restore, 0);
1724 forall_make_variable_temp (gfc_code *c, stmtblock_t *pre, stmtblock_t *post)
1729 gfc_symbol *new_sym;
1730 gfc_symbol *old_sym;
1734 /* Build a copy of the lvalue. */
1735 old_symtree = c->expr1->symtree;
1736 old_sym = old_symtree->n.sym;
1737 e = gfc_lval_expr_from_sym (old_sym);
1738 if (old_sym->attr.dimension)
1740 gfc_init_se (&tse, NULL);
1741 gfc_conv_subref_array_arg (&tse, e, 0, INTENT_IN);
1742 gfc_add_block_to_block (pre, &tse.pre);
1743 gfc_add_block_to_block (post, &tse.post);
1744 tse.expr = build_fold_indirect_ref (tse.expr);
1746 if (e->ts.type != BT_CHARACTER)
1748 /* Use the variable offset for the temporary. */
1749 tmp = gfc_conv_array_offset (old_sym->backend_decl);
1750 gfc_conv_descriptor_offset_set (pre, tse.expr, tmp);
1755 gfc_init_se (&tse, NULL);
1756 gfc_init_se (&rse, NULL);
1757 gfc_conv_expr (&rse, e);
1758 if (e->ts.type == BT_CHARACTER)
1760 tse.string_length = rse.string_length;
1761 tmp = gfc_get_character_type_len (gfc_default_character_kind,
1763 tse.expr = gfc_conv_string_tmp (&tse, build_pointer_type (tmp),
1765 gfc_add_block_to_block (pre, &tse.pre);
1766 gfc_add_block_to_block (post, &tse.post);
1770 tmp = gfc_typenode_for_spec (&e->ts);
1771 tse.expr = gfc_create_var (tmp, "temp");
1774 tmp = gfc_trans_scalar_assign (&tse, &rse, e->ts, true,
1775 e->expr_type == EXPR_VARIABLE);
1776 gfc_add_expr_to_block (pre, tmp);
1780 /* Create a new symbol to represent the lvalue. */
1781 new_sym = gfc_new_symbol (old_sym->name, NULL);
1782 new_sym->ts = old_sym->ts;
1783 new_sym->attr.referenced = 1;
1784 new_sym->attr.temporary = 1;
1785 new_sym->attr.dimension = old_sym->attr.dimension;
1786 new_sym->attr.flavor = old_sym->attr.flavor;
1788 /* Use the temporary as the backend_decl. */
1789 new_sym->backend_decl = tse.expr;
1791 /* Create a fake symtree for it. */
1793 new_symtree = gfc_new_symtree (&root, old_sym->name);
1794 new_symtree->n.sym = new_sym;
1795 gcc_assert (new_symtree == root);
1797 /* Go through the expression reference replacing the old_symtree
1799 forall_replace_symtree (c->expr1, old_sym, 2);
1801 /* Now we have made this temporary, we might as well use it for
1802 the right hand side. */
1803 forall_replace_symtree (c->expr2, old_sym, 1);
1807 /* Handles dependencies in forall assignments. */
1809 check_forall_dependencies (gfc_code *c, stmtblock_t *pre, stmtblock_t *post)
1816 lsym = c->expr1->symtree->n.sym;
1817 need_temp = gfc_check_dependency (c->expr1, c->expr2, 0);
1819 /* Now check for dependencies within the 'variable'
1820 expression itself. These are treated by making a complete
1821 copy of variable and changing all the references to it
1822 point to the copy instead. Note that the shallow copy of
1823 the variable will not suffice for derived types with
1824 pointer components. We therefore leave these to their
1826 if (lsym->ts.type == BT_DERIVED
1827 && lsym->ts.derived->attr.pointer_comp)
1831 if (find_forall_index (c->expr1, lsym, 2) == SUCCESS)
1833 forall_make_variable_temp (c, pre, post);
1837 /* Substrings with dependencies are treated in the same
1839 if (c->expr1->ts.type == BT_CHARACTER
1841 && c->expr2->expr_type == EXPR_VARIABLE
1842 && lsym == c->expr2->symtree->n.sym)
1844 for (lref = c->expr1->ref; lref; lref = lref->next)
1845 if (lref->type == REF_SUBSTRING)
1847 for (rref = c->expr2->ref; rref; rref = rref->next)
1848 if (rref->type == REF_SUBSTRING)
1852 && gfc_dep_compare_expr (rref->u.ss.start, lref->u.ss.start) < 0)
1854 forall_make_variable_temp (c, pre, post);
1863 cleanup_forall_symtrees (gfc_code *c)
1865 forall_restore_symtree (c->expr1);
1866 forall_restore_symtree (c->expr2);
1867 gfc_free (new_symtree->n.sym);
1868 gfc_free (new_symtree);
1872 /* Generate the loops for a FORALL block, specified by FORALL_TMP. BODY
1873 is the contents of the FORALL block/stmt to be iterated. MASK_FLAG
1874 indicates whether we should generate code to test the FORALLs mask
1875 array. OUTER is the loop header to be used for initializing mask
1878 The generated loop format is:
1879 count = (end - start + step) / step
1892 gfc_trans_forall_loop (forall_info *forall_tmp, tree body,
1893 int mask_flag, stmtblock_t *outer)
1901 tree var, start, end, step;
1904 /* Initialize the mask index outside the FORALL nest. */
1905 if (mask_flag && forall_tmp->mask)
1906 gfc_add_modify (outer, forall_tmp->maskindex, gfc_index_zero_node);
1908 iter = forall_tmp->this_loop;
1909 nvar = forall_tmp->nvar;
1910 for (n = 0; n < nvar; n++)
1913 start = iter->start;
1917 exit_label = gfc_build_label_decl (NULL_TREE);
1918 TREE_USED (exit_label) = 1;
1920 /* The loop counter. */
1921 count = gfc_create_var (TREE_TYPE (var), "count");
1923 /* The body of the loop. */
1924 gfc_init_block (&block);
1926 /* The exit condition. */
1927 cond = fold_build2 (LE_EXPR, boolean_type_node,
1928 count, build_int_cst (TREE_TYPE (count), 0));
1929 tmp = build1_v (GOTO_EXPR, exit_label);
1930 tmp = fold_build3 (COND_EXPR, void_type_node,
1931 cond, tmp, build_empty_stmt ());
1932 gfc_add_expr_to_block (&block, tmp);
1934 /* The main loop body. */
1935 gfc_add_expr_to_block (&block, body);
1937 /* Increment the loop variable. */
1938 tmp = fold_build2 (PLUS_EXPR, TREE_TYPE (var), var, step);
1939 gfc_add_modify (&block, var, tmp);
1941 /* Advance to the next mask element. Only do this for the
1943 if (n == 0 && mask_flag && forall_tmp->mask)
1945 tree maskindex = forall_tmp->maskindex;
1946 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1947 maskindex, gfc_index_one_node);
1948 gfc_add_modify (&block, maskindex, tmp);
1951 /* Decrement the loop counter. */
1952 tmp = fold_build2 (MINUS_EXPR, TREE_TYPE (var), count,
1953 build_int_cst (TREE_TYPE (var), 1));
1954 gfc_add_modify (&block, count, tmp);
1956 body = gfc_finish_block (&block);
1958 /* Loop var initialization. */
1959 gfc_init_block (&block);
1960 gfc_add_modify (&block, var, start);
1963 /* Initialize the loop counter. */
1964 tmp = fold_build2 (MINUS_EXPR, TREE_TYPE (var), step, start);
1965 tmp = fold_build2 (PLUS_EXPR, TREE_TYPE (var), end, tmp);
1966 tmp = fold_build2 (TRUNC_DIV_EXPR, TREE_TYPE (var), tmp, step);
1967 gfc_add_modify (&block, count, tmp);
1969 /* The loop expression. */
1970 tmp = build1_v (LOOP_EXPR, body);
1971 gfc_add_expr_to_block (&block, tmp);
1973 /* The exit label. */
1974 tmp = build1_v (LABEL_EXPR, exit_label);
1975 gfc_add_expr_to_block (&block, tmp);
1977 body = gfc_finish_block (&block);
1984 /* Generate the body and loops according to MASK_FLAG. If MASK_FLAG
1985 is nonzero, the body is controlled by all masks in the forall nest.
1986 Otherwise, the innermost loop is not controlled by it's mask. This
1987 is used for initializing that mask. */
1990 gfc_trans_nested_forall_loop (forall_info * nested_forall_info, tree body,
1995 forall_info *forall_tmp;
1996 tree mask, maskindex;
1998 gfc_start_block (&header);
2000 forall_tmp = nested_forall_info;
2001 while (forall_tmp != NULL)
2003 /* Generate body with masks' control. */
2006 mask = forall_tmp->mask;
2007 maskindex = forall_tmp->maskindex;
2009 /* If a mask was specified make the assignment conditional. */
2012 tmp = gfc_build_array_ref (mask, maskindex, NULL);
2013 body = build3_v (COND_EXPR, tmp, body, build_empty_stmt ());
2016 body = gfc_trans_forall_loop (forall_tmp, body, mask_flag, &header);
2017 forall_tmp = forall_tmp->prev_nest;
2021 gfc_add_expr_to_block (&header, body);
2022 return gfc_finish_block (&header);
2026 /* Allocate data for holding a temporary array. Returns either a local
2027 temporary array or a pointer variable. */
2030 gfc_do_allocate (tree bytesize, tree size, tree * pdata, stmtblock_t * pblock,
2037 if (INTEGER_CST_P (size))
2039 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, size,
2040 gfc_index_one_node);
2045 type = build_range_type (gfc_array_index_type, gfc_index_zero_node, tmp);
2046 type = build_array_type (elem_type, type);
2047 if (gfc_can_put_var_on_stack (bytesize))
2049 gcc_assert (INTEGER_CST_P (size));
2050 tmpvar = gfc_create_var (type, "temp");
2055 tmpvar = gfc_create_var (build_pointer_type (type), "temp");
2056 *pdata = convert (pvoid_type_node, tmpvar);
2058 tmp = gfc_call_malloc (pblock, TREE_TYPE (tmpvar), bytesize);
2059 gfc_add_modify (pblock, tmpvar, tmp);
2065 /* Generate codes to copy the temporary to the actual lhs. */
2068 generate_loop_for_temp_to_lhs (gfc_expr *expr, tree tmp1, tree count3,
2069 tree count1, tree wheremask, bool invert)
2073 stmtblock_t block, body;
2079 lss = gfc_walk_expr (expr);
2081 if (lss == gfc_ss_terminator)
2083 gfc_start_block (&block);
2085 gfc_init_se (&lse, NULL);
2087 /* Translate the expression. */
2088 gfc_conv_expr (&lse, expr);
2090 /* Form the expression for the temporary. */
2091 tmp = gfc_build_array_ref (tmp1, count1, NULL);
2093 /* Use the scalar assignment as is. */
2094 gfc_add_block_to_block (&block, &lse.pre);
2095 gfc_add_modify (&block, lse.expr, tmp);
2096 gfc_add_block_to_block (&block, &lse.post);
2098 /* Increment the count1. */
2099 tmp = fold_build2 (PLUS_EXPR, TREE_TYPE (count1), count1,
2100 gfc_index_one_node);
2101 gfc_add_modify (&block, count1, tmp);
2103 tmp = gfc_finish_block (&block);
2107 gfc_start_block (&block);
2109 gfc_init_loopinfo (&loop1);
2110 gfc_init_se (&rse, NULL);
2111 gfc_init_se (&lse, NULL);
2113 /* Associate the lss with the loop. */
2114 gfc_add_ss_to_loop (&loop1, lss);
2116 /* Calculate the bounds of the scalarization. */
2117 gfc_conv_ss_startstride (&loop1);
2118 /* Setup the scalarizing loops. */
2119 gfc_conv_loop_setup (&loop1, &expr->where);
2121 gfc_mark_ss_chain_used (lss, 1);
2123 /* Start the scalarized loop body. */
2124 gfc_start_scalarized_body (&loop1, &body);
2126 /* Setup the gfc_se structures. */
2127 gfc_copy_loopinfo_to_se (&lse, &loop1);
2130 /* Form the expression of the temporary. */
2131 if (lss != gfc_ss_terminator)
2132 rse.expr = gfc_build_array_ref (tmp1, count1, NULL);
2133 /* Translate expr. */
2134 gfc_conv_expr (&lse, expr);
2136 /* Use the scalar assignment. */
2137 rse.string_length = lse.string_length;
2138 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts, false, false);
2140 /* Form the mask expression according to the mask tree list. */
2143 wheremaskexpr = gfc_build_array_ref (wheremask, count3, NULL);
2145 wheremaskexpr = fold_build1 (TRUTH_NOT_EXPR,
2146 TREE_TYPE (wheremaskexpr),
2148 tmp = fold_build3 (COND_EXPR, void_type_node,
2149 wheremaskexpr, tmp, build_empty_stmt ());
2152 gfc_add_expr_to_block (&body, tmp);
2154 /* Increment count1. */
2155 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2156 count1, gfc_index_one_node);
2157 gfc_add_modify (&body, count1, tmp);
2159 /* Increment count3. */
2162 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2163 count3, gfc_index_one_node);
2164 gfc_add_modify (&body, count3, tmp);
2167 /* Generate the copying loops. */
2168 gfc_trans_scalarizing_loops (&loop1, &body);
2169 gfc_add_block_to_block (&block, &loop1.pre);
2170 gfc_add_block_to_block (&block, &loop1.post);
2171 gfc_cleanup_loop (&loop1);
2173 tmp = gfc_finish_block (&block);
2179 /* Generate codes to copy rhs to the temporary. TMP1 is the address of
2180 temporary, LSS and RSS are formed in function compute_inner_temp_size(),
2181 and should not be freed. WHEREMASK is the conditional execution mask
2182 whose sense may be inverted by INVERT. */
2185 generate_loop_for_rhs_to_temp (gfc_expr *expr2, tree tmp1, tree count3,
2186 tree count1, gfc_ss *lss, gfc_ss *rss,
2187 tree wheremask, bool invert)
2189 stmtblock_t block, body1;
2196 gfc_start_block (&block);
2198 gfc_init_se (&rse, NULL);
2199 gfc_init_se (&lse, NULL);
2201 if (lss == gfc_ss_terminator)
2203 gfc_init_block (&body1);
2204 gfc_conv_expr (&rse, expr2);
2205 lse.expr = gfc_build_array_ref (tmp1, count1, NULL);
2209 /* Initialize the loop. */
2210 gfc_init_loopinfo (&loop);
2212 /* We may need LSS to determine the shape of the expression. */
2213 gfc_add_ss_to_loop (&loop, lss);
2214 gfc_add_ss_to_loop (&loop, rss);
2216 gfc_conv_ss_startstride (&loop);
2217 gfc_conv_loop_setup (&loop, &expr2->where);
2219 gfc_mark_ss_chain_used (rss, 1);
2220 /* Start the loop body. */
2221 gfc_start_scalarized_body (&loop, &body1);
2223 /* Translate the expression. */
2224 gfc_copy_loopinfo_to_se (&rse, &loop);
2226 gfc_conv_expr (&rse, expr2);
2228 /* Form the expression of the temporary. */
2229 lse.expr = gfc_build_array_ref (tmp1, count1, NULL);
2232 /* Use the scalar assignment. */
2233 lse.string_length = rse.string_length;
2234 tmp = gfc_trans_scalar_assign (&lse, &rse, expr2->ts, true,
2235 expr2->expr_type == EXPR_VARIABLE);
2237 /* Form the mask expression according to the mask tree list. */
2240 wheremaskexpr = gfc_build_array_ref (wheremask, count3, NULL);
2242 wheremaskexpr = fold_build1 (TRUTH_NOT_EXPR,
2243 TREE_TYPE (wheremaskexpr),
2245 tmp = fold_build3 (COND_EXPR, void_type_node,
2246 wheremaskexpr, tmp, build_empty_stmt ());
2249 gfc_add_expr_to_block (&body1, tmp);
2251 if (lss == gfc_ss_terminator)
2253 gfc_add_block_to_block (&block, &body1);
2255 /* Increment count1. */
2256 tmp = fold_build2 (PLUS_EXPR, TREE_TYPE (count1), count1,
2257 gfc_index_one_node);
2258 gfc_add_modify (&block, count1, tmp);
2262 /* Increment count1. */
2263 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2264 count1, gfc_index_one_node);
2265 gfc_add_modify (&body1, count1, tmp);
2267 /* Increment count3. */
2270 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2271 count3, gfc_index_one_node);
2272 gfc_add_modify (&body1, count3, tmp);
2275 /* Generate the copying loops. */
2276 gfc_trans_scalarizing_loops (&loop, &body1);
2278 gfc_add_block_to_block (&block, &loop.pre);
2279 gfc_add_block_to_block (&block, &loop.post);
2281 gfc_cleanup_loop (&loop);
2282 /* TODO: Reuse lss and rss when copying temp->lhs. Need to be careful
2283 as tree nodes in SS may not be valid in different scope. */
2286 tmp = gfc_finish_block (&block);
2291 /* Calculate the size of temporary needed in the assignment inside forall.
2292 LSS and RSS are filled in this function. */
2295 compute_inner_temp_size (gfc_expr *expr1, gfc_expr *expr2,
2296 stmtblock_t * pblock,
2297 gfc_ss **lss, gfc_ss **rss)
2305 *lss = gfc_walk_expr (expr1);
2308 size = gfc_index_one_node;
2309 if (*lss != gfc_ss_terminator)
2311 gfc_init_loopinfo (&loop);
2313 /* Walk the RHS of the expression. */
2314 *rss = gfc_walk_expr (expr2);
2315 if (*rss == gfc_ss_terminator)
2317 /* The rhs is scalar. Add a ss for the expression. */
2318 *rss = gfc_get_ss ();
2319 (*rss)->next = gfc_ss_terminator;
2320 (*rss)->type = GFC_SS_SCALAR;
2321 (*rss)->expr = expr2;
2324 /* Associate the SS with the loop. */
2325 gfc_add_ss_to_loop (&loop, *lss);
2326 /* We don't actually need to add the rhs at this point, but it might
2327 make guessing the loop bounds a bit easier. */
2328 gfc_add_ss_to_loop (&loop, *rss);
2330 /* We only want the shape of the expression, not rest of the junk
2331 generated by the scalarizer. */
2332 loop.array_parameter = 1;
2334 /* Calculate the bounds of the scalarization. */
2335 save_flag = gfc_option.rtcheck;
2336 gfc_option.rtcheck &= !GFC_RTCHECK_BOUNDS;
2337 gfc_conv_ss_startstride (&loop);
2338 gfc_option.rtcheck = save_flag;
2339 gfc_conv_loop_setup (&loop, &expr2->where);
2341 /* Figure out how many elements we need. */
2342 for (i = 0; i < loop.dimen; i++)
2344 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
2345 gfc_index_one_node, loop.from[i]);
2346 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2348 size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
2350 gfc_add_block_to_block (pblock, &loop.pre);
2351 size = gfc_evaluate_now (size, pblock);
2352 gfc_add_block_to_block (pblock, &loop.post);
2354 /* TODO: write a function that cleans up a loopinfo without freeing
2355 the SS chains. Currently a NOP. */
2362 /* Calculate the overall iterator number of the nested forall construct.
2363 This routine actually calculates the number of times the body of the
2364 nested forall specified by NESTED_FORALL_INFO is executed and multiplies
2365 that by the expression INNER_SIZE. The BLOCK argument specifies the
2366 block in which to calculate the result, and the optional INNER_SIZE_BODY
2367 argument contains any statements that need to executed (inside the loop)
2368 to initialize or calculate INNER_SIZE. */
2371 compute_overall_iter_number (forall_info *nested_forall_info, tree inner_size,
2372 stmtblock_t *inner_size_body, stmtblock_t *block)
2374 forall_info *forall_tmp = nested_forall_info;
2378 /* We can eliminate the innermost unconditional loops with constant
2380 if (INTEGER_CST_P (inner_size))
2383 && !forall_tmp->mask
2384 && INTEGER_CST_P (forall_tmp->size))
2386 inner_size = fold_build2 (MULT_EXPR, gfc_array_index_type,
2387 inner_size, forall_tmp->size);
2388 forall_tmp = forall_tmp->prev_nest;
2391 /* If there are no loops left, we have our constant result. */
2396 /* Otherwise, create a temporary variable to compute the result. */
2397 number = gfc_create_var (gfc_array_index_type, "num");
2398 gfc_add_modify (block, number, gfc_index_zero_node);
2400 gfc_start_block (&body);
2401 if (inner_size_body)
2402 gfc_add_block_to_block (&body, inner_size_body);
2404 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2405 number, inner_size);
2408 gfc_add_modify (&body, number, tmp);
2409 tmp = gfc_finish_block (&body);
2411 /* Generate loops. */
2412 if (forall_tmp != NULL)
2413 tmp = gfc_trans_nested_forall_loop (forall_tmp, tmp, 1);
2415 gfc_add_expr_to_block (block, tmp);
2421 /* Allocate temporary for forall construct. SIZE is the size of temporary
2422 needed. PTEMP1 is returned for space free. */
2425 allocate_temp_for_forall_nest_1 (tree type, tree size, stmtblock_t * block,
2432 unit = fold_convert (gfc_array_index_type, TYPE_SIZE_UNIT (type));
2433 if (!integer_onep (unit))
2434 bytesize = fold_build2 (MULT_EXPR, gfc_array_index_type, size, unit);
2439 tmp = gfc_do_allocate (bytesize, size, ptemp1, block, type);
2442 tmp = build_fold_indirect_ref (tmp);
2447 /* Allocate temporary for forall construct according to the information in
2448 nested_forall_info. INNER_SIZE is the size of temporary needed in the
2449 assignment inside forall. PTEMP1 is returned for space free. */
2452 allocate_temp_for_forall_nest (forall_info * nested_forall_info, tree type,
2453 tree inner_size, stmtblock_t * inner_size_body,
2454 stmtblock_t * block, tree * ptemp1)
2458 /* Calculate the total size of temporary needed in forall construct. */
2459 size = compute_overall_iter_number (nested_forall_info, inner_size,
2460 inner_size_body, block);
2462 return allocate_temp_for_forall_nest_1 (type, size, block, ptemp1);
2466 /* Handle assignments inside forall which need temporary.
2468 forall (i=start:end:stride; maskexpr)
2471 (where e,f<i> are arbitrary expressions possibly involving i
2472 and there is a dependency between e<i> and f<i>)
2474 masktmp(:) = maskexpr(:)
2479 for (i = start; i <= end; i += stride)
2483 for (i = start; i <= end; i += stride)
2485 if (masktmp[maskindex++])
2486 tmp[count1++] = f<i>
2490 for (i = start; i <= end; i += stride)
2492 if (masktmp[maskindex++])
2493 e<i> = tmp[count1++]
2498 gfc_trans_assign_need_temp (gfc_expr * expr1, gfc_expr * expr2,
2499 tree wheremask, bool invert,
2500 forall_info * nested_forall_info,
2501 stmtblock_t * block)
2509 stmtblock_t inner_size_body;
2511 /* Create vars. count1 is the current iterator number of the nested
2513 count1 = gfc_create_var (gfc_array_index_type, "count1");
2515 /* Count is the wheremask index. */
2518 count = gfc_create_var (gfc_array_index_type, "count");
2519 gfc_add_modify (block, count, gfc_index_zero_node);
2524 /* Initialize count1. */
2525 gfc_add_modify (block, count1, gfc_index_zero_node);
2527 /* Calculate the size of temporary needed in the assignment. Return loop, lss
2528 and rss which are used in function generate_loop_for_rhs_to_temp(). */
2529 gfc_init_block (&inner_size_body);
2530 inner_size = compute_inner_temp_size (expr1, expr2, &inner_size_body,
2533 /* The type of LHS. Used in function allocate_temp_for_forall_nest */
2534 if (expr1->ts.type == BT_CHARACTER && expr1->ts.cl->length)
2536 if (!expr1->ts.cl->backend_decl)
2539 gfc_init_se (&tse, NULL);
2540 gfc_conv_expr (&tse, expr1->ts.cl->length);
2541 expr1->ts.cl->backend_decl = tse.expr;
2543 type = gfc_get_character_type_len (gfc_default_character_kind,
2544 expr1->ts.cl->backend_decl);
2547 type = gfc_typenode_for_spec (&expr1->ts);
2549 /* Allocate temporary for nested forall construct according to the
2550 information in nested_forall_info and inner_size. */
2551 tmp1 = allocate_temp_for_forall_nest (nested_forall_info, type, inner_size,
2552 &inner_size_body, block, &ptemp1);
2554 /* Generate codes to copy rhs to the temporary . */
2555 tmp = generate_loop_for_rhs_to_temp (expr2, tmp1, count, count1, lss, rss,
2558 /* Generate body and loops according to the information in
2559 nested_forall_info. */
2560 tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1);
2561 gfc_add_expr_to_block (block, tmp);
2564 gfc_add_modify (block, count1, gfc_index_zero_node);
2568 gfc_add_modify (block, count, gfc_index_zero_node);
2570 /* Generate codes to copy the temporary to lhs. */
2571 tmp = generate_loop_for_temp_to_lhs (expr1, tmp1, count, count1,
2574 /* Generate body and loops according to the information in
2575 nested_forall_info. */
2576 tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1);
2577 gfc_add_expr_to_block (block, tmp);
2581 /* Free the temporary. */
2582 tmp = gfc_call_free (ptemp1);
2583 gfc_add_expr_to_block (block, tmp);
2588 /* Translate pointer assignment inside FORALL which need temporary. */
2591 gfc_trans_pointer_assign_need_temp (gfc_expr * expr1, gfc_expr * expr2,
2592 forall_info * nested_forall_info,
2593 stmtblock_t * block)
2607 tree tmp, tmp1, ptemp1;
2609 count = gfc_create_var (gfc_array_index_type, "count");
2610 gfc_add_modify (block, count, gfc_index_zero_node);
2612 inner_size = integer_one_node;
2613 lss = gfc_walk_expr (expr1);
2614 rss = gfc_walk_expr (expr2);
2615 if (lss == gfc_ss_terminator)
2617 type = gfc_typenode_for_spec (&expr1->ts);
2618 type = build_pointer_type (type);
2620 /* Allocate temporary for nested forall construct according to the
2621 information in nested_forall_info and inner_size. */
2622 tmp1 = allocate_temp_for_forall_nest (nested_forall_info, type,
2623 inner_size, NULL, block, &ptemp1);
2624 gfc_start_block (&body);
2625 gfc_init_se (&lse, NULL);
2626 lse.expr = gfc_build_array_ref (tmp1, count, NULL);
2627 gfc_init_se (&rse, NULL);
2628 rse.want_pointer = 1;
2629 gfc_conv_expr (&rse, expr2);
2630 gfc_add_block_to_block (&body, &rse.pre);
2631 gfc_add_modify (&body, lse.expr,
2632 fold_convert (TREE_TYPE (lse.expr), rse.expr));
2633 gfc_add_block_to_block (&body, &rse.post);
2635 /* Increment count. */
2636 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2637 count, gfc_index_one_node);
2638 gfc_add_modify (&body, count, tmp);
2640 tmp = gfc_finish_block (&body);
2642 /* Generate body and loops according to the information in
2643 nested_forall_info. */
2644 tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1);
2645 gfc_add_expr_to_block (block, tmp);
2648 gfc_add_modify (block, count, gfc_index_zero_node);
2650 gfc_start_block (&body);
2651 gfc_init_se (&lse, NULL);
2652 gfc_init_se (&rse, NULL);
2653 rse.expr = gfc_build_array_ref (tmp1, count, NULL);
2654 lse.want_pointer = 1;
2655 gfc_conv_expr (&lse, expr1);
2656 gfc_add_block_to_block (&body, &lse.pre);
2657 gfc_add_modify (&body, lse.expr, rse.expr);
2658 gfc_add_block_to_block (&body, &lse.post);
2659 /* Increment count. */
2660 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2661 count, gfc_index_one_node);
2662 gfc_add_modify (&body, count, tmp);
2663 tmp = gfc_finish_block (&body);
2665 /* Generate body and loops according to the information in
2666 nested_forall_info. */
2667 tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1);
2668 gfc_add_expr_to_block (block, tmp);
2672 gfc_init_loopinfo (&loop);
2674 /* Associate the SS with the loop. */
2675 gfc_add_ss_to_loop (&loop, rss);
2677 /* Setup the scalarizing loops and bounds. */
2678 gfc_conv_ss_startstride (&loop);
2680 gfc_conv_loop_setup (&loop, &expr2->where);
2682 info = &rss->data.info;
2683 desc = info->descriptor;
2685 /* Make a new descriptor. */
2686 parmtype = gfc_get_element_type (TREE_TYPE (desc));
2687 parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen,
2688 loop.from, loop.to, 1,
2691 /* Allocate temporary for nested forall construct. */
2692 tmp1 = allocate_temp_for_forall_nest (nested_forall_info, parmtype,
2693 inner_size, NULL, block, &ptemp1);
2694 gfc_start_block (&body);
2695 gfc_init_se (&lse, NULL);
2696 lse.expr = gfc_build_array_ref (tmp1, count, NULL);
2697 lse.direct_byref = 1;
2698 rss = gfc_walk_expr (expr2);
2699 gfc_conv_expr_descriptor (&lse, expr2, rss);
2701 gfc_add_block_to_block (&body, &lse.pre);
2702 gfc_add_block_to_block (&body, &lse.post);
2704 /* Increment count. */
2705 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2706 count, gfc_index_one_node);
2707 gfc_add_modify (&body, count, tmp);
2709 tmp = gfc_finish_block (&body);
2711 /* Generate body and loops according to the information in
2712 nested_forall_info. */
2713 tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1);
2714 gfc_add_expr_to_block (block, tmp);
2717 gfc_add_modify (block, count, gfc_index_zero_node);
2719 parm = gfc_build_array_ref (tmp1, count, NULL);
2720 lss = gfc_walk_expr (expr1);
2721 gfc_init_se (&lse, NULL);
2722 gfc_conv_expr_descriptor (&lse, expr1, lss);
2723 gfc_add_modify (&lse.pre, lse.expr, parm);
2724 gfc_start_block (&body);
2725 gfc_add_block_to_block (&body, &lse.pre);
2726 gfc_add_block_to_block (&body, &lse.post);
2728 /* Increment count. */
2729 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2730 count, gfc_index_one_node);
2731 gfc_add_modify (&body, count, tmp);
2733 tmp = gfc_finish_block (&body);
2735 tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1);
2736 gfc_add_expr_to_block (block, tmp);
2738 /* Free the temporary. */
2741 tmp = gfc_call_free (ptemp1);
2742 gfc_add_expr_to_block (block, tmp);
2747 /* FORALL and WHERE statements are really nasty, especially when you nest
2748 them. All the rhs of a forall assignment must be evaluated before the
2749 actual assignments are performed. Presumably this also applies to all the
2750 assignments in an inner where statement. */
2752 /* Generate code for a FORALL statement. Any temporaries are allocated as a
2753 linear array, relying on the fact that we process in the same order in all
2756 forall (i=start:end:stride; maskexpr)
2760 (where e,f,g,h<i> are arbitrary expressions possibly involving i)
2762 count = ((end + 1 - start) / stride)
2763 masktmp(:) = maskexpr(:)
2766 for (i = start; i <= end; i += stride)
2768 if (masktmp[maskindex++])
2772 for (i = start; i <= end; i += stride)
2774 if (masktmp[maskindex++])
2778 Note that this code only works when there are no dependencies.
2779 Forall loop with array assignments and data dependencies are a real pain,
2780 because the size of the temporary cannot always be determined before the
2781 loop is executed. This problem is compounded by the presence of nested
2786 gfc_trans_forall_1 (gfc_code * code, forall_info * nested_forall_info)
2806 gfc_forall_iterator *fa;
2809 gfc_saved_var *saved_vars;
2810 iter_info *this_forall;
2814 /* Do nothing if the mask is false. */
2816 && code->expr1->expr_type == EXPR_CONSTANT
2817 && !code->expr1->value.logical)
2818 return build_empty_stmt ();
2821 /* Count the FORALL index number. */
2822 for (fa = code->ext.forall_iterator; fa; fa = fa->next)
2826 /* Allocate the space for var, start, end, step, varexpr. */
2827 var = (tree *) gfc_getmem (nvar * sizeof (tree));
2828 start = (tree *) gfc_getmem (nvar * sizeof (tree));
2829 end = (tree *) gfc_getmem (nvar * sizeof (tree));
2830 step = (tree *) gfc_getmem (nvar * sizeof (tree));
2831 varexpr = (gfc_expr **) gfc_getmem (nvar * sizeof (gfc_expr *));
2832 saved_vars = (gfc_saved_var *) gfc_getmem (nvar * sizeof (gfc_saved_var));
2834 /* Allocate the space for info. */
2835 info = (forall_info *) gfc_getmem (sizeof (forall_info));
2837 gfc_start_block (&pre);
2838 gfc_init_block (&post);
2839 gfc_init_block (&block);
2842 for (fa = code->ext.forall_iterator; fa; fa = fa->next)
2844 gfc_symbol *sym = fa->var->symtree->n.sym;
2846 /* Allocate space for this_forall. */
2847 this_forall = (iter_info *) gfc_getmem (sizeof (iter_info));
2849 /* Create a temporary variable for the FORALL index. */
2850 tmp = gfc_typenode_for_spec (&sym->ts);
2851 var[n] = gfc_create_var (tmp, sym->name);
2852 gfc_shadow_sym (sym, var[n], &saved_vars[n]);
2854 /* Record it in this_forall. */
2855 this_forall->var = var[n];
2857 /* Replace the index symbol's backend_decl with the temporary decl. */
2858 sym->backend_decl = var[n];
2860 /* Work out the start, end and stride for the loop. */
2861 gfc_init_se (&se, NULL);
2862 gfc_conv_expr_val (&se, fa->start);
2863 /* Record it in this_forall. */
2864 this_forall->start = se.expr;
2865 gfc_add_block_to_block (&block, &se.pre);
2868 gfc_init_se (&se, NULL);
2869 gfc_conv_expr_val (&se, fa->end);
2870 /* Record it in this_forall. */
2871 this_forall->end = se.expr;
2872 gfc_make_safe_expr (&se);
2873 gfc_add_block_to_block (&block, &se.pre);
2876 gfc_init_se (&se, NULL);
2877 gfc_conv_expr_val (&se, fa->stride);
2878 /* Record it in this_forall. */
2879 this_forall->step = se.expr;
2880 gfc_make_safe_expr (&se);
2881 gfc_add_block_to_block (&block, &se.pre);
2884 /* Set the NEXT field of this_forall to NULL. */
2885 this_forall->next = NULL;
2886 /* Link this_forall to the info construct. */
2887 if (info->this_loop)
2889 iter_info *iter_tmp = info->this_loop;
2890 while (iter_tmp->next != NULL)
2891 iter_tmp = iter_tmp->next;
2892 iter_tmp->next = this_forall;
2895 info->this_loop = this_forall;
2901 /* Calculate the size needed for the current forall level. */
2902 size = gfc_index_one_node;
2903 for (n = 0; n < nvar; n++)
2905 /* size = (end + step - start) / step. */
2906 tmp = fold_build2 (MINUS_EXPR, TREE_TYPE (start[n]),
2908 tmp = fold_build2 (PLUS_EXPR, TREE_TYPE (end[n]), end[n], tmp);
2910 tmp = fold_build2 (FLOOR_DIV_EXPR, TREE_TYPE (tmp), tmp, step[n]);
2911 tmp = convert (gfc_array_index_type, tmp);
2913 size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
2916 /* Record the nvar and size of current forall level. */
2922 /* If the mask is .true., consider the FORALL unconditional. */
2923 if (code->expr1->expr_type == EXPR_CONSTANT
2924 && code->expr1->value.logical)
2932 /* First we need to allocate the mask. */
2935 /* As the mask array can be very big, prefer compact boolean types. */
2936 tree mask_type = gfc_get_logical_type (gfc_logical_kinds[0].kind);
2937 mask = allocate_temp_for_forall_nest (nested_forall_info, mask_type,
2938 size, NULL, &block, &pmask);
2939 maskindex = gfc_create_var_np (gfc_array_index_type, "mi");
2941 /* Record them in the info structure. */
2942 info->maskindex = maskindex;
2947 /* No mask was specified. */
2948 maskindex = NULL_TREE;
2949 mask = pmask = NULL_TREE;
2952 /* Link the current forall level to nested_forall_info. */
2953 info->prev_nest = nested_forall_info;
2954 nested_forall_info = info;
2956 /* Copy the mask into a temporary variable if required.
2957 For now we assume a mask temporary is needed. */
2960 /* As the mask array can be very big, prefer compact boolean types. */
2961 tree mask_type = gfc_get_logical_type (gfc_logical_kinds[0].kind);
2963 gfc_add_modify (&block, maskindex, gfc_index_zero_node);
2965 /* Start of mask assignment loop body. */
2966 gfc_start_block (&body);
2968 /* Evaluate the mask expression. */
2969 gfc_init_se (&se, NULL);
2970 gfc_conv_expr_val (&se, code->expr1);
2971 gfc_add_block_to_block (&body, &se.pre);
2973 /* Store the mask. */
2974 se.expr = convert (mask_type, se.expr);
2976 tmp = gfc_build_array_ref (mask, maskindex, NULL);
2977 gfc_add_modify (&body, tmp, se.expr);
2979 /* Advance to the next mask element. */
2980 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2981 maskindex, gfc_index_one_node);
2982 gfc_add_modify (&body, maskindex, tmp);
2984 /* Generate the loops. */
2985 tmp = gfc_finish_block (&body);
2986 tmp = gfc_trans_nested_forall_loop (info, tmp, 0);
2987 gfc_add_expr_to_block (&block, tmp);
2990 c = code->block->next;
2992 /* TODO: loop merging in FORALL statements. */
2993 /* Now that we've got a copy of the mask, generate the assignment loops. */
2999 /* A scalar or array assignment. DO the simple check for
3000 lhs to rhs dependencies. These make a temporary for the
3001 rhs and form a second forall block to copy to variable. */
3002 need_temp = check_forall_dependencies(c, &pre, &post);
3004 /* Temporaries due to array assignment data dependencies introduce
3005 no end of problems. */
3007 gfc_trans_assign_need_temp (c->expr1, c->expr2, NULL, false,
3008 nested_forall_info, &block);
3011 /* Use the normal assignment copying routines. */
3012 assign = gfc_trans_assignment (c->expr1, c->expr2, false);
3014 /* Generate body and loops. */
3015 tmp = gfc_trans_nested_forall_loop (nested_forall_info,
3017 gfc_add_expr_to_block (&block, tmp);
3020 /* Cleanup any temporary symtrees that have been made to deal
3021 with dependencies. */
3023 cleanup_forall_symtrees (c);
3028 /* Translate WHERE or WHERE construct nested in FORALL. */
3029 gfc_trans_where_2 (c, NULL, false, nested_forall_info, &block);
3032 /* Pointer assignment inside FORALL. */
3033 case EXEC_POINTER_ASSIGN:
3034 need_temp = gfc_check_dependency (c->expr1, c->expr2, 0);
3036 gfc_trans_pointer_assign_need_temp (c->expr1, c->expr2,
3037 nested_forall_info, &block);
3040 /* Use the normal assignment copying routines. */
3041 assign = gfc_trans_pointer_assignment (c->expr1, c->expr2);
3043 /* Generate body and loops. */
3044 tmp = gfc_trans_nested_forall_loop (nested_forall_info,
3046 gfc_add_expr_to_block (&block, tmp);
3051 tmp = gfc_trans_forall_1 (c, nested_forall_info);
3052 gfc_add_expr_to_block (&block, tmp);
3055 /* Explicit subroutine calls are prevented by the frontend but interface
3056 assignments can legitimately produce them. */
3057 case EXEC_ASSIGN_CALL:
3058 assign = gfc_trans_call (c, true, NULL_TREE, NULL_TREE, false);
3059 tmp = gfc_trans_nested_forall_loop (nested_forall_info, assign, 1);
3060 gfc_add_expr_to_block (&block, tmp);
3070 /* Restore the original index variables. */
3071 for (fa = code->ext.forall_iterator, n = 0; fa; fa = fa->next, n++)
3072 gfc_restore_sym (fa->var->symtree->n.sym, &saved_vars[n]);
3074 /* Free the space for var, start, end, step, varexpr. */
3080 gfc_free (saved_vars);
3082 /* Free the space for this forall_info. */
3087 /* Free the temporary for the mask. */
3088 tmp = gfc_call_free (pmask);
3089 gfc_add_expr_to_block (&block, tmp);
3092 pushdecl (maskindex);
3094 gfc_add_block_to_block (&pre, &block);
3095 gfc_add_block_to_block (&pre, &post);
3097 return gfc_finish_block (&pre);
3101 /* Translate the FORALL statement or construct. */
3103 tree gfc_trans_forall (gfc_code * code)
3105 return gfc_trans_forall_1 (code, NULL);
3109 /* Evaluate the WHERE mask expression, copy its value to a temporary.
3110 If the WHERE construct is nested in FORALL, compute the overall temporary
3111 needed by the WHERE mask expression multiplied by the iterator number of
3113 ME is the WHERE mask expression.
3114 MASK is the current execution mask upon input, whose sense may or may
3115 not be inverted as specified by the INVERT argument.
3116 CMASK is the updated execution mask on output, or NULL if not required.
3117 PMASK is the pending execution mask on output, or NULL if not required.
3118 BLOCK is the block in which to place the condition evaluation loops. */
3121 gfc_evaluate_where_mask (gfc_expr * me, forall_info * nested_forall_info,
3122 tree mask, bool invert, tree cmask, tree pmask,
3123 tree mask_type, stmtblock_t * block)
3128 stmtblock_t body, body1;
3129 tree count, cond, mtmp;
3132 gfc_init_loopinfo (&loop);
3134 lss = gfc_walk_expr (me);
3135 rss = gfc_walk_expr (me);
3137 /* Variable to index the temporary. */
3138 count = gfc_create_var (gfc_array_index_type, "count");
3139 /* Initialize count. */
3140 gfc_add_modify (block, count, gfc_index_zero_node);
3142 gfc_start_block (&body);
3144 gfc_init_se (&rse, NULL);
3145 gfc_init_se (&lse, NULL);
3147 if (lss == gfc_ss_terminator)
3149 gfc_init_block (&body1);
3153 /* Initialize the loop. */
3154 gfc_init_loopinfo (&loop);
3156 /* We may need LSS to determine the shape of the expression. */
3157 gfc_add_ss_to_loop (&loop, lss);
3158 gfc_add_ss_to_loop (&loop, rss);
3160 gfc_conv_ss_startstride (&loop);
3161 gfc_conv_loop_setup (&loop, &me->where);
3163 gfc_mark_ss_chain_used (rss, 1);
3164 /* Start the loop body. */
3165 gfc_start_scalarized_body (&loop, &body1);
3167 /* Translate the expression. */
3168 gfc_copy_loopinfo_to_se (&rse, &loop);
3170 gfc_conv_expr (&rse, me);
3173 /* Variable to evaluate mask condition. */
3174 cond = gfc_create_var (mask_type, "cond");
3175 if (mask && (cmask || pmask))
3176 mtmp = gfc_create_var (mask_type, "mask");
3177 else mtmp = NULL_TREE;
3179 gfc_add_block_to_block (&body1, &lse.pre);
3180 gfc_add_block_to_block (&body1, &rse.pre);
3182 gfc_add_modify (&body1, cond, fold_convert (mask_type, rse.expr));
3184 if (mask && (cmask || pmask))
3186 tmp = gfc_build_array_ref (mask, count, NULL);
3188 tmp = fold_build1 (TRUTH_NOT_EXPR, mask_type, tmp);
3189 gfc_add_modify (&body1, mtmp, tmp);
3194 tmp1 = gfc_build_array_ref (cmask, count, NULL);
3197 tmp = fold_build2 (TRUTH_AND_EXPR, mask_type, mtmp, tmp);
3198 gfc_add_modify (&body1, tmp1, tmp);
3203 tmp1 = gfc_build_array_ref (pmask, count, NULL);
3204 tmp = fold_build1 (TRUTH_NOT_EXPR, mask_type, cond);
3206 tmp = fold_build2 (TRUTH_AND_EXPR, mask_type, mtmp, tmp);
3207 gfc_add_modify (&body1, tmp1, tmp);
3210 gfc_add_block_to_block (&body1, &lse.post);
3211 gfc_add_block_to_block (&body1, &rse.post);
3213 if (lss == gfc_ss_terminator)
3215 gfc_add_block_to_block (&body, &body1);
3219 /* Increment count. */
3220 tmp1 = fold_build2 (PLUS_EXPR, gfc_array_index_type, count,
3221 gfc_index_one_node);
3222 gfc_add_modify (&body1, count, tmp1);
3224 /* Generate the copying loops. */
3225 gfc_trans_scalarizing_loops (&loop, &body1);
3227 gfc_add_block_to_block (&body, &loop.pre);
3228 gfc_add_block_to_block (&body, &loop.post);
3230 gfc_cleanup_loop (&loop);
3231 /* TODO: Reuse lss and rss when copying temp->lhs. Need to be careful
3232 as tree nodes in SS may not be valid in different scope. */
3235 tmp1 = gfc_finish_block (&body);
3236 /* If the WHERE construct is inside FORALL, fill the full temporary. */
3237 if (nested_forall_info != NULL)
3238 tmp1 = gfc_trans_nested_forall_loop (nested_forall_info, tmp1, 1);
3240 gfc_add_expr_to_block (block, tmp1);
3244 /* Translate an assignment statement in a WHERE statement or construct
3245 statement. The MASK expression is used to control which elements
3246 of EXPR1 shall be assigned. The sense of MASK is specified by
3250 gfc_trans_where_assign (gfc_expr *expr1, gfc_expr *expr2,
3251 tree mask, bool invert,
3252 tree count1, tree count2,
3258 gfc_ss *lss_section;
3265 tree index, maskexpr;
3267 /* A defined assignment. */
3268 if (cnext && cnext->resolved_sym)
3269 return gfc_trans_call (cnext, true, mask, count1, invert);
3272 /* TODO: handle this special case.
3273 Special case a single function returning an array. */
3274 if (expr2->expr_type == EXPR_FUNCTION && expr2->rank > 0)
3276 tmp = gfc_trans_arrayfunc_assign (expr1, expr2);
3282 /* Assignment of the form lhs = rhs. */
3283 gfc_start_block (&block);
3285 gfc_init_se (&lse, NULL);
3286 gfc_init_se (&rse, NULL);
3289 lss = gfc_walk_expr (expr1);
3292 /* In each where-assign-stmt, the mask-expr and the variable being
3293 defined shall be arrays of the same shape. */
3294 gcc_assert (lss != gfc_ss_terminator);
3296 /* The assignment needs scalarization. */
3299 /* Find a non-scalar SS from the lhs. */
3300 while (lss_section != gfc_ss_terminator
3301 && lss_section->type != GFC_SS_SECTION)
3302 lss_section = lss_section->next;
3304 gcc_assert (lss_section != gfc_ss_terminator);
3306 /* Initialize the scalarizer. */
3307 gfc_init_loopinfo (&loop);
3310 rss = gfc_walk_expr (expr2);
3311 if (rss == gfc_ss_terminator)
3313 /* The rhs is scalar. Add a ss for the expression. */
3314 rss = gfc_get_ss ();
3316 rss->next = gfc_ss_terminator;
3317 rss->type = GFC_SS_SCALAR;
3321 /* Associate the SS with the loop. */
3322 gfc_add_ss_to_loop (&loop, lss);
3323 gfc_add_ss_to_loop (&loop, rss);
3325 /* Calculate the bounds of the scalarization. */
3326 gfc_conv_ss_startstride (&loop);
3328 /* Resolve any data dependencies in the statement. */
3329 gfc_conv_resolve_dependencies (&loop, lss_section, rss);
3331 /* Setup the scalarizing loops. */
3332 gfc_conv_loop_setup (&loop, &expr2->where);
3334 /* Setup the gfc_se structures. */
3335 gfc_copy_loopinfo_to_se (&lse, &loop);
3336 gfc_copy_loopinfo_to_se (&rse, &loop);
3339 gfc_mark_ss_chain_used (rss, 1);
3340 if (loop.temp_ss == NULL)
3343 gfc_mark_ss_chain_used (lss, 1);
3347 lse.ss = loop.temp_ss;
3348 gfc_mark_ss_chain_used (lss, 3);
3349 gfc_mark_ss_chain_used (loop.temp_ss, 3);
3352 /* Start the scalarized loop body. */
3353 gfc_start_scalarized_body (&loop, &body);
3355 /* Translate the expression. */
3356 gfc_conv_expr (&rse, expr2);
3357 if (lss != gfc_ss_terminator && loop.temp_ss != NULL)
3359 gfc_conv_tmp_array_ref (&lse);
3360 gfc_advance_se_ss_chain (&lse);
3363 gfc_conv_expr (&lse, expr1);
3365 /* Form the mask expression according to the mask. */
3367 maskexpr = gfc_build_array_ref (mask, index, NULL);
3369 maskexpr = fold_build1 (TRUTH_NOT_EXPR, TREE_TYPE (maskexpr), maskexpr);
3371 /* Use the scalar assignment as is. */
3372 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts,
3373 loop.temp_ss != NULL, false);
3375 tmp = build3_v (COND_EXPR, maskexpr, tmp, build_empty_stmt ());
3377 gfc_add_expr_to_block (&body, tmp);
3379 if (lss == gfc_ss_terminator)
3381 /* Increment count1. */
3382 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
3383 count1, gfc_index_one_node);
3384 gfc_add_modify (&body, count1, tmp);
3386 /* Use the scalar assignment as is. */
3387 gfc_add_block_to_block (&block, &body);
3391 gcc_assert (lse.ss == gfc_ss_terminator
3392 && rse.ss == gfc_ss_terminator);
3394 if (loop.temp_ss != NULL)
3396 /* Increment count1 before finish the main body of a scalarized
3398 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
3399 count1, gfc_index_one_node);
3400 gfc_add_modify (&body, count1, tmp);
3401 gfc_trans_scalarized_loop_boundary (&loop, &body);
3403 /* We need to copy the temporary to the actual lhs. */
3404 gfc_init_se (&lse, NULL);
3405 gfc_init_se (&rse, NULL);
3406 gfc_copy_loopinfo_to_se (&lse, &loop);
3407 gfc_copy_loopinfo_to_se (&rse, &loop);
3409 rse.ss = loop.temp_ss;
3412 gfc_conv_tmp_array_ref (&rse);
3413 gfc_advance_se_ss_chain (&rse);
3414 gfc_conv_expr (&lse, expr1);
3416 gcc_assert (lse.ss == gfc_ss_terminator
3417 && rse.ss == gfc_ss_terminator);
3419 /* Form the mask expression according to the mask tree list. */
3421 maskexpr = gfc_build_array_ref (mask, index, NULL);
3423 maskexpr = fold_build1 (TRUTH_NOT_EXPR, TREE_TYPE (maskexpr),
3426 /* Use the scalar assignment as is. */
3427 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts, false, false);
3428 tmp = build3_v (COND_EXPR, maskexpr, tmp, build_empty_stmt ());
3429 gfc_add_expr_to_block (&body, tmp);
3431 /* Increment count2. */
3432 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
3433 count2, gfc_index_one_node);
3434 gfc_add_modify (&body, count2, tmp);
3438 /* Increment count1. */
3439 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
3440 count1, gfc_index_one_node);
3441 gfc_add_modify (&body, count1, tmp);
3444 /* Generate the copying loops. */
3445 gfc_trans_scalarizing_loops (&loop, &body);
3447 /* Wrap the whole thing up. */
3448 gfc_add_block_to_block (&block, &loop.pre);
3449 gfc_add_block_to_block (&block, &loop.post);
3450 gfc_cleanup_loop (&loop);
3453 return gfc_finish_block (&block);
3457 /* Translate the WHERE construct or statement.
3458 This function can be called iteratively to translate the nested WHERE
3459 construct or statement.
3460 MASK is the control mask. */
3463 gfc_trans_where_2 (gfc_code * code, tree mask, bool invert,
3464 forall_info * nested_forall_info, stmtblock_t * block)
3466 stmtblock_t inner_size_body;
3467 tree inner_size, size;
3476 tree count1, count2;
3480 tree pcmask = NULL_TREE;
3481 tree ppmask = NULL_TREE;
3482 tree cmask = NULL_TREE;
3483 tree pmask = NULL_TREE;
3484 gfc_actual_arglist *arg;
3486 /* the WHERE statement or the WHERE construct statement. */
3487 cblock = code->block;
3489 /* As the mask array can be very big, prefer compact boolean types. */
3490 mask_type = gfc_get_logical_type (gfc_logical_kinds[0].kind);
3492 /* Determine which temporary masks are needed. */
3495 /* One clause: No ELSEWHEREs. */
3496 need_cmask = (cblock->next != 0);
3499 else if (cblock->block->block)
3501 /* Three or more clauses: Conditional ELSEWHEREs. */
3505 else if (cblock->next)
3507 /* Two clauses, the first non-empty. */
3509 need_pmask = (mask != NULL_TREE
3510 && cblock->block->next != 0);
3512 else if (!cblock->block->next)
3514 /* Two clauses, both empty. */
3518 /* Two clauses, the first empty, the second non-empty. */
3521 need_cmask = (cblock->block->expr1 != 0);
3530 if (need_cmask || need_pmask)
3532 /* Calculate the size of temporary needed by the mask-expr. */
3533 gfc_init_block (&inner_size_body);
3534 inner_size = compute_inner_temp_size (cblock->expr1, cblock->expr1,
3535 &inner_size_body, &lss, &rss);
3537 /* Calculate the total size of temporary needed. */
3538 size = compute_overall_iter_number (nested_forall_info, inner_size,
3539 &inner_size_body, block);
3541 /* Check whether the size is negative. */
3542 cond = fold_build2 (LE_EXPR, boolean_type_node, size,
3543 gfc_index_zero_node);
3544 size = fold_build3 (COND_EXPR, gfc_array_index_type, cond,
3545 gfc_index_zero_node, size);
3546 size = gfc_evaluate_now (size, block);
3548 /* Allocate temporary for WHERE mask if needed. */
3550 cmask = allocate_temp_for_forall_nest_1 (mask_type, size, block,
3553 /* Allocate temporary for !mask if needed. */
3555 pmask = allocate_temp_for_forall_nest_1 (mask_type, size, block,
3561 /* Each time around this loop, the where clause is conditional
3562 on the value of mask and invert, which are updated at the
3563 bottom of the loop. */
3565 /* Has mask-expr. */
3568 /* Ensure that the WHERE mask will be evaluated exactly once.
3569 If there are no statements in this WHERE/ELSEWHERE clause,
3570 then we don't need to update the control mask (cmask).
3571 If this is the last clause of the WHERE construct, then
3572 we don't need to update the pending control mask (pmask). */
3574 gfc_evaluate_where_mask (cblock->expr1, nested_forall_info,
3576 cblock->next ? cmask : NULL_TREE,
3577 cblock->block ? pmask : NULL_TREE,
3580 gfc_evaluate_where_mask (cblock->expr1, nested_forall_info,
3582 (cblock->next || cblock->block)
3583 ? cmask : NULL_TREE,
3584 NULL_TREE, mask_type, block);
3588 /* It's a final elsewhere-stmt. No mask-expr is present. */
3592 /* The body of this where clause are controlled by cmask with
3593 sense specified by invert. */
3595 /* Get the assignment statement of a WHERE statement, or the first
3596 statement in where-body-construct of a WHERE construct. */
3597 cnext = cblock->next;
3602 /* WHERE assignment statement. */
3603 case EXEC_ASSIGN_CALL:
3605 arg = cnext->ext.actual;
3606 expr1 = expr2 = NULL;
3607 for (; arg; arg = arg->next)
3619 expr1 = cnext->expr1;
3620 expr2 = cnext->expr2;
3622 if (nested_forall_info != NULL)
3624 need_temp = gfc_check_dependency (expr1, expr2, 0);
3625 if (need_temp && cnext->op != EXEC_ASSIGN_CALL)
3626 gfc_trans_assign_need_temp (expr1, expr2,
3628 nested_forall_info, block);
3631 /* Variables to control maskexpr. */
3632 count1 = gfc_create_var (gfc_array_index_type, "count1");
3633 count2 = gfc_create_var (gfc_array_index_type, "count2");
3634 gfc_add_modify (block, count1, gfc_index_zero_node);
3635 gfc_add_modify (block, count2, gfc_index_zero_node);
3637 tmp = gfc_trans_where_assign (expr1, expr2,
3642 tmp = gfc_trans_nested_forall_loop (nested_forall_info,
3644 gfc_add_expr_to_block (block, tmp);
3649 /* Variables to control maskexpr. */
3650 count1 = gfc_create_var (gfc_array_index_type, "count1");
3651 count2 = gfc_create_var (gfc_array_index_type, "count2");
3652 gfc_add_modify (block, count1, gfc_index_zero_node);
3653 gfc_add_modify (block, count2, gfc_index_zero_node);
3655 tmp = gfc_trans_where_assign (expr1, expr2,
3659 gfc_add_expr_to_block (block, tmp);
3664 /* WHERE or WHERE construct is part of a where-body-construct. */
3666 gfc_trans_where_2 (cnext, cmask, invert,
3667 nested_forall_info, block);
3674 /* The next statement within the same where-body-construct. */
3675 cnext = cnext->next;
3677 /* The next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt. */
3678 cblock = cblock->block;
3679 if (mask == NULL_TREE)
3681 /* If we're the initial WHERE, we can simply invert the sense
3682 of the current mask to obtain the "mask" for the remaining
3689 /* Otherwise, for nested WHERE's we need to use the pending mask. */
3695 /* If we allocated a pending mask array, deallocate it now. */
3698 tmp = gfc_call_free (ppmask);
3699 gfc_add_expr_to_block (block, tmp);
3702 /* If we allocated a current mask array, deallocate it now. */
3705 tmp = gfc_call_free (pcmask);
3706 gfc_add_expr_to_block (block, tmp);
3710 /* Translate a simple WHERE construct or statement without dependencies.
3711 CBLOCK is the "then" clause of the WHERE statement, where CBLOCK->EXPR
3712 is the mask condition, and EBLOCK if non-NULL is the "else" clause.
3713 Currently both CBLOCK and EBLOCK are restricted to single assignments. */
3716 gfc_trans_where_3 (gfc_code * cblock, gfc_code * eblock)
3718 stmtblock_t block, body;
3719 gfc_expr *cond, *tdst, *tsrc, *edst, *esrc;
3720 tree tmp, cexpr, tstmt, estmt;
3721 gfc_ss *css, *tdss, *tsss;
3722 gfc_se cse, tdse, tsse, edse, esse;
3727 /* Allow the scalarizer to workshare simple where loops. */
3728 if (ompws_flags & OMPWS_WORKSHARE_FLAG)
3729 ompws_flags |= OMPWS_SCALARIZER_WS;
3731 cond = cblock->expr1;
3732 tdst = cblock->next->expr1;
3733 tsrc = cblock->next->expr2;
3734 edst = eblock ? eblock->next->expr1 : NULL;
3735 esrc = eblock ? eblock->next->expr2 : NULL;
3737 gfc_start_block (&block);
3738 gfc_init_loopinfo (&loop);
3740 /* Handle the condition. */
3741 gfc_init_se (&cse, NULL);
3742 css = gfc_walk_expr (cond);
3743 gfc_add_ss_to_loop (&loop, css);
3745 /* Handle the then-clause. */
3746 gfc_init_se (&tdse, NULL);
3747 gfc_init_se (&tsse, NULL);
3748 tdss = gfc_walk_expr (tdst);
3749 tsss = gfc_walk_expr (tsrc);
3750 if (tsss == gfc_ss_terminator)
3752 tsss = gfc_get_ss ();
3754 tsss->next = gfc_ss_terminator;
3755 tsss->type = GFC_SS_SCALAR;
3758 gfc_add_ss_to_loop (&loop, tdss);
3759 gfc_add_ss_to_loop (&loop, tsss);
3763 /* Handle the else clause. */
3764 gfc_init_se (&edse, NULL);
3765 gfc_init_se (&esse, NULL);
3766 edss = gfc_walk_expr (edst);
3767 esss = gfc_walk_expr (esrc);
3768 if (esss == gfc_ss_terminator)
3770 esss = gfc_get_ss ();
3772 esss->next = gfc_ss_terminator;
3773 esss->type = GFC_SS_SCALAR;
3776 gfc_add_ss_to_loop (&loop, edss);
3777 gfc_add_ss_to_loop (&loop, esss);
3780 gfc_conv_ss_startstride (&loop);
3781 gfc_conv_loop_setup (&loop, &tdst->where);
3783 gfc_mark_ss_chain_used (css, 1);
3784 gfc_mark_ss_chain_used (tdss, 1);
3785 gfc_mark_ss_chain_used (tsss, 1);
3788 gfc_mark_ss_chain_used (edss, 1);
3789 gfc_mark_ss_chain_used (esss, 1);
3792 gfc_start_scalarized_body (&loop, &body);
3794 gfc_copy_loopinfo_to_se (&cse, &loop);
3795 gfc_copy_loopinfo_to_se (&tdse, &loop);
3796 gfc_copy_loopinfo_to_se (&tsse, &loop);
3802 gfc_copy_loopinfo_to_se (&edse, &loop);
3803 gfc_copy_loopinfo_to_se (&esse, &loop);
3808 gfc_conv_expr (&cse, cond);
3809 gfc_add_block_to_block (&body, &cse.pre);
3812 gfc_conv_expr (&tsse, tsrc);
3813 if (tdss != gfc_ss_terminator && loop.temp_ss != NULL)
3815 gfc_conv_tmp_array_ref (&tdse);
3816 gfc_advance_se_ss_chain (&tdse);
3819 gfc_conv_expr (&tdse, tdst);
3823 gfc_conv_expr (&esse, esrc);
3824 if (edss != gfc_ss_terminator && loop.temp_ss != NULL)
3826 gfc_conv_tmp_array_ref (&edse);
3827 gfc_advance_se_ss_chain (&edse);
3830 gfc_conv_expr (&edse, edst);
3833 tstmt = gfc_trans_scalar_assign (&tdse, &tsse, tdst->ts, false, false);
3834 estmt = eblock ? gfc_trans_scalar_assign (&edse, &esse, edst->ts, false, false)
3835 : build_empty_stmt ();
3836 tmp = build3_v (COND_EXPR, cexpr, tstmt, estmt);
3837 gfc_add_expr_to_block (&body, tmp);
3838 gfc_add_block_to_block (&body, &cse.post);
3840 gfc_trans_scalarizing_loops (&loop, &body);
3841 gfc_add_block_to_block (&block, &loop.pre);
3842 gfc_add_block_to_block (&block, &loop.post);
3843 gfc_cleanup_loop (&loop);
3845 return gfc_finish_block (&block);
3848 /* As the WHERE or WHERE construct statement can be nested, we call
3849 gfc_trans_where_2 to do the translation, and pass the initial
3850 NULL values for both the control mask and the pending control mask. */
3853 gfc_trans_where (gfc_code * code)
3859 cblock = code->block;
3861 && cblock->next->op == EXEC_ASSIGN
3862 && !cblock->next->next)
3864 eblock = cblock->block;
3867 /* A simple "WHERE (cond) x = y" statement or block is
3868 dependence free if cond is not dependent upon writing x,
3869 and the source y is unaffected by the destination x. */
3870 if (!gfc_check_dependency (cblock->next->expr1,
3872 && !gfc_check_dependency (cblock->next->expr1,
3873 cblock->next->expr2, 0))
3874 return gfc_trans_where_3 (cblock, NULL);
3876 else if (!eblock->expr1
3879 && eblock->next->op == EXEC_ASSIGN
3880 && !eblock->next->next)
3882 /* A simple "WHERE (cond) x1 = y1 ELSEWHERE x2 = y2 ENDWHERE"
3883 block is dependence free if cond is not dependent on writes
3884 to x1 and x2, y1 is not dependent on writes to x2, and y2
3885 is not dependent on writes to x1, and both y's are not
3886 dependent upon their own x's. In addition to this, the
3887 final two dependency checks below exclude all but the same
3888 array reference if the where and elswhere destinations
3889 are the same. In short, this is VERY conservative and this
3890 is needed because the two loops, required by the standard
3891 are coalesced in gfc_trans_where_3. */
3892 if (!gfc_check_dependency(cblock->next->expr1,
3894 && !gfc_check_dependency(eblock->next->expr1,
3896 && !gfc_check_dependency(cblock->next->expr1,
3897 eblock->next->expr2, 1)
3898 && !gfc_check_dependency(eblock->next->expr1,
3899 cblock->next->expr2, 1)
3900 && !gfc_check_dependency(cblock->next->expr1,
3901 cblock->next->expr2, 1)
3902 && !gfc_check_dependency(eblock->next->expr1,
3903 eblock->next->expr2, 1)
3904 && !gfc_check_dependency(cblock->next->expr1,
3905 eblock->next->expr1, 0)
3906 && !gfc_check_dependency(eblock->next->expr1,
3907 cblock->next->expr1, 0))
3908 return gfc_trans_where_3 (cblock, eblock);
3912 gfc_start_block (&block);
3914 gfc_trans_where_2 (code, NULL, false, NULL, &block);
3916 return gfc_finish_block (&block);
3920 /* CYCLE a DO loop. The label decl has already been created by
3921 gfc_trans_do(), it's in TREE_PURPOSE (backend_decl) of the gfc_code
3922 node at the head of the loop. We must mark the label as used. */
3925 gfc_trans_cycle (gfc_code * code)
3929 cycle_label = TREE_PURPOSE (code->ext.whichloop->backend_decl);
3930 TREE_USED (cycle_label) = 1;
3931 return build1_v (GOTO_EXPR, cycle_label);
3935 /* EXIT a DO loop. Similar to CYCLE, but now the label is in
3936 TREE_VALUE (backend_decl) of the gfc_code node at the head of the
3940 gfc_trans_exit (gfc_code * code)
3944 exit_label = TREE_VALUE (code->ext.whichloop->backend_decl);
3945 TREE_USED (exit_label) = 1;
3946 return build1_v (GOTO_EXPR, exit_label);
3950 /* Translate the ALLOCATE statement. */
3953 gfc_trans_allocate (gfc_code * code)
3965 if (!code->ext.alloc_list)
3968 pstat = stat = error_label = tmp = NULL_TREE;
3970 gfc_start_block (&block);
3972 /* Either STAT= and/or ERRMSG is present. */
3973 if (code->expr1 || code->expr2)
3975 tree gfc_int4_type_node = gfc_get_int_type (4);
3977 stat = gfc_create_var (gfc_int4_type_node, "stat");
3978 pstat = gfc_build_addr_expr (NULL_TREE, stat);
3980 error_label = gfc_build_label_decl (NULL_TREE);
3981 TREE_USED (error_label) = 1;
3984 for (al = code->ext.alloc_list; al != NULL; al = al->next)
3988 gfc_init_se (&se, NULL);
3989 gfc_start_block (&se.pre);
3991 se.want_pointer = 1;
3992 se.descriptor_only = 1;
3993 gfc_conv_expr (&se, expr);
3995 if (!gfc_array_allocate (&se, expr, pstat))
3997 /* A scalar or derived type. */
3998 tmp = TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (se.expr)));
4000 if (expr->ts.type == BT_CHARACTER && tmp == NULL_TREE)
4001 tmp = se.string_length;
4003 tmp = gfc_allocate_with_status (&se.pre, tmp, pstat);
4004 tmp = fold_build2 (MODIFY_EXPR, void_type_node, se.expr,
4005 fold_convert (TREE_TYPE (se.expr), tmp));
4006 gfc_add_expr_to_block (&se.pre, tmp);
4008 if (code->expr1 || code->expr2)
4010 tmp = build1_v (GOTO_EXPR, error_label);
4011 parm = fold_build2 (NE_EXPR, boolean_type_node,
4012 stat, build_int_cst (TREE_TYPE (stat), 0));
4013 tmp = fold_build3 (COND_EXPR, void_type_node,
4014 parm, tmp, build_empty_stmt ());
4015 gfc_add_expr_to_block (&se.pre, tmp);
4018 if (expr->ts.type == BT_DERIVED && expr->ts.derived->attr.alloc_comp)
4020 tmp = build_fold_indirect_ref (se.expr);
4021 tmp = gfc_nullify_alloc_comp (expr->ts.derived, tmp, 0);
4022 gfc_add_expr_to_block (&se.pre, tmp);
4027 tmp = gfc_finish_block (&se.pre);
4028 gfc_add_expr_to_block (&block, tmp);
4034 tmp = build1_v (LABEL_EXPR, error_label);
4035 gfc_add_expr_to_block (&block, tmp);
4037 gfc_init_se (&se, NULL);
4038 gfc_conv_expr_lhs (&se, code->expr1);
4039 tmp = convert (TREE_TYPE (se.expr), stat);
4040 gfc_add_modify (&block, se.expr, tmp);
4046 /* A better error message may be possible, but not required. */
4047 const char *msg = "Attempt to allocate an allocated object";
4048 tree errmsg, slen, dlen;
4050 gfc_init_se (&se, NULL);
4051 gfc_conv_expr_lhs (&se, code->expr2);
4053 errmsg = gfc_create_var (pchar_type_node, "ERRMSG");
4055 gfc_add_modify (&block, errmsg,
4056 gfc_build_addr_expr (pchar_type_node,
4057 gfc_build_localized_cstring_const (msg)));
4059 slen = build_int_cst (gfc_charlen_type_node, ((int) strlen (msg)));
4060 dlen = gfc_get_expr_charlen (code->expr2);
4061 slen = fold_build2 (MIN_EXPR, TREE_TYPE (slen), dlen, slen);
4063 dlen = build_call_expr (built_in_decls[BUILT_IN_MEMCPY], 3,
4064 gfc_build_addr_expr (pvoid_type_node, se.expr), errmsg, slen);
4066 tmp = fold_build2 (NE_EXPR, boolean_type_node, stat,
4067 build_int_cst (TREE_TYPE (stat), 0));
4069 tmp = build3_v (COND_EXPR, tmp, dlen, build_empty_stmt ());
4071 gfc_add_expr_to_block (&block, tmp);
4074 return gfc_finish_block (&block);
4078 /* Translate a DEALLOCATE statement. */
4081 gfc_trans_deallocate (gfc_code *code)
4086 tree apstat, astat, pstat, stat, tmp;
4089 pstat = apstat = stat = astat = tmp = NULL_TREE;
4091 gfc_start_block (&block);
4093 /* Count the number of failed deallocations. If deallocate() was
4094 called with STAT= , then set STAT to the count. If deallocate
4095 was called with ERRMSG, then set ERRMG to a string. */
4096 if (code->expr1 || code->expr2)
4098 tree gfc_int4_type_node = gfc_get_int_type (4);
4100 stat = gfc_create_var (gfc_int4_type_node, "stat");
4101 pstat = gfc_build_addr_expr (NULL_TREE, stat);
4103 /* Running total of possible deallocation failures. */
4104 astat = gfc_create_var (gfc_int4_type_node, "astat");
4105 apstat = gfc_build_addr_expr (NULL_TREE, astat);
4107 /* Initialize astat to 0. */
4108 gfc_add_modify (&block, astat, build_int_cst (TREE_TYPE (astat), 0));
4111 for (al = code->ext.alloc_list; al != NULL; al = al->next)
4114 gcc_assert (expr->expr_type == EXPR_VARIABLE);
4116 gfc_init_se (&se, NULL);
4117 gfc_start_block (&se.pre);
4119 se.want_pointer = 1;
4120 se.descriptor_only = 1;
4121 gfc_conv_expr (&se, expr);
4123 if (expr->ts.type == BT_DERIVED && expr->ts.derived->attr.alloc_comp)
4126 gfc_ref *last = NULL;
4127 for (ref = expr->ref; ref; ref = ref->next)
4128 if (ref->type == REF_COMPONENT)
4131 /* Do not deallocate the components of a derived type
4132 ultimate pointer component. */
4133 if (!(last && last->u.c.component->attr.pointer)
4134 && !(!last && expr->symtree->n.sym->attr.pointer))
4136 tmp = gfc_deallocate_alloc_comp (expr->ts.derived, se.expr,
4138 gfc_add_expr_to_block (&se.pre, tmp);
4143 tmp = gfc_array_deallocate (se.expr, pstat, expr);
4146 tmp = gfc_deallocate_with_status (se.expr, pstat, false, expr);
4147 gfc_add_expr_to_block (&se.pre, tmp);
4149 tmp = fold_build2 (MODIFY_EXPR, void_type_node,
4150 se.expr, build_int_cst (TREE_TYPE (se.expr), 0));
4153 gfc_add_expr_to_block (&se.pre, tmp);
4155 /* Keep track of the number of failed deallocations by adding stat
4156 of the last deallocation to the running total. */
4157 if (code->expr1 || code->expr2)
4159 apstat = fold_build2 (PLUS_EXPR, TREE_TYPE (stat), astat, stat);
4160 gfc_add_modify (&se.pre, astat, apstat);
4163 tmp = gfc_finish_block (&se.pre);
4164 gfc_add_expr_to_block (&block, tmp);
4171 gfc_init_se (&se, NULL);
4172 gfc_conv_expr_lhs (&se, code->expr1);
4173 tmp = convert (TREE_TYPE (se.expr), astat);
4174 gfc_add_modify (&block, se.expr, tmp);
4180 /* A better error message may be possible, but not required. */
4181 const char *msg = "Attempt to deallocate an unallocated object";
4182 tree errmsg, slen, dlen;
4184 gfc_init_se (&se, NULL);
4185 gfc_conv_expr_lhs (&se, code->expr2);
4187 errmsg = gfc_create_var (pchar_type_node, "ERRMSG");
4189 gfc_add_modify (&block, errmsg,
4190 gfc_build_addr_expr (pchar_type_node,
4191 gfc_build_localized_cstring_const (msg)));
4193 slen = build_int_cst (gfc_charlen_type_node, ((int) strlen (msg)));
4194 dlen = gfc_get_expr_charlen (code->expr2);
4195 slen = fold_build2 (MIN_EXPR, TREE_TYPE (slen), dlen, slen);
4197 dlen = build_call_expr (built_in_decls[BUILT_IN_MEMCPY], 3,
4198 gfc_build_addr_expr (pvoid_type_node, se.expr), errmsg, slen);
4200 tmp = fold_build2 (NE_EXPR, boolean_type_node, astat,
4201 build_int_cst (TREE_TYPE (astat), 0));
4203 tmp = build3_v (COND_EXPR, tmp, dlen, build_empty_stmt ());
4205 gfc_add_expr_to_block (&block, tmp);
4208 return gfc_finish_block (&block);