1 /* Statement translation -- generate GCC trees from gfc_code.
2 Copyright (C) 2002, 2003, 2004, 2005, 2006 Free Software Foundation,
4 Contributed by Paul Brook <paul@nowt.org>
5 and Steven Bosscher <s.bosscher@student.tudelft.nl>
7 This file is part of GCC.
9 GCC is free software; you can redistribute it and/or modify it under
10 the terms of the GNU General Public License as published by the Free
11 Software Foundation; either version 2, or (at your option) any later
14 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
15 WARRANTY; without even the implied warranty of MERCHANTABILITY or
16 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
19 You should have received a copy of the GNU General Public License
20 along with GCC; see the file COPYING. If not, write to the Free
21 Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
27 #include "coretypes.h"
29 #include "tree-gimple.h"
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
60 struct forall_info *outer;
61 struct forall_info *next_nest;
65 static void gfc_trans_where_2 (gfc_code *, tree, forall_info *, stmtblock_t *);
67 /* Translate a F95 label number to a LABEL_EXPR. */
70 gfc_trans_label_here (gfc_code * code)
72 return build1_v (LABEL_EXPR, gfc_get_label_decl (code->here));
76 /* Given a variable expression which has been ASSIGNed to, find the decl
77 containing the auxiliary variables. For variables in common blocks this
81 gfc_conv_label_variable (gfc_se * se, gfc_expr * expr)
83 gcc_assert (expr->symtree->n.sym->attr.assign == 1);
84 gfc_conv_expr (se, expr);
85 /* Deals with variable in common block. Get the field declaration. */
86 if (TREE_CODE (se->expr) == COMPONENT_REF)
87 se->expr = TREE_OPERAND (se->expr, 1);
88 /* Deals with dummy argument. Get the parameter declaration. */
89 else if (TREE_CODE (se->expr) == INDIRECT_REF)
90 se->expr = TREE_OPERAND (se->expr, 0);
93 /* Translate a label assignment statement. */
96 gfc_trans_label_assign (gfc_code * code)
106 /* Start a new block. */
107 gfc_init_se (&se, NULL);
108 gfc_start_block (&se.pre);
109 gfc_conv_label_variable (&se, code->expr);
111 len = GFC_DECL_STRING_LEN (se.expr);
112 addr = GFC_DECL_ASSIGN_ADDR (se.expr);
114 label_tree = gfc_get_label_decl (code->label);
116 if (code->label->defined == ST_LABEL_TARGET)
118 label_tree = gfc_build_addr_expr (pvoid_type_node, label_tree);
119 len_tree = integer_minus_one_node;
123 label_str = code->label->format->value.character.string;
124 label_len = code->label->format->value.character.length;
125 len_tree = build_int_cst (NULL_TREE, label_len);
126 label_tree = gfc_build_string_const (label_len + 1, label_str);
127 label_tree = gfc_build_addr_expr (pvoid_type_node, label_tree);
130 gfc_add_modify_expr (&se.pre, len, len_tree);
131 gfc_add_modify_expr (&se.pre, addr, label_tree);
133 return gfc_finish_block (&se.pre);
136 /* Translate a GOTO statement. */
139 gfc_trans_goto (gfc_code * code)
149 if (code->label != NULL)
150 return build1_v (GOTO_EXPR, gfc_get_label_decl (code->label));
153 gfc_init_se (&se, NULL);
154 gfc_start_block (&se.pre);
155 gfc_conv_label_variable (&se, code->expr);
157 gfc_build_cstring_const ("Assigned label is not a target label");
158 tmp = GFC_DECL_STRING_LEN (se.expr);
159 tmp = fold_build2 (NE_EXPR, boolean_type_node, tmp,
160 build_int_cst (TREE_TYPE (tmp), -1));
161 gfc_trans_runtime_check (tmp, assign_error, &se.pre);
163 assigned_goto = GFC_DECL_ASSIGN_ADDR (se.expr);
168 target = build1 (GOTO_EXPR, void_type_node, assigned_goto);
169 gfc_add_expr_to_block (&se.pre, target);
170 return gfc_finish_block (&se.pre);
173 /* Check the label list. */
174 range_error = gfc_build_cstring_const ("Assigned label is not in the list");
178 target = gfc_get_label_decl (code->label);
179 tmp = gfc_build_addr_expr (pvoid_type_node, target);
180 tmp = build2 (EQ_EXPR, boolean_type_node, tmp, assigned_goto);
181 tmp = build3_v (COND_EXPR, tmp,
182 build1 (GOTO_EXPR, void_type_node, target),
183 build_empty_stmt ());
184 gfc_add_expr_to_block (&se.pre, tmp);
187 while (code != NULL);
188 gfc_trans_runtime_check (boolean_true_node, range_error, &se.pre);
189 return gfc_finish_block (&se.pre);
193 /* Translate an ENTRY statement. Just adds a label for this entry point. */
195 gfc_trans_entry (gfc_code * code)
197 return build1_v (LABEL_EXPR, code->ext.entry->label);
201 /* Translate the CALL statement. Builds a call to an F95 subroutine. */
204 gfc_trans_call (gfc_code * code)
208 int has_alternate_specifier;
210 /* A CALL starts a new block because the actual arguments may have to
211 be evaluated first. */
212 gfc_init_se (&se, NULL);
213 gfc_start_block (&se.pre);
215 gcc_assert (code->resolved_sym);
217 ss = gfc_ss_terminator;
218 if (code->resolved_sym->attr.elemental)
219 ss = gfc_walk_elemental_function_args (ss, code->ext.actual, GFC_SS_REFERENCE);
221 /* Is not an elemental subroutine call with array valued arguments. */
222 if (ss == gfc_ss_terminator)
225 /* Translate the call. */
226 has_alternate_specifier
227 = gfc_conv_function_call (&se, code->resolved_sym, code->ext.actual);
229 /* A subroutine without side-effect, by definition, does nothing! */
230 TREE_SIDE_EFFECTS (se.expr) = 1;
232 /* Chain the pieces together and return the block. */
233 if (has_alternate_specifier)
235 gfc_code *select_code;
237 select_code = code->next;
238 gcc_assert(select_code->op == EXEC_SELECT);
239 sym = select_code->expr->symtree->n.sym;
240 se.expr = convert (gfc_typenode_for_spec (&sym->ts), se.expr);
241 gfc_add_modify_expr (&se.pre, sym->backend_decl, se.expr);
244 gfc_add_expr_to_block (&se.pre, se.expr);
246 gfc_add_block_to_block (&se.pre, &se.post);
251 /* An elemental subroutine call with array valued arguments has
258 /* gfc_walk_elemental_function_args renders the ss chain in the
259 reverse order to the actual argument order. */
260 ss = gfc_reverse_ss (ss);
262 /* Initialize the loop. */
263 gfc_init_se (&loopse, NULL);
264 gfc_init_loopinfo (&loop);
265 gfc_add_ss_to_loop (&loop, ss);
267 gfc_conv_ss_startstride (&loop);
268 gfc_conv_loop_setup (&loop);
269 gfc_mark_ss_chain_used (ss, 1);
271 /* Generate the loop body. */
272 gfc_start_scalarized_body (&loop, &body);
273 gfc_init_block (&block);
274 gfc_copy_loopinfo_to_se (&loopse, &loop);
277 /* Add the subroutine call to the block. */
278 gfc_conv_function_call (&loopse, code->resolved_sym, code->ext.actual);
279 gfc_add_expr_to_block (&loopse.pre, loopse.expr);
281 gfc_add_block_to_block (&block, &loopse.pre);
282 gfc_add_block_to_block (&block, &loopse.post);
284 /* Finish up the loop block and the loop. */
285 gfc_add_expr_to_block (&body, gfc_finish_block (&block));
286 gfc_trans_scalarizing_loops (&loop, &body);
287 gfc_add_block_to_block (&se.pre, &loop.pre);
288 gfc_add_block_to_block (&se.pre, &loop.post);
289 gfc_cleanup_loop (&loop);
292 return gfc_finish_block (&se.pre);
296 /* Translate the RETURN statement. */
299 gfc_trans_return (gfc_code * code ATTRIBUTE_UNUSED)
307 /* if code->expr is not NULL, this return statement must appear
308 in a subroutine and current_fake_result_decl has already
311 result = gfc_get_fake_result_decl (NULL);
314 gfc_warning ("An alternate return at %L without a * dummy argument",
316 return build1_v (GOTO_EXPR, gfc_get_return_label ());
319 /* Start a new block for this statement. */
320 gfc_init_se (&se, NULL);
321 gfc_start_block (&se.pre);
323 gfc_conv_expr (&se, code->expr);
325 tmp = build2 (MODIFY_EXPR, TREE_TYPE (result), result, se.expr);
326 gfc_add_expr_to_block (&se.pre, tmp);
328 tmp = build1_v (GOTO_EXPR, gfc_get_return_label ());
329 gfc_add_expr_to_block (&se.pre, tmp);
330 gfc_add_block_to_block (&se.pre, &se.post);
331 return gfc_finish_block (&se.pre);
334 return build1_v (GOTO_EXPR, gfc_get_return_label ());
338 /* Translate the PAUSE statement. We have to translate this statement
339 to a runtime library call. */
342 gfc_trans_pause (gfc_code * code)
344 tree gfc_int4_type_node = gfc_get_int_type (4);
350 /* Start a new block for this statement. */
351 gfc_init_se (&se, NULL);
352 gfc_start_block (&se.pre);
355 if (code->expr == NULL)
357 tmp = build_int_cst (gfc_int4_type_node, code->ext.stop_code);
358 args = gfc_chainon_list (NULL_TREE, tmp);
359 fndecl = gfor_fndecl_pause_numeric;
363 gfc_conv_expr_reference (&se, code->expr);
364 args = gfc_chainon_list (NULL_TREE, se.expr);
365 args = gfc_chainon_list (args, se.string_length);
366 fndecl = gfor_fndecl_pause_string;
369 tmp = build_function_call_expr (fndecl, args);
370 gfc_add_expr_to_block (&se.pre, tmp);
372 gfc_add_block_to_block (&se.pre, &se.post);
374 return gfc_finish_block (&se.pre);
378 /* Translate the STOP statement. We have to translate this statement
379 to a runtime library call. */
382 gfc_trans_stop (gfc_code * code)
384 tree gfc_int4_type_node = gfc_get_int_type (4);
390 /* Start a new block for this statement. */
391 gfc_init_se (&se, NULL);
392 gfc_start_block (&se.pre);
395 if (code->expr == NULL)
397 tmp = build_int_cst (gfc_int4_type_node, code->ext.stop_code);
398 args = gfc_chainon_list (NULL_TREE, tmp);
399 fndecl = gfor_fndecl_stop_numeric;
403 gfc_conv_expr_reference (&se, code->expr);
404 args = gfc_chainon_list (NULL_TREE, se.expr);
405 args = gfc_chainon_list (args, se.string_length);
406 fndecl = gfor_fndecl_stop_string;
409 tmp = build_function_call_expr (fndecl, args);
410 gfc_add_expr_to_block (&se.pre, tmp);
412 gfc_add_block_to_block (&se.pre, &se.post);
414 return gfc_finish_block (&se.pre);
418 /* Generate GENERIC for the IF construct. This function also deals with
419 the simple IF statement, because the front end translates the IF
420 statement into an IF construct.
452 where COND_S is the simplified version of the predicate. PRE_COND_S
453 are the pre side-effects produced by the translation of the
455 We need to build the chain recursively otherwise we run into
456 problems with folding incomplete statements. */
459 gfc_trans_if_1 (gfc_code * code)
464 /* Check for an unconditional ELSE clause. */
466 return gfc_trans_code (code->next);
468 /* Initialize a statement builder for each block. Puts in NULL_TREEs. */
469 gfc_init_se (&if_se, NULL);
470 gfc_start_block (&if_se.pre);
472 /* Calculate the IF condition expression. */
473 gfc_conv_expr_val (&if_se, code->expr);
475 /* Translate the THEN clause. */
476 stmt = gfc_trans_code (code->next);
478 /* Translate the ELSE clause. */
480 elsestmt = gfc_trans_if_1 (code->block);
482 elsestmt = build_empty_stmt ();
484 /* Build the condition expression and add it to the condition block. */
485 stmt = fold_build3 (COND_EXPR, void_type_node, if_se.expr, stmt, elsestmt);
487 gfc_add_expr_to_block (&if_se.pre, stmt);
489 /* Finish off this statement. */
490 return gfc_finish_block (&if_se.pre);
494 gfc_trans_if (gfc_code * code)
496 /* Ignore the top EXEC_IF, it only announces an IF construct. The
497 actual code we must translate is in code->block. */
499 return gfc_trans_if_1 (code->block);
503 /* Translage an arithmetic IF expression.
505 IF (cond) label1, label2, label3 translates to
517 An optimized version can be generated in case of equal labels.
518 E.g., if label1 is equal to label2, we can translate it to
527 gfc_trans_arithmetic_if (gfc_code * code)
535 /* Start a new block. */
536 gfc_init_se (&se, NULL);
537 gfc_start_block (&se.pre);
539 /* Pre-evaluate COND. */
540 gfc_conv_expr_val (&se, code->expr);
542 /* Build something to compare with. */
543 zero = gfc_build_const (TREE_TYPE (se.expr), integer_zero_node);
545 if (code->label->value != code->label2->value)
547 /* If (cond < 0) take branch1 else take branch2.
548 First build jumps to the COND .LT. 0 and the COND .EQ. 0 cases. */
549 branch1 = build1_v (GOTO_EXPR, gfc_get_label_decl (code->label));
550 branch2 = build1_v (GOTO_EXPR, gfc_get_label_decl (code->label2));
552 if (code->label->value != code->label3->value)
553 tmp = fold_build2 (LT_EXPR, boolean_type_node, se.expr, zero);
555 tmp = fold_build2 (NE_EXPR, boolean_type_node, se.expr, zero);
557 branch1 = fold_build3 (COND_EXPR, void_type_node, tmp, branch1, branch2);
560 branch1 = build1_v (GOTO_EXPR, gfc_get_label_decl (code->label));
562 if (code->label->value != code->label3->value
563 && code->label2->value != code->label3->value)
565 /* if (cond <= 0) take branch1 else take branch2. */
566 branch2 = build1_v (GOTO_EXPR, gfc_get_label_decl (code->label3));
567 tmp = fold_build2 (LE_EXPR, boolean_type_node, se.expr, zero);
568 branch1 = fold_build3 (COND_EXPR, void_type_node, tmp, branch1, branch2);
571 /* Append the COND_EXPR to the evaluation of COND, and return. */
572 gfc_add_expr_to_block (&se.pre, branch1);
573 return gfc_finish_block (&se.pre);
577 /* Translate the simple DO construct. This is where the loop variable has
578 integer type and step +-1. We can't use this in the general case
579 because integer overflow and floating point errors could give incorrect
581 We translate a do loop from:
583 DO dovar = from, to, step
589 [Evaluate loop bounds and step]
591 if ((step > 0) ? (dovar <= to) : (dovar => to))
597 cond = (dovar == to);
599 if (cond) goto end_label;
604 This helps the optimizers by avoiding the extra induction variable
605 used in the general case. */
608 gfc_trans_simple_do (gfc_code * code, stmtblock_t *pblock, tree dovar,
609 tree from, tree to, tree step)
618 type = TREE_TYPE (dovar);
620 /* Initialize the DO variable: dovar = from. */
621 gfc_add_modify_expr (pblock, dovar, from);
623 /* Cycle and exit statements are implemented with gotos. */
624 cycle_label = gfc_build_label_decl (NULL_TREE);
625 exit_label = gfc_build_label_decl (NULL_TREE);
627 /* Put the labels where they can be found later. See gfc_trans_do(). */
628 code->block->backend_decl = tree_cons (cycle_label, exit_label, NULL);
631 gfc_start_block (&body);
633 /* Main loop body. */
634 tmp = gfc_trans_code (code->block->next);
635 gfc_add_expr_to_block (&body, tmp);
637 /* Label for cycle statements (if needed). */
638 if (TREE_USED (cycle_label))
640 tmp = build1_v (LABEL_EXPR, cycle_label);
641 gfc_add_expr_to_block (&body, tmp);
644 /* Evaluate the loop condition. */
645 cond = fold_build2 (EQ_EXPR, boolean_type_node, dovar, to);
646 cond = gfc_evaluate_now (cond, &body);
648 /* Increment the loop variable. */
649 tmp = fold_build2 (PLUS_EXPR, type, dovar, step);
650 gfc_add_modify_expr (&body, dovar, tmp);
653 tmp = build1_v (GOTO_EXPR, exit_label);
654 TREE_USED (exit_label) = 1;
655 tmp = fold_build3 (COND_EXPR, void_type_node,
656 cond, tmp, build_empty_stmt ());
657 gfc_add_expr_to_block (&body, tmp);
659 /* Finish the loop body. */
660 tmp = gfc_finish_block (&body);
661 tmp = build1_v (LOOP_EXPR, tmp);
663 /* Only execute the loop if the number of iterations is positive. */
664 if (tree_int_cst_sgn (step) > 0)
665 cond = fold_build2 (LE_EXPR, boolean_type_node, dovar, to);
667 cond = fold_build2 (GE_EXPR, boolean_type_node, dovar, to);
668 tmp = fold_build3 (COND_EXPR, void_type_node,
669 cond, tmp, build_empty_stmt ());
670 gfc_add_expr_to_block (pblock, tmp);
672 /* Add the exit label. */
673 tmp = build1_v (LABEL_EXPR, exit_label);
674 gfc_add_expr_to_block (pblock, tmp);
676 return gfc_finish_block (pblock);
679 /* Translate the DO construct. This obviously is one of the most
680 important ones to get right with any compiler, but especially
683 We special case some loop forms as described in gfc_trans_simple_do.
684 For other cases we implement them with a separate loop count,
685 as described in the standard.
687 We translate a do loop from:
689 DO dovar = from, to, step
695 [evaluate loop bounds and step]
696 count = (to + step - from) / step;
704 if (count <=0) goto exit_label;
708 TODO: Large loop counts
709 The code above assumes the loop count fits into a signed integer kind,
710 i.e. Does not work for loop counts > 2^31 for integer(kind=4) variables
711 We must support the full range. */
714 gfc_trans_do (gfc_code * code)
731 gfc_start_block (&block);
733 /* Evaluate all the expressions in the iterator. */
734 gfc_init_se (&se, NULL);
735 gfc_conv_expr_lhs (&se, code->ext.iterator->var);
736 gfc_add_block_to_block (&block, &se.pre);
738 type = TREE_TYPE (dovar);
740 gfc_init_se (&se, NULL);
741 gfc_conv_expr_val (&se, code->ext.iterator->start);
742 gfc_add_block_to_block (&block, &se.pre);
743 from = gfc_evaluate_now (se.expr, &block);
745 gfc_init_se (&se, NULL);
746 gfc_conv_expr_val (&se, code->ext.iterator->end);
747 gfc_add_block_to_block (&block, &se.pre);
748 to = gfc_evaluate_now (se.expr, &block);
750 gfc_init_se (&se, NULL);
751 gfc_conv_expr_val (&se, code->ext.iterator->step);
752 gfc_add_block_to_block (&block, &se.pre);
753 step = gfc_evaluate_now (se.expr, &block);
755 /* Special case simple loops. */
756 if (TREE_CODE (type) == INTEGER_TYPE
757 && (integer_onep (step)
758 || tree_int_cst_equal (step, integer_minus_one_node)))
759 return gfc_trans_simple_do (code, &block, dovar, from, to, step);
761 /* Initialize loop count. This code is executed before we enter the
762 loop body. We generate: count = (to + step - from) / step. */
764 tmp = fold_build2 (MINUS_EXPR, type, step, from);
765 tmp = fold_build2 (PLUS_EXPR, type, to, tmp);
766 if (TREE_CODE (type) == INTEGER_TYPE)
768 tmp = fold_build2 (TRUNC_DIV_EXPR, type, tmp, step);
769 count = gfc_create_var (type, "count");
773 /* TODO: We could use the same width as the real type.
774 This would probably cause more problems that it solves
775 when we implement "long double" types. */
776 tmp = fold_build2 (RDIV_EXPR, type, tmp, step);
777 tmp = fold_build1 (FIX_TRUNC_EXPR, gfc_array_index_type, tmp);
778 count = gfc_create_var (gfc_array_index_type, "count");
780 gfc_add_modify_expr (&block, count, tmp);
782 count_one = convert (TREE_TYPE (count), integer_one_node);
784 /* Initialize the DO variable: dovar = from. */
785 gfc_add_modify_expr (&block, dovar, from);
788 gfc_start_block (&body);
790 /* Cycle and exit statements are implemented with gotos. */
791 cycle_label = gfc_build_label_decl (NULL_TREE);
792 exit_label = gfc_build_label_decl (NULL_TREE);
794 /* Start with the loop condition. Loop until count <= 0. */
795 cond = fold_build2 (LE_EXPR, boolean_type_node, count,
796 build_int_cst (TREE_TYPE (count), 0));
797 tmp = build1_v (GOTO_EXPR, exit_label);
798 TREE_USED (exit_label) = 1;
799 tmp = fold_build3 (COND_EXPR, void_type_node,
800 cond, tmp, build_empty_stmt ());
801 gfc_add_expr_to_block (&body, tmp);
803 /* Put these labels where they can be found later. We put the
804 labels in a TREE_LIST node (because TREE_CHAIN is already
805 used). cycle_label goes in TREE_PURPOSE (backend_decl), exit
806 label in TREE_VALUE (backend_decl). */
808 code->block->backend_decl = tree_cons (cycle_label, exit_label, NULL);
810 /* Main loop body. */
811 tmp = gfc_trans_code (code->block->next);
812 gfc_add_expr_to_block (&body, tmp);
814 /* Label for cycle statements (if needed). */
815 if (TREE_USED (cycle_label))
817 tmp = build1_v (LABEL_EXPR, cycle_label);
818 gfc_add_expr_to_block (&body, tmp);
821 /* Increment the loop variable. */
822 tmp = build2 (PLUS_EXPR, type, dovar, step);
823 gfc_add_modify_expr (&body, dovar, tmp);
825 /* Decrement the loop count. */
826 tmp = build2 (MINUS_EXPR, TREE_TYPE (count), count, count_one);
827 gfc_add_modify_expr (&body, count, tmp);
829 /* End of loop body. */
830 tmp = gfc_finish_block (&body);
832 /* The for loop itself. */
833 tmp = build1_v (LOOP_EXPR, tmp);
834 gfc_add_expr_to_block (&block, tmp);
836 /* Add the exit label. */
837 tmp = build1_v (LABEL_EXPR, exit_label);
838 gfc_add_expr_to_block (&block, tmp);
840 return gfc_finish_block (&block);
844 /* Translate the DO WHILE construct.
857 if (! cond) goto exit_label;
863 Because the evaluation of the exit condition `cond' may have side
864 effects, we can't do much for empty loop bodies. The backend optimizers
865 should be smart enough to eliminate any dead loops. */
868 gfc_trans_do_while (gfc_code * code)
876 /* Everything we build here is part of the loop body. */
877 gfc_start_block (&block);
879 /* Cycle and exit statements are implemented with gotos. */
880 cycle_label = gfc_build_label_decl (NULL_TREE);
881 exit_label = gfc_build_label_decl (NULL_TREE);
883 /* Put the labels where they can be found later. See gfc_trans_do(). */
884 code->block->backend_decl = tree_cons (cycle_label, exit_label, NULL);
886 /* Create a GIMPLE version of the exit condition. */
887 gfc_init_se (&cond, NULL);
888 gfc_conv_expr_val (&cond, code->expr);
889 gfc_add_block_to_block (&block, &cond.pre);
890 cond.expr = fold_build1 (TRUTH_NOT_EXPR, boolean_type_node, cond.expr);
892 /* Build "IF (! cond) GOTO exit_label". */
893 tmp = build1_v (GOTO_EXPR, exit_label);
894 TREE_USED (exit_label) = 1;
895 tmp = fold_build3 (COND_EXPR, void_type_node,
896 cond.expr, tmp, build_empty_stmt ());
897 gfc_add_expr_to_block (&block, tmp);
899 /* The main body of the loop. */
900 tmp = gfc_trans_code (code->block->next);
901 gfc_add_expr_to_block (&block, tmp);
903 /* Label for cycle statements (if needed). */
904 if (TREE_USED (cycle_label))
906 tmp = build1_v (LABEL_EXPR, cycle_label);
907 gfc_add_expr_to_block (&block, tmp);
910 /* End of loop body. */
911 tmp = gfc_finish_block (&block);
913 gfc_init_block (&block);
914 /* Build the loop. */
915 tmp = build1_v (LOOP_EXPR, tmp);
916 gfc_add_expr_to_block (&block, tmp);
918 /* Add the exit label. */
919 tmp = build1_v (LABEL_EXPR, exit_label);
920 gfc_add_expr_to_block (&block, tmp);
922 return gfc_finish_block (&block);
926 /* Translate the SELECT CASE construct for INTEGER case expressions,
927 without killing all potential optimizations. The problem is that
928 Fortran allows unbounded cases, but the back-end does not, so we
929 need to intercept those before we enter the equivalent SWITCH_EXPR
932 For example, we translate this,
935 CASE (:100,101,105:115)
945 to the GENERIC equivalent,
949 case (minimum value for typeof(expr) ... 100:
955 case 200 ... (maximum value for typeof(expr):
972 gfc_trans_integer_select (gfc_code * code)
982 gfc_start_block (&block);
984 /* Calculate the switch expression. */
985 gfc_init_se (&se, NULL);
986 gfc_conv_expr_val (&se, code->expr);
987 gfc_add_block_to_block (&block, &se.pre);
989 end_label = gfc_build_label_decl (NULL_TREE);
991 gfc_init_block (&body);
993 for (c = code->block; c; c = c->block)
995 for (cp = c->ext.case_list; cp; cp = cp->next)
1000 /* Assume it's the default case. */
1001 low = high = NULL_TREE;
1005 low = gfc_conv_constant_to_tree (cp->low);
1007 /* If there's only a lower bound, set the high bound to the
1008 maximum value of the case expression. */
1010 high = TYPE_MAX_VALUE (TREE_TYPE (se.expr));
1015 /* Three cases are possible here:
1017 1) There is no lower bound, e.g. CASE (:N).
1018 2) There is a lower bound .NE. high bound, that is
1019 a case range, e.g. CASE (N:M) where M>N (we make
1020 sure that M>N during type resolution).
1021 3) There is a lower bound, and it has the same value
1022 as the high bound, e.g. CASE (N:N). This is our
1023 internal representation of CASE(N).
1025 In the first and second case, we need to set a value for
1026 high. In the thirth case, we don't because the GCC middle
1027 end represents a single case value by just letting high be
1028 a NULL_TREE. We can't do that because we need to be able
1029 to represent unbounded cases. */
1033 && mpz_cmp (cp->low->value.integer,
1034 cp->high->value.integer) != 0))
1035 high = gfc_conv_constant_to_tree (cp->high);
1037 /* Unbounded case. */
1039 low = TYPE_MIN_VALUE (TREE_TYPE (se.expr));
1042 /* Build a label. */
1043 label = gfc_build_label_decl (NULL_TREE);
1045 /* Add this case label.
1046 Add parameter 'label', make it match GCC backend. */
1047 tmp = build3 (CASE_LABEL_EXPR, void_type_node, low, high, label);
1048 gfc_add_expr_to_block (&body, tmp);
1051 /* Add the statements for this case. */
1052 tmp = gfc_trans_code (c->next);
1053 gfc_add_expr_to_block (&body, tmp);
1055 /* Break to the end of the construct. */
1056 tmp = build1_v (GOTO_EXPR, end_label);
1057 gfc_add_expr_to_block (&body, tmp);
1060 tmp = gfc_finish_block (&body);
1061 tmp = build3_v (SWITCH_EXPR, se.expr, tmp, NULL_TREE);
1062 gfc_add_expr_to_block (&block, tmp);
1064 tmp = build1_v (LABEL_EXPR, end_label);
1065 gfc_add_expr_to_block (&block, tmp);
1067 return gfc_finish_block (&block);
1071 /* Translate the SELECT CASE construct for LOGICAL case expressions.
1073 There are only two cases possible here, even though the standard
1074 does allow three cases in a LOGICAL SELECT CASE construct: .TRUE.,
1075 .FALSE., and DEFAULT.
1077 We never generate more than two blocks here. Instead, we always
1078 try to eliminate the DEFAULT case. This way, we can translate this
1079 kind of SELECT construct to a simple
1083 expression in GENERIC. */
1086 gfc_trans_logical_select (gfc_code * code)
1089 gfc_code *t, *f, *d;
1094 /* Assume we don't have any cases at all. */
1097 /* Now see which ones we actually do have. We can have at most two
1098 cases in a single case list: one for .TRUE. and one for .FALSE.
1099 The default case is always separate. If the cases for .TRUE. and
1100 .FALSE. are in the same case list, the block for that case list
1101 always executed, and we don't generate code a COND_EXPR. */
1102 for (c = code->block; c; c = c->block)
1104 for (cp = c->ext.case_list; cp; cp = cp->next)
1108 if (cp->low->value.logical == 0) /* .FALSE. */
1110 else /* if (cp->value.logical != 0), thus .TRUE. */
1118 /* Start a new block. */
1119 gfc_start_block (&block);
1121 /* Calculate the switch expression. We always need to do this
1122 because it may have side effects. */
1123 gfc_init_se (&se, NULL);
1124 gfc_conv_expr_val (&se, code->expr);
1125 gfc_add_block_to_block (&block, &se.pre);
1127 if (t == f && t != NULL)
1129 /* Cases for .TRUE. and .FALSE. are in the same block. Just
1130 translate the code for these cases, append it to the current
1132 gfc_add_expr_to_block (&block, gfc_trans_code (t->next));
1136 tree true_tree, false_tree, stmt;
1138 true_tree = build_empty_stmt ();
1139 false_tree = build_empty_stmt ();
1141 /* If we have a case for .TRUE. and for .FALSE., discard the default case.
1142 Otherwise, if .TRUE. or .FALSE. is missing and there is a default case,
1143 make the missing case the default case. */
1144 if (t != NULL && f != NULL)
1154 /* Translate the code for each of these blocks, and append it to
1155 the current block. */
1157 true_tree = gfc_trans_code (t->next);
1160 false_tree = gfc_trans_code (f->next);
1162 stmt = fold_build3 (COND_EXPR, void_type_node, se.expr,
1163 true_tree, false_tree);
1164 gfc_add_expr_to_block (&block, stmt);
1167 return gfc_finish_block (&block);
1171 /* Translate the SELECT CASE construct for CHARACTER case expressions.
1172 Instead of generating compares and jumps, it is far simpler to
1173 generate a data structure describing the cases in order and call a
1174 library subroutine that locates the right case.
1175 This is particularly true because this is the only case where we
1176 might have to dispose of a temporary.
1177 The library subroutine returns a pointer to jump to or NULL if no
1178 branches are to be taken. */
1181 gfc_trans_character_select (gfc_code *code)
1183 tree init, node, end_label, tmp, type, args, *labels;
1184 stmtblock_t block, body;
1190 static tree select_struct;
1191 static tree ss_string1, ss_string1_len;
1192 static tree ss_string2, ss_string2_len;
1193 static tree ss_target;
1195 if (select_struct == NULL)
1197 tree gfc_int4_type_node = gfc_get_int_type (4);
1199 select_struct = make_node (RECORD_TYPE);
1200 TYPE_NAME (select_struct) = get_identifier ("_jump_struct");
1203 #define ADD_FIELD(NAME, TYPE) \
1204 ss_##NAME = gfc_add_field_to_struct \
1205 (&(TYPE_FIELDS (select_struct)), select_struct, \
1206 get_identifier (stringize(NAME)), TYPE)
1208 ADD_FIELD (string1, pchar_type_node);
1209 ADD_FIELD (string1_len, gfc_int4_type_node);
1211 ADD_FIELD (string2, pchar_type_node);
1212 ADD_FIELD (string2_len, gfc_int4_type_node);
1214 ADD_FIELD (target, pvoid_type_node);
1217 gfc_finish_type (select_struct);
1220 cp = code->block->ext.case_list;
1221 while (cp->left != NULL)
1225 for (d = cp; d; d = d->right)
1229 labels = gfc_getmem (n * sizeof (tree));
1233 for(i = 0; i < n; i++)
1235 labels[i] = gfc_build_label_decl (NULL_TREE);
1236 TREE_USED (labels[i]) = 1;
1237 /* TODO: The gimplifier should do this for us, but it has
1238 inadequacies when dealing with static initializers. */
1239 FORCED_LABEL (labels[i]) = 1;
1242 end_label = gfc_build_label_decl (NULL_TREE);
1244 /* Generate the body */
1245 gfc_start_block (&block);
1246 gfc_init_block (&body);
1248 for (c = code->block; c; c = c->block)
1250 for (d = c->ext.case_list; d; d = d->next)
1252 tmp = build1_v (LABEL_EXPR, labels[d->n]);
1253 gfc_add_expr_to_block (&body, tmp);
1256 tmp = gfc_trans_code (c->next);
1257 gfc_add_expr_to_block (&body, tmp);
1259 tmp = build1_v (GOTO_EXPR, end_label);
1260 gfc_add_expr_to_block (&body, tmp);
1263 /* Generate the structure describing the branches */
1267 for(d = cp; d; d = d->right, i++)
1271 gfc_init_se (&se, NULL);
1275 node = tree_cons (ss_string1, null_pointer_node, node);
1276 node = tree_cons (ss_string1_len, integer_zero_node, node);
1280 gfc_conv_expr_reference (&se, d->low);
1282 node = tree_cons (ss_string1, se.expr, node);
1283 node = tree_cons (ss_string1_len, se.string_length, node);
1286 if (d->high == NULL)
1288 node = tree_cons (ss_string2, null_pointer_node, node);
1289 node = tree_cons (ss_string2_len, integer_zero_node, node);
1293 gfc_init_se (&se, NULL);
1294 gfc_conv_expr_reference (&se, d->high);
1296 node = tree_cons (ss_string2, se.expr, node);
1297 node = tree_cons (ss_string2_len, se.string_length, node);
1300 tmp = gfc_build_addr_expr (pvoid_type_node, labels[i]);
1301 node = tree_cons (ss_target, tmp, node);
1303 tmp = build_constructor_from_list (select_struct, nreverse (node));
1304 init = tree_cons (NULL_TREE, tmp, init);
1307 type = build_array_type (select_struct, build_index_type
1308 (build_int_cst (NULL_TREE, n - 1)));
1310 init = build_constructor_from_list (type, nreverse(init));
1311 TREE_CONSTANT (init) = 1;
1312 TREE_INVARIANT (init) = 1;
1313 TREE_STATIC (init) = 1;
1314 /* Create a static variable to hold the jump table. */
1315 tmp = gfc_create_var (type, "jumptable");
1316 TREE_CONSTANT (tmp) = 1;
1317 TREE_INVARIANT (tmp) = 1;
1318 TREE_STATIC (tmp) = 1;
1319 DECL_INITIAL (tmp) = init;
1322 /* Build an argument list for the library call */
1323 init = gfc_build_addr_expr (pvoid_type_node, init);
1324 args = gfc_chainon_list (NULL_TREE, init);
1326 tmp = build_int_cst (NULL_TREE, n);
1327 args = gfc_chainon_list (args, tmp);
1329 tmp = gfc_build_addr_expr (pvoid_type_node, end_label);
1330 args = gfc_chainon_list (args, tmp);
1332 gfc_init_se (&se, NULL);
1333 gfc_conv_expr_reference (&se, code->expr);
1335 args = gfc_chainon_list (args, se.expr);
1336 args = gfc_chainon_list (args, se.string_length);
1338 gfc_add_block_to_block (&block, &se.pre);
1340 tmp = build_function_call_expr (gfor_fndecl_select_string, args);
1341 tmp = build1 (GOTO_EXPR, void_type_node, tmp);
1342 gfc_add_expr_to_block (&block, tmp);
1344 tmp = gfc_finish_block (&body);
1345 gfc_add_expr_to_block (&block, tmp);
1346 tmp = build1_v (LABEL_EXPR, end_label);
1347 gfc_add_expr_to_block (&block, tmp);
1352 return gfc_finish_block (&block);
1356 /* Translate the three variants of the SELECT CASE construct.
1358 SELECT CASEs with INTEGER case expressions can be translated to an
1359 equivalent GENERIC switch statement, and for LOGICAL case
1360 expressions we build one or two if-else compares.
1362 SELECT CASEs with CHARACTER case expressions are a whole different
1363 story, because they don't exist in GENERIC. So we sort them and
1364 do a binary search at runtime.
1366 Fortran has no BREAK statement, and it does not allow jumps from
1367 one case block to another. That makes things a lot easier for
1371 gfc_trans_select (gfc_code * code)
1373 gcc_assert (code && code->expr);
1375 /* Empty SELECT constructs are legal. */
1376 if (code->block == NULL)
1377 return build_empty_stmt ();
1379 /* Select the correct translation function. */
1380 switch (code->expr->ts.type)
1382 case BT_LOGICAL: return gfc_trans_logical_select (code);
1383 case BT_INTEGER: return gfc_trans_integer_select (code);
1384 case BT_CHARACTER: return gfc_trans_character_select (code);
1386 gfc_internal_error ("gfc_trans_select(): Bad type for case expr.");
1392 /* Generate the loops for a FORALL block. The normal loop format:
1393 count = (end - start + step) / step
1406 gfc_trans_forall_loop (forall_info *forall_tmp, int nvar, tree body, int mask_flag)
1414 tree var, start, end, step;
1417 iter = forall_tmp->this_loop;
1418 for (n = 0; n < nvar; n++)
1421 start = iter->start;
1425 exit_label = gfc_build_label_decl (NULL_TREE);
1426 TREE_USED (exit_label) = 1;
1428 /* The loop counter. */
1429 count = gfc_create_var (TREE_TYPE (var), "count");
1431 /* The body of the loop. */
1432 gfc_init_block (&block);
1434 /* The exit condition. */
1435 cond = fold_build2 (LE_EXPR, boolean_type_node,
1436 count, build_int_cst (TREE_TYPE (count), 0));
1437 tmp = build1_v (GOTO_EXPR, exit_label);
1438 tmp = fold_build3 (COND_EXPR, void_type_node,
1439 cond, tmp, build_empty_stmt ());
1440 gfc_add_expr_to_block (&block, tmp);
1442 /* The main loop body. */
1443 gfc_add_expr_to_block (&block, body);
1445 /* Increment the loop variable. */
1446 tmp = build2 (PLUS_EXPR, TREE_TYPE (var), var, step);
1447 gfc_add_modify_expr (&block, var, tmp);
1449 /* Advance to the next mask element. Only do this for the
1451 if (n == 0 && mask_flag && forall_tmp->mask)
1453 tree maskindex = forall_tmp->maskindex;
1454 tmp = build2 (PLUS_EXPR, gfc_array_index_type,
1455 maskindex, gfc_index_one_node);
1456 gfc_add_modify_expr (&block, maskindex, tmp);
1459 /* Decrement the loop counter. */
1460 tmp = build2 (MINUS_EXPR, TREE_TYPE (var), count, gfc_index_one_node);
1461 gfc_add_modify_expr (&block, count, tmp);
1463 body = gfc_finish_block (&block);
1465 /* Loop var initialization. */
1466 gfc_init_block (&block);
1467 gfc_add_modify_expr (&block, var, start);
1469 /* Initialize maskindex counter. Only do this before the
1471 if (n == nvar - 1 && mask_flag && forall_tmp->mask)
1472 gfc_add_modify_expr (&block, forall_tmp->maskindex,
1473 gfc_index_zero_node);
1475 /* Initialize the loop counter. */
1476 tmp = fold_build2 (MINUS_EXPR, TREE_TYPE (var), step, start);
1477 tmp = fold_build2 (PLUS_EXPR, TREE_TYPE (var), end, tmp);
1478 tmp = fold_build2 (TRUNC_DIV_EXPR, TREE_TYPE (var), tmp, step);
1479 gfc_add_modify_expr (&block, count, tmp);
1481 /* The loop expression. */
1482 tmp = build1_v (LOOP_EXPR, body);
1483 gfc_add_expr_to_block (&block, tmp);
1485 /* The exit label. */
1486 tmp = build1_v (LABEL_EXPR, exit_label);
1487 gfc_add_expr_to_block (&block, tmp);
1489 body = gfc_finish_block (&block);
1496 /* Generate the body and loops according to MASK_FLAG and NEST_FLAG.
1497 if MASK_FLAG is nonzero, the body is controlled by maskes in forall
1498 nest, otherwise, the body is not controlled by maskes.
1499 if NEST_FLAG is nonzero, generate loops for nested forall, otherwise,
1500 only generate loops for the current forall level. */
1503 gfc_trans_nested_forall_loop (forall_info * nested_forall_info, tree body,
1504 int mask_flag, int nest_flag)
1508 forall_info *forall_tmp;
1509 tree pmask, mask, maskindex;
1511 forall_tmp = nested_forall_info;
1512 /* Generate loops for nested forall. */
1515 while (forall_tmp->next_nest != NULL)
1516 forall_tmp = forall_tmp->next_nest;
1517 while (forall_tmp != NULL)
1519 /* Generate body with masks' control. */
1522 pmask = forall_tmp->pmask;
1523 mask = forall_tmp->mask;
1524 maskindex = forall_tmp->maskindex;
1528 /* If a mask was specified make the assignment conditional. */
1530 tmp = build_fold_indirect_ref (mask);
1533 tmp = gfc_build_array_ref (tmp, maskindex);
1535 body = build3_v (COND_EXPR, tmp, body, build_empty_stmt ());
1538 nvar = forall_tmp->nvar;
1539 body = gfc_trans_forall_loop (forall_tmp, nvar, body, mask_flag);
1540 forall_tmp = forall_tmp->outer;
1545 nvar = forall_tmp->nvar;
1546 body = gfc_trans_forall_loop (forall_tmp, nvar, body, mask_flag);
1553 /* Allocate data for holding a temporary array. Returns either a local
1554 temporary array or a pointer variable. */
1557 gfc_do_allocate (tree bytesize, tree size, tree * pdata, stmtblock_t * pblock,
1565 if (INTEGER_CST_P (size))
1567 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, size,
1568 gfc_index_one_node);
1573 type = build_range_type (gfc_array_index_type, gfc_index_zero_node, tmp);
1574 type = build_array_type (elem_type, type);
1575 if (gfc_can_put_var_on_stack (bytesize))
1577 gcc_assert (INTEGER_CST_P (size));
1578 tmpvar = gfc_create_var (type, "temp");
1583 tmpvar = gfc_create_var (build_pointer_type (type), "temp");
1584 *pdata = convert (pvoid_type_node, tmpvar);
1586 args = gfc_chainon_list (NULL_TREE, bytesize);
1587 if (gfc_index_integer_kind == 4)
1588 tmp = gfor_fndecl_internal_malloc;
1589 else if (gfc_index_integer_kind == 8)
1590 tmp = gfor_fndecl_internal_malloc64;
1593 tmp = build_function_call_expr (tmp, args);
1594 tmp = convert (TREE_TYPE (tmpvar), tmp);
1595 gfc_add_modify_expr (pblock, tmpvar, tmp);
1601 /* Generate codes to copy the temporary to the actual lhs. */
1604 generate_loop_for_temp_to_lhs (gfc_expr *expr, tree tmp1, tree count3,
1605 tree count1, tree wheremask)
1609 stmtblock_t block, body;
1615 lss = gfc_walk_expr (expr);
1617 if (lss == gfc_ss_terminator)
1619 gfc_start_block (&block);
1621 gfc_init_se (&lse, NULL);
1623 /* Translate the expression. */
1624 gfc_conv_expr (&lse, expr);
1626 /* Form the expression for the temporary. */
1627 tmp = gfc_build_array_ref (tmp1, count1);
1629 /* Use the scalar assignment as is. */
1630 gfc_add_block_to_block (&block, &lse.pre);
1631 gfc_add_modify_expr (&block, lse.expr, tmp);
1632 gfc_add_block_to_block (&block, &lse.post);
1634 /* Increment the count1. */
1635 tmp = fold_build2 (PLUS_EXPR, TREE_TYPE (count1), count1,
1636 gfc_index_one_node);
1637 gfc_add_modify_expr (&block, count1, tmp);
1639 tmp = gfc_finish_block (&block);
1643 gfc_start_block (&block);
1645 gfc_init_loopinfo (&loop1);
1646 gfc_init_se (&rse, NULL);
1647 gfc_init_se (&lse, NULL);
1649 /* Associate the lss with the loop. */
1650 gfc_add_ss_to_loop (&loop1, lss);
1652 /* Calculate the bounds of the scalarization. */
1653 gfc_conv_ss_startstride (&loop1);
1654 /* Setup the scalarizing loops. */
1655 gfc_conv_loop_setup (&loop1);
1657 gfc_mark_ss_chain_used (lss, 1);
1659 /* Start the scalarized loop body. */
1660 gfc_start_scalarized_body (&loop1, &body);
1662 /* Setup the gfc_se structures. */
1663 gfc_copy_loopinfo_to_se (&lse, &loop1);
1666 /* Form the expression of the temporary. */
1667 if (lss != gfc_ss_terminator)
1668 rse.expr = gfc_build_array_ref (tmp1, count1);
1669 /* Translate expr. */
1670 gfc_conv_expr (&lse, expr);
1672 /* Use the scalar assignment. */
1673 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts.type);
1675 /* Form the mask expression according to the mask tree list. */
1678 wheremaskexpr = gfc_build_array_ref (wheremask, count3);
1679 tmp2 = TREE_CHAIN (wheremask);
1682 tmp1 = gfc_build_array_ref (tmp2, count3);
1683 wheremaskexpr = fold_build2 (TRUTH_AND_EXPR, TREE_TYPE (tmp1),
1684 wheremaskexpr, tmp1);
1685 tmp2 = TREE_CHAIN (tmp2);
1687 tmp = fold_build3 (COND_EXPR, void_type_node,
1688 wheremaskexpr, tmp, build_empty_stmt ());
1691 gfc_add_expr_to_block (&body, tmp);
1693 /* Increment count1. */
1694 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1695 count1, gfc_index_one_node);
1696 gfc_add_modify_expr (&body, count1, tmp);
1698 /* Increment count3. */
1701 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1702 count3, gfc_index_one_node);
1703 gfc_add_modify_expr (&body, count3, tmp);
1706 /* Generate the copying loops. */
1707 gfc_trans_scalarizing_loops (&loop1, &body);
1708 gfc_add_block_to_block (&block, &loop1.pre);
1709 gfc_add_block_to_block (&block, &loop1.post);
1710 gfc_cleanup_loop (&loop1);
1712 tmp = gfc_finish_block (&block);
1718 /* Generate codes to copy rhs to the temporary. TMP1 is the address of temporary
1719 LSS and RSS are formed in function compute_inner_temp_size(), and should
1723 generate_loop_for_rhs_to_temp (gfc_expr *expr2, tree tmp1, tree count3,
1724 tree count1, gfc_ss *lss, gfc_ss *rss,
1727 stmtblock_t block, body1;
1734 gfc_start_block (&block);
1736 gfc_init_se (&rse, NULL);
1737 gfc_init_se (&lse, NULL);
1739 if (lss == gfc_ss_terminator)
1741 gfc_init_block (&body1);
1742 gfc_conv_expr (&rse, expr2);
1743 lse.expr = gfc_build_array_ref (tmp1, count1);
1747 /* Initialize the loop. */
1748 gfc_init_loopinfo (&loop);
1750 /* We may need LSS to determine the shape of the expression. */
1751 gfc_add_ss_to_loop (&loop, lss);
1752 gfc_add_ss_to_loop (&loop, rss);
1754 gfc_conv_ss_startstride (&loop);
1755 gfc_conv_loop_setup (&loop);
1757 gfc_mark_ss_chain_used (rss, 1);
1758 /* Start the loop body. */
1759 gfc_start_scalarized_body (&loop, &body1);
1761 /* Translate the expression. */
1762 gfc_copy_loopinfo_to_se (&rse, &loop);
1764 gfc_conv_expr (&rse, expr2);
1766 /* Form the expression of the temporary. */
1767 lse.expr = gfc_build_array_ref (tmp1, count1);
1770 /* Use the scalar assignment. */
1771 tmp = gfc_trans_scalar_assign (&lse, &rse, expr2->ts.type);
1773 /* Form the mask expression according to the mask tree list. */
1776 wheremaskexpr = gfc_build_array_ref (wheremask, count3);
1777 tmp2 = TREE_CHAIN (wheremask);
1780 tmp1 = gfc_build_array_ref (tmp2, count3);
1781 wheremaskexpr = fold_build2 (TRUTH_AND_EXPR, TREE_TYPE (tmp1),
1782 wheremaskexpr, tmp1);
1783 tmp2 = TREE_CHAIN (tmp2);
1785 tmp = fold_build3 (COND_EXPR, void_type_node,
1786 wheremaskexpr, tmp, build_empty_stmt ());
1789 gfc_add_expr_to_block (&body1, tmp);
1791 if (lss == gfc_ss_terminator)
1793 gfc_add_block_to_block (&block, &body1);
1795 /* Increment count1. */
1796 tmp = fold_build2 (PLUS_EXPR, TREE_TYPE (count1), count1,
1797 gfc_index_one_node);
1798 gfc_add_modify_expr (&block, count1, tmp);
1802 /* Increment count1. */
1803 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1804 count1, gfc_index_one_node);
1805 gfc_add_modify_expr (&body1, count1, tmp);
1807 /* Increment count3. */
1810 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1811 count3, gfc_index_one_node);
1812 gfc_add_modify_expr (&body1, count3, tmp);
1815 /* Generate the copying loops. */
1816 gfc_trans_scalarizing_loops (&loop, &body1);
1818 gfc_add_block_to_block (&block, &loop.pre);
1819 gfc_add_block_to_block (&block, &loop.post);
1821 gfc_cleanup_loop (&loop);
1822 /* TODO: Reuse lss and rss when copying temp->lhs. Need to be careful
1823 as tree nodes in SS may not be valid in different scope. */
1826 tmp = gfc_finish_block (&block);
1831 /* Calculate the size of temporary needed in the assignment inside forall.
1832 LSS and RSS are filled in this function. */
1835 compute_inner_temp_size (gfc_expr *expr1, gfc_expr *expr2,
1836 stmtblock_t * pblock,
1837 gfc_ss **lss, gfc_ss **rss)
1844 *lss = gfc_walk_expr (expr1);
1847 size = gfc_index_one_node;
1848 if (*lss != gfc_ss_terminator)
1850 gfc_init_loopinfo (&loop);
1852 /* Walk the RHS of the expression. */
1853 *rss = gfc_walk_expr (expr2);
1854 if (*rss == gfc_ss_terminator)
1856 /* The rhs is scalar. Add a ss for the expression. */
1857 *rss = gfc_get_ss ();
1858 (*rss)->next = gfc_ss_terminator;
1859 (*rss)->type = GFC_SS_SCALAR;
1860 (*rss)->expr = expr2;
1863 /* Associate the SS with the loop. */
1864 gfc_add_ss_to_loop (&loop, *lss);
1865 /* We don't actually need to add the rhs at this point, but it might
1866 make guessing the loop bounds a bit easier. */
1867 gfc_add_ss_to_loop (&loop, *rss);
1869 /* We only want the shape of the expression, not rest of the junk
1870 generated by the scalarizer. */
1871 loop.array_parameter = 1;
1873 /* Calculate the bounds of the scalarization. */
1874 gfc_conv_ss_startstride (&loop);
1875 gfc_conv_loop_setup (&loop);
1877 /* Figure out how many elements we need. */
1878 for (i = 0; i < loop.dimen; i++)
1880 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1881 gfc_index_one_node, loop.from[i]);
1882 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1884 size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
1886 gfc_add_block_to_block (pblock, &loop.pre);
1887 size = gfc_evaluate_now (size, pblock);
1888 gfc_add_block_to_block (pblock, &loop.post);
1890 /* TODO: write a function that cleans up a loopinfo without freeing
1891 the SS chains. Currently a NOP. */
1898 /* Calculate the overall iterator number of the nested forall construct. */
1901 compute_overall_iter_number (forall_info *nested_forall_info, tree inner_size,
1902 stmtblock_t *inner_size_body, stmtblock_t *block)
1907 /* TODO: optimizing the computing process. */
1908 number = gfc_create_var (gfc_array_index_type, "num");
1909 gfc_add_modify_expr (block, number, gfc_index_zero_node);
1911 gfc_start_block (&body);
1912 if (inner_size_body)
1913 gfc_add_block_to_block (&body, inner_size_body);
1914 if (nested_forall_info)
1915 tmp = build2 (PLUS_EXPR, gfc_array_index_type, number,
1919 gfc_add_modify_expr (&body, number, tmp);
1920 tmp = gfc_finish_block (&body);
1922 /* Generate loops. */
1923 if (nested_forall_info != NULL)
1924 tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 0, 1);
1926 gfc_add_expr_to_block (block, tmp);
1932 /* Allocate temporary for forall construct. SIZE is the size of temporary
1933 needed. PTEMP1 is returned for space free. */
1936 allocate_temp_for_forall_nest_1 (tree type, tree size, stmtblock_t * block,
1944 unit = TYPE_SIZE_UNIT (type);
1945 bytesize = fold_build2 (MULT_EXPR, gfc_array_index_type, size, unit);
1948 temp1 = gfc_do_allocate (bytesize, size, ptemp1, block, type);
1951 tmp = build_fold_indirect_ref (temp1);
1959 /* Allocate temporary for forall construct according to the information in
1960 nested_forall_info. INNER_SIZE is the size of temporary needed in the
1961 assignment inside forall. PTEMP1 is returned for space free. */
1964 allocate_temp_for_forall_nest (forall_info * nested_forall_info, tree type,
1965 tree inner_size, stmtblock_t * inner_size_body,
1966 stmtblock_t * block, tree * ptemp1)
1970 /* Calculate the total size of temporary needed in forall construct. */
1971 size = compute_overall_iter_number (nested_forall_info, inner_size,
1972 inner_size_body, block);
1974 return allocate_temp_for_forall_nest_1 (type, size, block, ptemp1);
1978 /* Handle assignments inside forall which need temporary.
1980 forall (i=start:end:stride; maskexpr)
1983 (where e,f<i> are arbitrary expressions possibly involving i
1984 and there is a dependency between e<i> and f<i>)
1986 masktmp(:) = maskexpr(:)
1991 for (i = start; i <= end; i += stride)
1995 for (i = start; i <= end; i += stride)
1997 if (masktmp[maskindex++])
1998 tmp[count1++] = f<i>
2002 for (i = start; i <= end; i += stride)
2004 if (masktmp[maskindex++])
2005 e<i> = tmp[count1++]
2010 gfc_trans_assign_need_temp (gfc_expr * expr1, gfc_expr * expr2, tree wheremask,
2011 forall_info * nested_forall_info,
2012 stmtblock_t * block)
2020 stmtblock_t inner_size_body;
2022 /* Create vars. count1 is the current iterator number of the nested
2024 count1 = gfc_create_var (gfc_array_index_type, "count1");
2026 /* Count is the wheremask index. */
2029 count = gfc_create_var (gfc_array_index_type, "count");
2030 gfc_add_modify_expr (block, count, gfc_index_zero_node);
2035 /* Initialize count1. */
2036 gfc_add_modify_expr (block, count1, gfc_index_zero_node);
2038 /* Calculate the size of temporary needed in the assignment. Return loop, lss
2039 and rss which are used in function generate_loop_for_rhs_to_temp(). */
2040 gfc_init_block (&inner_size_body);
2041 inner_size = compute_inner_temp_size (expr1, expr2, &inner_size_body,
2044 /* The type of LHS. Used in function allocate_temp_for_forall_nest */
2045 type = gfc_typenode_for_spec (&expr1->ts);
2047 /* Allocate temporary for nested forall construct according to the
2048 information in nested_forall_info and inner_size. */
2049 tmp1 = allocate_temp_for_forall_nest (nested_forall_info, type, inner_size,
2050 &inner_size_body, block, &ptemp1);
2052 /* Generate codes to copy rhs to the temporary . */
2053 tmp = generate_loop_for_rhs_to_temp (expr2, tmp1, count, count1, lss, rss,
2056 /* Generate body and loops according to the information in
2057 nested_forall_info. */
2058 tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1, 1);
2059 gfc_add_expr_to_block (block, tmp);
2062 gfc_add_modify_expr (block, count1, gfc_index_zero_node);
2066 gfc_add_modify_expr (block, count, gfc_index_zero_node);
2068 /* Generate codes to copy the temporary to lhs. */
2069 tmp = generate_loop_for_temp_to_lhs (expr1, tmp1, count, count1, wheremask);
2071 /* Generate body and loops according to the information in
2072 nested_forall_info. */
2073 tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1, 1);
2074 gfc_add_expr_to_block (block, tmp);
2078 /* Free the temporary. */
2079 tmp = gfc_chainon_list (NULL_TREE, ptemp1);
2080 tmp = build_function_call_expr (gfor_fndecl_internal_free, tmp);
2081 gfc_add_expr_to_block (block, tmp);
2086 /* Translate pointer assignment inside FORALL which need temporary. */
2089 gfc_trans_pointer_assign_need_temp (gfc_expr * expr1, gfc_expr * expr2,
2090 forall_info * nested_forall_info,
2091 stmtblock_t * block)
2105 tree tmp, tmp1, ptemp1;
2107 count = gfc_create_var (gfc_array_index_type, "count");
2108 gfc_add_modify_expr (block, count, gfc_index_zero_node);
2110 inner_size = integer_one_node;
2111 lss = gfc_walk_expr (expr1);
2112 rss = gfc_walk_expr (expr2);
2113 if (lss == gfc_ss_terminator)
2115 type = gfc_typenode_for_spec (&expr1->ts);
2116 type = build_pointer_type (type);
2118 /* Allocate temporary for nested forall construct according to the
2119 information in nested_forall_info and inner_size. */
2120 tmp1 = allocate_temp_for_forall_nest (nested_forall_info, type,
2121 inner_size, NULL, block, &ptemp1);
2122 gfc_start_block (&body);
2123 gfc_init_se (&lse, NULL);
2124 lse.expr = gfc_build_array_ref (tmp1, count);
2125 gfc_init_se (&rse, NULL);
2126 rse.want_pointer = 1;
2127 gfc_conv_expr (&rse, expr2);
2128 gfc_add_block_to_block (&body, &rse.pre);
2129 gfc_add_modify_expr (&body, lse.expr,
2130 fold_convert (TREE_TYPE (lse.expr), rse.expr));
2131 gfc_add_block_to_block (&body, &rse.post);
2133 /* Increment count. */
2134 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2135 count, gfc_index_one_node);
2136 gfc_add_modify_expr (&body, count, tmp);
2138 tmp = gfc_finish_block (&body);
2140 /* Generate body and loops according to the information in
2141 nested_forall_info. */
2142 tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1, 1);
2143 gfc_add_expr_to_block (block, tmp);
2146 gfc_add_modify_expr (block, count, gfc_index_zero_node);
2148 gfc_start_block (&body);
2149 gfc_init_se (&lse, NULL);
2150 gfc_init_se (&rse, NULL);
2151 rse.expr = gfc_build_array_ref (tmp1, count);
2152 lse.want_pointer = 1;
2153 gfc_conv_expr (&lse, expr1);
2154 gfc_add_block_to_block (&body, &lse.pre);
2155 gfc_add_modify_expr (&body, lse.expr, rse.expr);
2156 gfc_add_block_to_block (&body, &lse.post);
2157 /* Increment count. */
2158 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2159 count, gfc_index_one_node);
2160 gfc_add_modify_expr (&body, count, tmp);
2161 tmp = gfc_finish_block (&body);
2163 /* Generate body and loops according to the information in
2164 nested_forall_info. */
2165 tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1, 1);
2166 gfc_add_expr_to_block (block, tmp);
2170 gfc_init_loopinfo (&loop);
2172 /* Associate the SS with the loop. */
2173 gfc_add_ss_to_loop (&loop, rss);
2175 /* Setup the scalarizing loops and bounds. */
2176 gfc_conv_ss_startstride (&loop);
2178 gfc_conv_loop_setup (&loop);
2180 info = &rss->data.info;
2181 desc = info->descriptor;
2183 /* Make a new descriptor. */
2184 parmtype = gfc_get_element_type (TREE_TYPE (desc));
2185 parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen,
2186 loop.from, loop.to, 1);
2188 /* Allocate temporary for nested forall construct. */
2189 tmp1 = allocate_temp_for_forall_nest (nested_forall_info, parmtype,
2190 inner_size, NULL, block, &ptemp1);
2191 gfc_start_block (&body);
2192 gfc_init_se (&lse, NULL);
2193 lse.expr = gfc_build_array_ref (tmp1, count);
2194 lse.direct_byref = 1;
2195 rss = gfc_walk_expr (expr2);
2196 gfc_conv_expr_descriptor (&lse, expr2, rss);
2198 gfc_add_block_to_block (&body, &lse.pre);
2199 gfc_add_block_to_block (&body, &lse.post);
2201 /* Increment count. */
2202 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2203 count, gfc_index_one_node);
2204 gfc_add_modify_expr (&body, count, tmp);
2206 tmp = gfc_finish_block (&body);
2208 /* Generate body and loops according to the information in
2209 nested_forall_info. */
2210 tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1, 1);
2211 gfc_add_expr_to_block (block, tmp);
2214 gfc_add_modify_expr (block, count, gfc_index_zero_node);
2216 parm = gfc_build_array_ref (tmp1, count);
2217 lss = gfc_walk_expr (expr1);
2218 gfc_init_se (&lse, NULL);
2219 gfc_conv_expr_descriptor (&lse, expr1, lss);
2220 gfc_add_modify_expr (&lse.pre, lse.expr, parm);
2221 gfc_start_block (&body);
2222 gfc_add_block_to_block (&body, &lse.pre);
2223 gfc_add_block_to_block (&body, &lse.post);
2225 /* Increment count. */
2226 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2227 count, gfc_index_one_node);
2228 gfc_add_modify_expr (&body, count, tmp);
2230 tmp = gfc_finish_block (&body);
2232 tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1, 1);
2233 gfc_add_expr_to_block (block, tmp);
2235 /* Free the temporary. */
2238 tmp = gfc_chainon_list (NULL_TREE, ptemp1);
2239 tmp = build_function_call_expr (gfor_fndecl_internal_free, tmp);
2240 gfc_add_expr_to_block (block, tmp);
2245 /* FORALL and WHERE statements are really nasty, especially when you nest
2246 them. All the rhs of a forall assignment must be evaluated before the
2247 actual assignments are performed. Presumably this also applies to all the
2248 assignments in an inner where statement. */
2250 /* Generate code for a FORALL statement. Any temporaries are allocated as a
2251 linear array, relying on the fact that we process in the same order in all
2254 forall (i=start:end:stride; maskexpr)
2258 (where e,f,g,h<i> are arbitrary expressions possibly involving i)
2260 count = ((end + 1 - start) / stride)
2261 masktmp(:) = maskexpr(:)
2264 for (i = start; i <= end; i += stride)
2266 if (masktmp[maskindex++])
2270 for (i = start; i <= end; i += stride)
2272 if (masktmp[maskindex++])
2276 Note that this code only works when there are no dependencies.
2277 Forall loop with array assignments and data dependencies are a real pain,
2278 because the size of the temporary cannot always be determined before the
2279 loop is executed. This problem is compounded by the presence of nested
2284 gfc_trans_forall_1 (gfc_code * code, forall_info * nested_forall_info)
2306 gfc_forall_iterator *fa;
2309 gfc_saved_var *saved_vars;
2310 iter_info *this_forall, *iter_tmp;
2311 forall_info *info, *forall_tmp;
2313 gfc_start_block (&block);
2316 /* Count the FORALL index number. */
2317 for (fa = code->ext.forall_iterator; fa; fa = fa->next)
2321 /* Allocate the space for var, start, end, step, varexpr. */
2322 var = (tree *) gfc_getmem (nvar * sizeof (tree));
2323 start = (tree *) gfc_getmem (nvar * sizeof (tree));
2324 end = (tree *) gfc_getmem (nvar * sizeof (tree));
2325 step = (tree *) gfc_getmem (nvar * sizeof (tree));
2326 varexpr = (gfc_expr **) gfc_getmem (nvar * sizeof (gfc_expr *));
2327 saved_vars = (gfc_saved_var *) gfc_getmem (nvar * sizeof (gfc_saved_var));
2329 /* Allocate the space for info. */
2330 info = (forall_info *) gfc_getmem (sizeof (forall_info));
2332 for (fa = code->ext.forall_iterator; fa; fa = fa->next)
2334 gfc_symbol *sym = fa->var->symtree->n.sym;
2336 /* allocate space for this_forall. */
2337 this_forall = (iter_info *) gfc_getmem (sizeof (iter_info));
2339 /* Create a temporary variable for the FORALL index. */
2340 tmp = gfc_typenode_for_spec (&sym->ts);
2341 var[n] = gfc_create_var (tmp, sym->name);
2342 gfc_shadow_sym (sym, var[n], &saved_vars[n]);
2344 /* Record it in this_forall. */
2345 this_forall->var = var[n];
2347 /* Replace the index symbol's backend_decl with the temporary decl. */
2348 sym->backend_decl = var[n];
2350 /* Work out the start, end and stride for the loop. */
2351 gfc_init_se (&se, NULL);
2352 gfc_conv_expr_val (&se, fa->start);
2353 /* Record it in this_forall. */
2354 this_forall->start = se.expr;
2355 gfc_add_block_to_block (&block, &se.pre);
2358 gfc_init_se (&se, NULL);
2359 gfc_conv_expr_val (&se, fa->end);
2360 /* Record it in this_forall. */
2361 this_forall->end = se.expr;
2362 gfc_make_safe_expr (&se);
2363 gfc_add_block_to_block (&block, &se.pre);
2366 gfc_init_se (&se, NULL);
2367 gfc_conv_expr_val (&se, fa->stride);
2368 /* Record it in this_forall. */
2369 this_forall->step = se.expr;
2370 gfc_make_safe_expr (&se);
2371 gfc_add_block_to_block (&block, &se.pre);
2374 /* Set the NEXT field of this_forall to NULL. */
2375 this_forall->next = NULL;
2376 /* Link this_forall to the info construct. */
2377 if (info->this_loop == NULL)
2378 info->this_loop = this_forall;
2381 iter_tmp = info->this_loop;
2382 while (iter_tmp->next != NULL)
2383 iter_tmp = iter_tmp->next;
2384 iter_tmp->next = this_forall;
2391 /* Work out the number of elements in the mask array. */
2394 size = gfc_index_one_node;
2395 sizevar = NULL_TREE;
2397 for (n = 0; n < nvar; n++)
2399 if (lenvar && TREE_TYPE (lenvar) != TREE_TYPE (start[n]))
2402 /* size = (end + step - start) / step. */
2403 tmp = fold_build2 (MINUS_EXPR, TREE_TYPE (start[n]),
2405 tmp = fold_build2 (PLUS_EXPR, TREE_TYPE (end[n]), end[n], tmp);
2407 tmp = fold_build2 (FLOOR_DIV_EXPR, TREE_TYPE (tmp), tmp, step[n]);
2408 tmp = convert (gfc_array_index_type, tmp);
2410 size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
2413 /* Record the nvar and size of current forall level. */
2417 /* Link the current forall level to nested_forall_info. */
2418 forall_tmp = nested_forall_info;
2419 if (forall_tmp == NULL)
2420 nested_forall_info = info;
2423 while (forall_tmp->next_nest != NULL)
2424 forall_tmp = forall_tmp->next_nest;
2425 info->outer = forall_tmp;
2426 forall_tmp->next_nest = info;
2429 /* Copy the mask into a temporary variable if required.
2430 For now we assume a mask temporary is needed. */
2433 /* As the mask array can be very big, prefer compact
2435 tree smallest_boolean_type_node
2436 = gfc_get_logical_type (gfc_logical_kinds[0].kind);
2438 /* Allocate the mask temporary. */
2439 bytesize = fold_build2 (MULT_EXPR, gfc_array_index_type, size,
2440 TYPE_SIZE_UNIT (smallest_boolean_type_node));
2442 mask = gfc_do_allocate (bytesize, size, &pmask, &block,
2443 smallest_boolean_type_node);
2445 maskindex = gfc_create_var_np (gfc_array_index_type, "mi");
2446 /* Record them in the info structure. */
2447 info->pmask = pmask;
2449 info->maskindex = maskindex;
2451 gfc_add_modify_expr (&block, maskindex, gfc_index_zero_node);
2453 /* Start of mask assignment loop body. */
2454 gfc_start_block (&body);
2456 /* Evaluate the mask expression. */
2457 gfc_init_se (&se, NULL);
2458 gfc_conv_expr_val (&se, code->expr);
2459 gfc_add_block_to_block (&body, &se.pre);
2461 /* Store the mask. */
2462 se.expr = convert (smallest_boolean_type_node, se.expr);
2465 tmp = build_fold_indirect_ref (mask);
2468 tmp = gfc_build_array_ref (tmp, maskindex);
2469 gfc_add_modify_expr (&body, tmp, se.expr);
2471 /* Advance to the next mask element. */
2472 tmp = build2 (PLUS_EXPR, gfc_array_index_type,
2473 maskindex, gfc_index_one_node);
2474 gfc_add_modify_expr (&body, maskindex, tmp);
2476 /* Generate the loops. */
2477 tmp = gfc_finish_block (&body);
2478 tmp = gfc_trans_nested_forall_loop (info, tmp, 0, 0);
2479 gfc_add_expr_to_block (&block, tmp);
2483 /* No mask was specified. */
2484 maskindex = NULL_TREE;
2485 mask = pmask = NULL_TREE;
2488 c = code->block->next;
2490 /* TODO: loop merging in FORALL statements. */
2491 /* Now that we've got a copy of the mask, generate the assignment loops. */
2497 /* A scalar or array assignment. */
2498 need_temp = gfc_check_dependency (c->expr, c->expr2, 0);
2499 /* Temporaries due to array assignment data dependencies introduce
2500 no end of problems. */
2502 gfc_trans_assign_need_temp (c->expr, c->expr2, NULL,
2503 nested_forall_info, &block);
2506 /* Use the normal assignment copying routines. */
2507 assign = gfc_trans_assignment (c->expr, c->expr2);
2509 /* Generate body and loops. */
2510 tmp = gfc_trans_nested_forall_loop (nested_forall_info, assign, 1, 1);
2511 gfc_add_expr_to_block (&block, tmp);
2517 /* Translate WHERE or WHERE construct nested in FORALL. */
2518 gfc_trans_where_2 (c, NULL, nested_forall_info, &block);
2521 /* Pointer assignment inside FORALL. */
2522 case EXEC_POINTER_ASSIGN:
2523 need_temp = gfc_check_dependency (c->expr, c->expr2, 0);
2525 gfc_trans_pointer_assign_need_temp (c->expr, c->expr2,
2526 nested_forall_info, &block);
2529 /* Use the normal assignment copying routines. */
2530 assign = gfc_trans_pointer_assignment (c->expr, c->expr2);
2532 /* Generate body and loops. */
2533 tmp = gfc_trans_nested_forall_loop (nested_forall_info, assign,
2535 gfc_add_expr_to_block (&block, tmp);
2540 tmp = gfc_trans_forall_1 (c, nested_forall_info);
2541 gfc_add_expr_to_block (&block, tmp);
2544 /* Explicit subroutine calls are prevented by the frontend but interface
2545 assignments can legitimately produce them. */
2547 assign = gfc_trans_call (c);
2548 tmp = gfc_trans_nested_forall_loop (nested_forall_info, assign, 1, 1);
2549 gfc_add_expr_to_block (&block, tmp);
2559 /* Restore the original index variables. */
2560 for (fa = code->ext.forall_iterator, n = 0; fa; fa = fa->next, n++)
2561 gfc_restore_sym (fa->var->symtree->n.sym, &saved_vars[n]);
2563 /* Free the space for var, start, end, step, varexpr. */
2569 gfc_free (saved_vars);
2573 /* Free the temporary for the mask. */
2574 tmp = gfc_chainon_list (NULL_TREE, pmask);
2575 tmp = build_function_call_expr (gfor_fndecl_internal_free, tmp);
2576 gfc_add_expr_to_block (&block, tmp);
2579 pushdecl (maskindex);
2581 return gfc_finish_block (&block);
2585 /* Translate the FORALL statement or construct. */
2587 tree gfc_trans_forall (gfc_code * code)
2589 return gfc_trans_forall_1 (code, NULL);
2593 /* Evaluate the WHERE mask expression, copy its value to a temporary.
2594 If the WHERE construct is nested in FORALL, compute the overall temporary
2595 needed by the WHERE mask expression multiplied by the iterator number of
2597 ME is the WHERE mask expression.
2598 MASK is the current execution mask upon input.
2599 CMASK is the updated execution mask on output, or NULL if not required.
2600 PMASK is the pending execution mask on output, or NULL if not required.
2601 BLOCK is the block in which to place the condition evaluation loops. */
2604 gfc_evaluate_where_mask (gfc_expr * me, forall_info * nested_forall_info,
2605 tree mask, tree cmask, tree pmask,
2606 tree mask_type, stmtblock_t * block)
2611 stmtblock_t body, body1;
2612 tree count, cond, mtmp;
2615 gfc_init_loopinfo (&loop);
2617 lss = gfc_walk_expr (me);
2618 rss = gfc_walk_expr (me);
2620 /* Variable to index the temporary. */
2621 count = gfc_create_var (gfc_array_index_type, "count");
2622 /* Initialize count. */
2623 gfc_add_modify_expr (block, count, gfc_index_zero_node);
2625 gfc_start_block (&body);
2627 gfc_init_se (&rse, NULL);
2628 gfc_init_se (&lse, NULL);
2630 if (lss == gfc_ss_terminator)
2632 gfc_init_block (&body1);
2636 /* Initialize the loop. */
2637 gfc_init_loopinfo (&loop);
2639 /* We may need LSS to determine the shape of the expression. */
2640 gfc_add_ss_to_loop (&loop, lss);
2641 gfc_add_ss_to_loop (&loop, rss);
2643 gfc_conv_ss_startstride (&loop);
2644 gfc_conv_loop_setup (&loop);
2646 gfc_mark_ss_chain_used (rss, 1);
2647 /* Start the loop body. */
2648 gfc_start_scalarized_body (&loop, &body1);
2650 /* Translate the expression. */
2651 gfc_copy_loopinfo_to_se (&rse, &loop);
2653 gfc_conv_expr (&rse, me);
2656 /* Variable to evalate mask condition. */
2657 cond = gfc_create_var (mask_type, "cond");
2658 if (mask && (cmask || pmask))
2659 mtmp = gfc_create_var (mask_type, "mask");
2660 else mtmp = NULL_TREE;
2662 gfc_add_block_to_block (&body1, &lse.pre);
2663 gfc_add_block_to_block (&body1, &rse.pre);
2665 gfc_add_modify_expr (&body1, cond, fold_convert (mask_type, rse.expr));
2667 if (mask && (cmask || pmask))
2669 tmp = gfc_build_array_ref (mask, count);
2670 gfc_add_modify_expr (&body1, mtmp, tmp);
2675 tmp1 = gfc_build_array_ref (cmask, count);
2678 tmp = build2 (TRUTH_AND_EXPR, mask_type, mtmp, tmp);
2679 gfc_add_modify_expr (&body1, tmp1, tmp);
2684 tmp1 = gfc_build_array_ref (pmask, count);
2685 tmp = build1 (TRUTH_NOT_EXPR, mask_type, cond);
2687 tmp = build2 (TRUTH_AND_EXPR, mask_type, mtmp, tmp);
2688 gfc_add_modify_expr (&body1, tmp1, tmp);
2691 gfc_add_block_to_block (&body1, &lse.post);
2692 gfc_add_block_to_block (&body1, &rse.post);
2694 if (lss == gfc_ss_terminator)
2696 gfc_add_block_to_block (&body, &body1);
2700 /* Increment count. */
2701 tmp1 = fold_build2 (PLUS_EXPR, gfc_array_index_type, count,
2702 gfc_index_one_node);
2703 gfc_add_modify_expr (&body1, count, tmp1);
2705 /* Generate the copying loops. */
2706 gfc_trans_scalarizing_loops (&loop, &body1);
2708 gfc_add_block_to_block (&body, &loop.pre);
2709 gfc_add_block_to_block (&body, &loop.post);
2711 gfc_cleanup_loop (&loop);
2712 /* TODO: Reuse lss and rss when copying temp->lhs. Need to be careful
2713 as tree nodes in SS may not be valid in different scope. */
2716 tmp1 = gfc_finish_block (&body);
2717 /* If the WHERE construct is inside FORALL, fill the full temporary. */
2718 if (nested_forall_info != NULL)
2719 tmp1 = gfc_trans_nested_forall_loop (nested_forall_info, tmp1, 1, 1);
2721 gfc_add_expr_to_block (block, tmp1);
2725 /* Translate an assignment statement in a WHERE statement or construct
2726 statement. The MASK expression is used to control which elements
2727 of EXPR1 shall be assigned. */
2730 gfc_trans_where_assign (gfc_expr *expr1, gfc_expr *expr2, tree mask,
2731 tree count1, tree count2)
2736 gfc_ss *lss_section;
2743 tree index, maskexpr;
2746 /* TODO: handle this special case.
2747 Special case a single function returning an array. */
2748 if (expr2->expr_type == EXPR_FUNCTION && expr2->rank > 0)
2750 tmp = gfc_trans_arrayfunc_assign (expr1, expr2);
2756 /* Assignment of the form lhs = rhs. */
2757 gfc_start_block (&block);
2759 gfc_init_se (&lse, NULL);
2760 gfc_init_se (&rse, NULL);
2763 lss = gfc_walk_expr (expr1);
2766 /* In each where-assign-stmt, the mask-expr and the variable being
2767 defined shall be arrays of the same shape. */
2768 gcc_assert (lss != gfc_ss_terminator);
2770 /* The assignment needs scalarization. */
2773 /* Find a non-scalar SS from the lhs. */
2774 while (lss_section != gfc_ss_terminator
2775 && lss_section->type != GFC_SS_SECTION)
2776 lss_section = lss_section->next;
2778 gcc_assert (lss_section != gfc_ss_terminator);
2780 /* Initialize the scalarizer. */
2781 gfc_init_loopinfo (&loop);
2784 rss = gfc_walk_expr (expr2);
2785 if (rss == gfc_ss_terminator)
2787 /* The rhs is scalar. Add a ss for the expression. */
2788 rss = gfc_get_ss ();
2789 rss->next = gfc_ss_terminator;
2790 rss->type = GFC_SS_SCALAR;
2794 /* Associate the SS with the loop. */
2795 gfc_add_ss_to_loop (&loop, lss);
2796 gfc_add_ss_to_loop (&loop, rss);
2798 /* Calculate the bounds of the scalarization. */
2799 gfc_conv_ss_startstride (&loop);
2801 /* Resolve any data dependencies in the statement. */
2802 gfc_conv_resolve_dependencies (&loop, lss_section, rss);
2804 /* Setup the scalarizing loops. */
2805 gfc_conv_loop_setup (&loop);
2807 /* Setup the gfc_se structures. */
2808 gfc_copy_loopinfo_to_se (&lse, &loop);
2809 gfc_copy_loopinfo_to_se (&rse, &loop);
2812 gfc_mark_ss_chain_used (rss, 1);
2813 if (loop.temp_ss == NULL)
2816 gfc_mark_ss_chain_used (lss, 1);
2820 lse.ss = loop.temp_ss;
2821 gfc_mark_ss_chain_used (lss, 3);
2822 gfc_mark_ss_chain_used (loop.temp_ss, 3);
2825 /* Start the scalarized loop body. */
2826 gfc_start_scalarized_body (&loop, &body);
2828 /* Translate the expression. */
2829 gfc_conv_expr (&rse, expr2);
2830 if (lss != gfc_ss_terminator && loop.temp_ss != NULL)
2832 gfc_conv_tmp_array_ref (&lse);
2833 gfc_advance_se_ss_chain (&lse);
2836 gfc_conv_expr (&lse, expr1);
2838 /* Form the mask expression according to the mask. */
2840 maskexpr = gfc_build_array_ref (mask, index);
2842 /* Use the scalar assignment as is. */
2843 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts.type);
2844 tmp = build3_v (COND_EXPR, maskexpr, tmp, build_empty_stmt ());
2846 gfc_add_expr_to_block (&body, tmp);
2848 if (lss == gfc_ss_terminator)
2850 /* Increment count1. */
2851 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2852 count1, gfc_index_one_node);
2853 gfc_add_modify_expr (&body, count1, tmp);
2855 /* Use the scalar assignment as is. */
2856 gfc_add_block_to_block (&block, &body);
2860 gcc_assert (lse.ss == gfc_ss_terminator
2861 && rse.ss == gfc_ss_terminator);
2863 if (loop.temp_ss != NULL)
2865 /* Increment count1 before finish the main body of a scalarized
2867 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2868 count1, gfc_index_one_node);
2869 gfc_add_modify_expr (&body, count1, tmp);
2870 gfc_trans_scalarized_loop_boundary (&loop, &body);
2872 /* We need to copy the temporary to the actual lhs. */
2873 gfc_init_se (&lse, NULL);
2874 gfc_init_se (&rse, NULL);
2875 gfc_copy_loopinfo_to_se (&lse, &loop);
2876 gfc_copy_loopinfo_to_se (&rse, &loop);
2878 rse.ss = loop.temp_ss;
2881 gfc_conv_tmp_array_ref (&rse);
2882 gfc_advance_se_ss_chain (&rse);
2883 gfc_conv_expr (&lse, expr1);
2885 gcc_assert (lse.ss == gfc_ss_terminator
2886 && rse.ss == gfc_ss_terminator);
2888 /* Form the mask expression according to the mask tree list. */
2890 maskexpr = gfc_build_array_ref (mask, index);
2892 /* Use the scalar assignment as is. */
2893 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts.type);
2894 tmp = build3_v (COND_EXPR, maskexpr, tmp, build_empty_stmt ());
2895 gfc_add_expr_to_block (&body, tmp);
2897 /* Increment count2. */
2898 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2899 count2, gfc_index_one_node);
2900 gfc_add_modify_expr (&body, count2, tmp);
2904 /* Increment count1. */
2905 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2906 count1, gfc_index_one_node);
2907 gfc_add_modify_expr (&body, count1, tmp);
2910 /* Generate the copying loops. */
2911 gfc_trans_scalarizing_loops (&loop, &body);
2913 /* Wrap the whole thing up. */
2914 gfc_add_block_to_block (&block, &loop.pre);
2915 gfc_add_block_to_block (&block, &loop.post);
2916 gfc_cleanup_loop (&loop);
2919 return gfc_finish_block (&block);
2923 /* Translate the WHERE construct or statement.
2924 This function can be called iteratively to translate the nested WHERE
2925 construct or statement.
2926 MASK is the control mask. */
2929 gfc_trans_where_2 (gfc_code * code, tree mask,
2930 forall_info * nested_forall_info, stmtblock_t * block)
2932 stmtblock_t inner_size_body;
2933 tree inner_size, size;
2941 tree count1, count2;
2943 tree pcmask = NULL_TREE;
2944 tree ppmask = NULL_TREE;
2945 tree cmask = NULL_TREE;
2946 tree pmask = NULL_TREE;
2948 /* the WHERE statement or the WHERE construct statement. */
2949 cblock = code->block;
2951 /* Calculate the size of temporary needed by the mask-expr. */
2952 gfc_init_block (&inner_size_body);
2953 inner_size = compute_inner_temp_size (cblock->expr, cblock->expr,
2954 &inner_size_body, &lss, &rss);
2956 /* Calculate the total size of temporary needed. */
2957 size = compute_overall_iter_number (nested_forall_info, inner_size,
2958 &inner_size_body, block);
2960 /* As the mask array can be very big, prefer compact boolean types. */
2961 mask_type = gfc_get_logical_type (gfc_logical_kinds[0].kind);
2963 /* Allocate temporary for WHERE mask. We only need a "cmask" if
2964 there are statements to be executed. The following test only
2965 checks the first ELSEWHERE to catch the F90 cases. */
2967 || (cblock->block && cblock->block->next && cblock->block->expr)
2968 || (cblock->block && cblock->block->block))
2970 cmask = allocate_temp_for_forall_nest_1 (mask_type, size, block,
2979 /* Allocate temporary for !mask. We only need a "pmask" if there
2980 is an ELSEWHERE clause containing executable statements. Again
2981 we only lookahead a single ELSEWHERE to catch the F90 cases. */
2982 if ((cblock->block && cblock->block->next)
2983 || (cblock->block && cblock->block->block))
2985 pmask = allocate_temp_for_forall_nest_1 (mask_type, size, block,
2996 /* Has mask-expr. */
2999 /* Ensure that the WHERE mask will be evaluated exactly once.
3000 If there are no statements in this WHERE/ELSEWHERE clause,
3001 then we don't need to update the control mask (cmask).
3002 If this is the last clause of the WHERE construct, then
3003 we don't need to update the pending control mask (pmask). */
3004 gfc_evaluate_where_mask (cblock->expr, nested_forall_info, mask,
3005 cblock->next ? cmask : NULL_TREE,
3006 cblock->block ? pmask : NULL_TREE,
3010 /* It's a final elsewhere-stmt. No mask-expr is present. */
3014 /* Get the assignment statement of a WHERE statement, or the first
3015 statement in where-body-construct of a WHERE construct. */
3016 cnext = cblock->next;
3021 /* WHERE assignment statement. */
3023 expr1 = cnext->expr;
3024 expr2 = cnext->expr2;
3025 if (nested_forall_info != NULL)
3027 need_temp = gfc_check_dependency (expr1, expr2, 0);
3029 gfc_trans_assign_need_temp (expr1, expr2, cmask,
3030 nested_forall_info, block);
3033 /* Variables to control maskexpr. */
3034 count1 = gfc_create_var (gfc_array_index_type, "count1");
3035 count2 = gfc_create_var (gfc_array_index_type, "count2");
3036 gfc_add_modify_expr (block, count1, gfc_index_zero_node);
3037 gfc_add_modify_expr (block, count2, gfc_index_zero_node);
3039 tmp = gfc_trans_where_assign (expr1, expr2, cmask,
3042 tmp = gfc_trans_nested_forall_loop (nested_forall_info,
3044 gfc_add_expr_to_block (block, tmp);
3049 /* Variables to control maskexpr. */
3050 count1 = gfc_create_var (gfc_array_index_type, "count1");
3051 count2 = gfc_create_var (gfc_array_index_type, "count2");
3052 gfc_add_modify_expr (block, count1, gfc_index_zero_node);
3053 gfc_add_modify_expr (block, count2, gfc_index_zero_node);
3055 tmp = gfc_trans_where_assign (expr1, expr2, cmask,
3057 gfc_add_expr_to_block (block, tmp);
3062 /* WHERE or WHERE construct is part of a where-body-construct. */
3064 /* Ensure that MASK is not modified by next gfc_trans_where_2. */
3065 gfc_trans_where_2 (cnext, cmask, nested_forall_info, block);
3072 /* The next statement within the same where-body-construct. */
3073 cnext = cnext->next;
3075 /* The next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt. */
3076 cblock = cblock->block;
3080 /* If we allocated a pending mask array, deallocate it now. */
3083 tree args = gfc_chainon_list (NULL_TREE, ppmask);
3084 tmp = build_function_call_expr (gfor_fndecl_internal_free, args);
3085 gfc_add_expr_to_block (block, tmp);
3088 /* If we allocated a current mask array, deallocate it now. */
3091 tree args = gfc_chainon_list (NULL_TREE, pcmask);
3092 tmp = build_function_call_expr (gfor_fndecl_internal_free, args);
3093 gfc_add_expr_to_block (block, tmp);
3097 /* Translate a simple WHERE construct or statement without dependencies.
3098 CBLOCK is the "then" clause of the WHERE statement, where CBLOCK->EXPR
3099 is the mask condition, and EBLOCK if non-NULL is the "else" clause.
3100 Currently both CBLOCK and EBLOCK are restricted to single assignments. */
3103 gfc_trans_where_3 (gfc_code * cblock, gfc_code * eblock)
3105 stmtblock_t block, body;
3106 gfc_expr *cond, *tdst, *tsrc, *edst, *esrc;
3107 tree tmp, cexpr, tstmt, estmt;
3108 gfc_ss *css, *tdss, *tsss;
3109 gfc_se cse, tdse, tsse, edse, esse;
3114 cond = cblock->expr;
3115 tdst = cblock->next->expr;
3116 tsrc = cblock->next->expr2;
3117 edst = eblock ? eblock->next->expr : NULL;
3118 esrc = eblock ? eblock->next->expr2 : NULL;
3120 gfc_start_block (&block);
3121 gfc_init_loopinfo (&loop);
3123 /* Handle the condition. */
3124 gfc_init_se (&cse, NULL);
3125 css = gfc_walk_expr (cond);
3126 gfc_add_ss_to_loop (&loop, css);
3128 /* Handle the then-clause. */
3129 gfc_init_se (&tdse, NULL);
3130 gfc_init_se (&tsse, NULL);
3131 tdss = gfc_walk_expr (tdst);
3132 tsss = gfc_walk_expr (tsrc);
3133 if (tsss == gfc_ss_terminator)
3135 tsss = gfc_get_ss ();
3136 tsss->next = gfc_ss_terminator;
3137 tsss->type = GFC_SS_SCALAR;
3140 gfc_add_ss_to_loop (&loop, tdss);
3141 gfc_add_ss_to_loop (&loop, tsss);
3145 /* Handle the else clause. */
3146 gfc_init_se (&edse, NULL);
3147 gfc_init_se (&esse, NULL);
3148 edss = gfc_walk_expr (edst);
3149 esss = gfc_walk_expr (esrc);
3150 if (esss == gfc_ss_terminator)
3152 esss = gfc_get_ss ();
3153 esss->next = gfc_ss_terminator;
3154 esss->type = GFC_SS_SCALAR;
3157 gfc_add_ss_to_loop (&loop, edss);
3158 gfc_add_ss_to_loop (&loop, esss);
3161 gfc_conv_ss_startstride (&loop);
3162 gfc_conv_loop_setup (&loop);
3164 gfc_mark_ss_chain_used (css, 1);
3165 gfc_mark_ss_chain_used (tdss, 1);
3166 gfc_mark_ss_chain_used (tsss, 1);
3169 gfc_mark_ss_chain_used (edss, 1);
3170 gfc_mark_ss_chain_used (esss, 1);
3173 gfc_start_scalarized_body (&loop, &body);
3175 gfc_copy_loopinfo_to_se (&cse, &loop);
3176 gfc_copy_loopinfo_to_se (&tdse, &loop);
3177 gfc_copy_loopinfo_to_se (&tsse, &loop);
3183 gfc_copy_loopinfo_to_se (&edse, &loop);
3184 gfc_copy_loopinfo_to_se (&esse, &loop);
3189 gfc_conv_expr (&cse, cond);
3190 gfc_add_block_to_block (&body, &cse.pre);
3193 gfc_conv_expr (&tsse, tsrc);
3194 if (tdss != gfc_ss_terminator && loop.temp_ss != NULL)
3196 gfc_conv_tmp_array_ref (&tdse);
3197 gfc_advance_se_ss_chain (&tdse);
3200 gfc_conv_expr (&tdse, tdst);
3204 gfc_conv_expr (&esse, esrc);
3205 if (edss != gfc_ss_terminator && loop.temp_ss != NULL)
3207 gfc_conv_tmp_array_ref (&edse);
3208 gfc_advance_se_ss_chain (&edse);
3211 gfc_conv_expr (&edse, edst);
3214 tstmt = gfc_trans_scalar_assign (&tdse, &tsse, tdst->ts.type);
3215 estmt = eblock ? gfc_trans_scalar_assign (&edse, &esse, edst->ts.type)
3216 : build_empty_stmt ();
3217 tmp = build3_v (COND_EXPR, cexpr, tstmt, estmt);
3218 gfc_add_expr_to_block (&body, tmp);
3219 gfc_add_block_to_block (&body, &cse.post);
3221 gfc_trans_scalarizing_loops (&loop, &body);
3222 gfc_add_block_to_block (&block, &loop.pre);
3223 gfc_add_block_to_block (&block, &loop.post);
3224 gfc_cleanup_loop (&loop);
3226 return gfc_finish_block (&block);
3229 /* As the WHERE or WHERE construct statement can be nested, we call
3230 gfc_trans_where_2 to do the translation, and pass the initial
3231 NULL values for both the control mask and the pending control mask. */
3234 gfc_trans_where (gfc_code * code)
3240 cblock = code->block;
3242 && cblock->next->op == EXEC_ASSIGN
3243 && !cblock->next->next)
3245 eblock = cblock->block;
3248 /* A simple "WHERE (cond) x = y" statement or block is
3249 dependence free if cond is not dependent upon writing x,
3250 and the source y is unaffected by the destination x. */
3251 if (!gfc_check_dependency (cblock->next->expr,
3253 && !gfc_check_dependency (cblock->next->expr,
3254 cblock->next->expr2, 0))
3255 return gfc_trans_where_3 (cblock, NULL);
3257 else if (!eblock->expr
3260 && eblock->next->op == EXEC_ASSIGN
3261 && !eblock->next->next)
3263 /* A simple "WHERE (cond) x1 = y1 ELSEWHERE x2 = y2 ENDWHERE"
3264 block is dependence free if cond is not dependent on writes
3265 to x1 and x2, y1 is not dependent on writes to x2, and y2
3266 is not dependent on writes to x1, and both y's are not
3267 dependent upon their own x's. */
3268 if (!gfc_check_dependency(cblock->next->expr,
3270 && !gfc_check_dependency(eblock->next->expr,
3272 && !gfc_check_dependency(cblock->next->expr,
3273 eblock->next->expr2, 0)
3274 && !gfc_check_dependency(eblock->next->expr,
3275 cblock->next->expr2, 0)
3276 && !gfc_check_dependency(cblock->next->expr,
3277 cblock->next->expr2, 0)
3278 && !gfc_check_dependency(eblock->next->expr,
3279 eblock->next->expr2, 0))
3280 return gfc_trans_where_3 (cblock, eblock);
3284 gfc_start_block (&block);
3286 gfc_trans_where_2 (code, NULL, NULL, &block);
3288 return gfc_finish_block (&block);
3292 /* CYCLE a DO loop. The label decl has already been created by
3293 gfc_trans_do(), it's in TREE_PURPOSE (backend_decl) of the gfc_code
3294 node at the head of the loop. We must mark the label as used. */
3297 gfc_trans_cycle (gfc_code * code)
3301 cycle_label = TREE_PURPOSE (code->ext.whichloop->backend_decl);
3302 TREE_USED (cycle_label) = 1;
3303 return build1_v (GOTO_EXPR, cycle_label);
3307 /* EXIT a DO loop. Similar to CYCLE, but now the label is in
3308 TREE_VALUE (backend_decl) of the gfc_code node at the head of the
3312 gfc_trans_exit (gfc_code * code)
3316 exit_label = TREE_VALUE (code->ext.whichloop->backend_decl);
3317 TREE_USED (exit_label) = 1;
3318 return build1_v (GOTO_EXPR, exit_label);
3322 /* Translate the ALLOCATE statement. */
3325 gfc_trans_allocate (gfc_code * code)
3338 if (!code->ext.alloc_list)
3341 gfc_start_block (&block);
3345 tree gfc_int4_type_node = gfc_get_int_type (4);
3347 stat = gfc_create_var (gfc_int4_type_node, "stat");
3348 pstat = build_fold_addr_expr (stat);
3350 error_label = gfc_build_label_decl (NULL_TREE);
3351 TREE_USED (error_label) = 1;
3355 pstat = integer_zero_node;
3356 stat = error_label = NULL_TREE;
3360 for (al = code->ext.alloc_list; al != NULL; al = al->next)
3364 gfc_init_se (&se, NULL);
3365 gfc_start_block (&se.pre);
3367 se.want_pointer = 1;
3368 se.descriptor_only = 1;
3369 gfc_conv_expr (&se, expr);
3373 /* Find the last reference in the chain. */
3374 while (ref && ref->next != NULL)
3376 gcc_assert (ref->type != REF_ARRAY || ref->u.ar.type == AR_ELEMENT);
3380 if (ref != NULL && ref->type == REF_ARRAY)
3383 gfc_array_allocate (&se, ref, pstat);
3387 /* A scalar or derived type. */
3390 val = gfc_create_var (ppvoid_type_node, "ptr");
3391 tmp = gfc_build_addr_expr (ppvoid_type_node, se.expr);
3392 gfc_add_modify_expr (&se.pre, val, tmp);
3394 tmp = TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (se.expr)));
3396 if (expr->ts.type == BT_CHARACTER && tmp == NULL_TREE)
3397 tmp = se.string_length;
3399 parm = gfc_chainon_list (NULL_TREE, val);
3400 parm = gfc_chainon_list (parm, tmp);
3401 parm = gfc_chainon_list (parm, pstat);
3402 tmp = build_function_call_expr (gfor_fndecl_allocate, parm);
3403 gfc_add_expr_to_block (&se.pre, tmp);
3407 tmp = build1_v (GOTO_EXPR, error_label);
3408 parm = fold_build2 (NE_EXPR, boolean_type_node,
3409 stat, build_int_cst (TREE_TYPE (stat), 0));
3410 tmp = fold_build3 (COND_EXPR, void_type_node,
3411 parm, tmp, build_empty_stmt ());
3412 gfc_add_expr_to_block (&se.pre, tmp);
3416 tmp = gfc_finish_block (&se.pre);
3417 gfc_add_expr_to_block (&block, tmp);
3420 /* Assign the value to the status variable. */
3423 tmp = build1_v (LABEL_EXPR, error_label);
3424 gfc_add_expr_to_block (&block, tmp);
3426 gfc_init_se (&se, NULL);
3427 gfc_conv_expr_lhs (&se, code->expr);
3428 tmp = convert (TREE_TYPE (se.expr), stat);
3429 gfc_add_modify_expr (&block, se.expr, tmp);
3432 return gfc_finish_block (&block);
3436 /* Translate a DEALLOCATE statement.
3437 There are two cases within the for loop:
3438 (1) deallocate(a1, a2, a3) is translated into the following sequence
3439 _gfortran_deallocate(a1, 0B)
3440 _gfortran_deallocate(a2, 0B)
3441 _gfortran_deallocate(a3, 0B)
3442 where the STAT= variable is passed a NULL pointer.
3443 (2) deallocate(a1, a2, a3, stat=i) is translated into the following
3445 _gfortran_deallocate(a1, &stat)
3446 astat = astat + stat
3447 _gfortran_deallocate(a2, &stat)
3448 astat = astat + stat
3449 _gfortran_deallocate(a3, &stat)
3450 astat = astat + stat
3451 In case (1), we simply return at the end of the for loop. In case (2)
3452 we set STAT= astat. */
3454 gfc_trans_deallocate (gfc_code * code)
3459 tree apstat, astat, parm, pstat, stat, tmp, type, var;
3462 gfc_start_block (&block);
3464 /* Set up the optional STAT= */
3467 tree gfc_int4_type_node = gfc_get_int_type (4);
3469 /* Variable used with the library call. */
3470 stat = gfc_create_var (gfc_int4_type_node, "stat");
3471 pstat = build_fold_addr_expr (stat);
3473 /* Running total of possible deallocation failures. */
3474 astat = gfc_create_var (gfc_int4_type_node, "astat");
3475 apstat = build_fold_addr_expr (astat);
3477 /* Initialize astat to 0. */
3478 gfc_add_modify_expr (&block, astat, build_int_cst (TREE_TYPE (astat), 0));
3482 pstat = apstat = null_pointer_node;
3483 stat = astat = NULL_TREE;
3486 for (al = code->ext.alloc_list; al != NULL; al = al->next)
3489 gcc_assert (expr->expr_type == EXPR_VARIABLE);
3491 gfc_init_se (&se, NULL);
3492 gfc_start_block (&se.pre);
3494 se.want_pointer = 1;
3495 se.descriptor_only = 1;
3496 gfc_conv_expr (&se, expr);
3499 tmp = gfc_array_deallocate (se.expr, pstat);
3502 type = build_pointer_type (TREE_TYPE (se.expr));
3503 var = gfc_create_var (type, "ptr");
3504 tmp = gfc_build_addr_expr (type, se.expr);
3505 gfc_add_modify_expr (&se.pre, var, tmp);
3507 parm = gfc_chainon_list (NULL_TREE, var);
3508 parm = gfc_chainon_list (parm, pstat);
3509 tmp = build_function_call_expr (gfor_fndecl_deallocate, parm);
3512 gfc_add_expr_to_block (&se.pre, tmp);
3514 /* Keep track of the number of failed deallocations by adding stat
3515 of the last deallocation to the running total. */
3518 apstat = build2 (PLUS_EXPR, TREE_TYPE (stat), astat, stat);
3519 gfc_add_modify_expr (&se.pre, astat, apstat);
3522 tmp = gfc_finish_block (&se.pre);
3523 gfc_add_expr_to_block (&block, tmp);
3527 /* Assign the value to the status variable. */
3530 gfc_init_se (&se, NULL);
3531 gfc_conv_expr_lhs (&se, code->expr);
3532 tmp = convert (TREE_TYPE (se.expr), astat);
3533 gfc_add_modify_expr (&block, se.expr, tmp);
3536 return gfc_finish_block (&block);