1 /* Statement translation -- generate GCC trees from gfc_code.
2 Copyright (C) 2002, 2003, 2004, 2005 Free Software Foundation, Inc.
3 Contributed by Paul Brook <paul@nowt.org>
4 and Steven Bosscher <s.bosscher@student.tudelft.nl>
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 2, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING. If not, write to the Free
20 Software Foundation, 59 Temple Place - Suite 330, Boston, MA
26 #include "coretypes.h"
28 #include "tree-gimple.h"
34 #include "trans-stmt.h"
35 #include "trans-types.h"
36 #include "trans-array.h"
37 #include "trans-const.h"
40 int has_alternate_specifier;
42 typedef struct iter_info
48 struct iter_info *next;
52 typedef struct temporary_list
55 struct temporary_list *next;
59 typedef struct forall_info
67 struct forall_info *outer;
68 struct forall_info *next_nest;
72 static void gfc_trans_where_2 (gfc_code *, tree, tree, forall_info *,
73 stmtblock_t *, temporary_list **temp);
75 /* Translate a F95 label number to a LABEL_EXPR. */
78 gfc_trans_label_here (gfc_code * code)
80 return build1_v (LABEL_EXPR, gfc_get_label_decl (code->here));
83 /* Translate a label assignment statement. */
85 gfc_trans_label_assign (gfc_code * code)
95 /* Start a new block. */
96 gfc_init_se (&se, NULL);
97 gfc_start_block (&se.pre);
98 gfc_conv_expr (&se, code->expr);
99 len = GFC_DECL_STRING_LEN (se.expr);
100 addr = GFC_DECL_ASSIGN_ADDR (se.expr);
102 label_tree = gfc_get_label_decl (code->label);
104 if (code->label->defined == ST_LABEL_TARGET)
106 label_tree = gfc_build_addr_expr (pvoid_type_node, label_tree);
107 len_tree = integer_minus_one_node;
111 label_str = code->label->format->value.character.string;
112 label_len = code->label->format->value.character.length;
113 len_tree = build_int_cst (NULL_TREE, label_len);
114 label_tree = gfc_build_string_const (label_len + 1, label_str);
115 label_tree = gfc_build_addr_expr (pchar_type_node, label_tree);
118 gfc_add_modify_expr (&se.pre, len, len_tree);
119 gfc_add_modify_expr (&se.pre, addr, label_tree);
121 return gfc_finish_block (&se.pre);
124 /* Translate a GOTO statement. */
127 gfc_trans_goto (gfc_code * code)
137 if (code->label != NULL)
138 return build1_v (GOTO_EXPR, gfc_get_label_decl (code->label));
141 gfc_init_se (&se, NULL);
142 gfc_start_block (&se.pre);
143 gfc_conv_expr (&se, code->expr);
145 gfc_build_cstring_const ("Assigned label is not a target label");
146 tmp = GFC_DECL_STRING_LEN (se.expr);
147 tmp = build2 (NE_EXPR, boolean_type_node, tmp, integer_minus_one_node);
148 gfc_trans_runtime_check (tmp, assign_error, &se.pre);
150 assigned_goto = GFC_DECL_ASSIGN_ADDR (se.expr);
151 target = build1 (GOTO_EXPR, void_type_node, assigned_goto);
156 gfc_add_expr_to_block (&se.pre, target);
157 return gfc_finish_block (&se.pre);
160 /* Check the label list. */
161 range_error = gfc_build_cstring_const ("Assigned label is not in the list");
165 tmp = gfc_get_label_decl (code->label);
166 tmp = gfc_build_addr_expr (pvoid_type_node, tmp);
167 tmp = build2 (EQ_EXPR, boolean_type_node, tmp, assigned_goto);
168 tmp = build3_v (COND_EXPR, tmp, target, build_empty_stmt ());
169 gfc_add_expr_to_block (&se.pre, tmp);
172 while (code != NULL);
173 gfc_trans_runtime_check (boolean_true_node, range_error, &se.pre);
174 return gfc_finish_block (&se.pre);
178 /* Translate an ENTRY statement. Just adds a label for this entry point. */
180 gfc_trans_entry (gfc_code * code)
182 return build1_v (LABEL_EXPR, code->ext.entry->label);
186 /* Translate the CALL statement. Builds a call to an F95 subroutine. */
189 gfc_trans_call (gfc_code * code)
193 /* A CALL starts a new block because the actual arguments may have to
194 be evaluated first. */
195 gfc_init_se (&se, NULL);
196 gfc_start_block (&se.pre);
198 gcc_assert (code->resolved_sym);
199 has_alternate_specifier = 0;
201 /* Translate the call. */
202 gfc_conv_function_call (&se, code->resolved_sym, code->ext.actual);
204 /* A subroutine without side-effect, by definition, does nothing! */
205 TREE_SIDE_EFFECTS (se.expr) = 1;
207 /* Chain the pieces together and return the block. */
208 if (has_alternate_specifier)
210 gfc_code *select_code;
212 select_code = code->next;
213 gcc_assert(select_code->op == EXEC_SELECT);
214 sym = select_code->expr->symtree->n.sym;
215 se.expr = convert (gfc_typenode_for_spec (&sym->ts), se.expr);
216 gfc_add_modify_expr (&se.pre, sym->backend_decl, se.expr);
219 gfc_add_expr_to_block (&se.pre, se.expr);
221 gfc_add_block_to_block (&se.pre, &se.post);
222 return gfc_finish_block (&se.pre);
226 /* Translate the RETURN statement. */
229 gfc_trans_return (gfc_code * code ATTRIBUTE_UNUSED)
237 /* if code->expr is not NULL, this return statement must appear
238 in a subroutine and current_fake_result_decl has already
241 result = gfc_get_fake_result_decl (NULL);
244 gfc_warning ("An alternate return at %L without a * dummy argument",
246 return build1_v (GOTO_EXPR, gfc_get_return_label ());
249 /* Start a new block for this statement. */
250 gfc_init_se (&se, NULL);
251 gfc_start_block (&se.pre);
253 gfc_conv_expr (&se, code->expr);
255 tmp = build2 (MODIFY_EXPR, TREE_TYPE (result), result, se.expr);
256 gfc_add_expr_to_block (&se.pre, tmp);
258 tmp = build1_v (GOTO_EXPR, gfc_get_return_label ());
259 gfc_add_expr_to_block (&se.pre, tmp);
260 gfc_add_block_to_block (&se.pre, &se.post);
261 return gfc_finish_block (&se.pre);
264 return build1_v (GOTO_EXPR, gfc_get_return_label ());
268 /* Translate the PAUSE statement. We have to translate this statement
269 to a runtime library call. */
272 gfc_trans_pause (gfc_code * code)
274 tree gfc_int4_type_node = gfc_get_int_type (4);
280 /* Start a new block for this statement. */
281 gfc_init_se (&se, NULL);
282 gfc_start_block (&se.pre);
285 if (code->expr == NULL)
287 tmp = build_int_cst (gfc_int4_type_node, code->ext.stop_code);
288 args = gfc_chainon_list (NULL_TREE, tmp);
289 fndecl = gfor_fndecl_pause_numeric;
293 gfc_conv_expr_reference (&se, code->expr);
294 args = gfc_chainon_list (NULL_TREE, se.expr);
295 args = gfc_chainon_list (args, se.string_length);
296 fndecl = gfor_fndecl_pause_string;
299 tmp = gfc_build_function_call (fndecl, args);
300 gfc_add_expr_to_block (&se.pre, tmp);
302 gfc_add_block_to_block (&se.pre, &se.post);
304 return gfc_finish_block (&se.pre);
308 /* Translate the STOP statement. We have to translate this statement
309 to a runtime library call. */
312 gfc_trans_stop (gfc_code * code)
314 tree gfc_int4_type_node = gfc_get_int_type (4);
320 /* Start a new block for this statement. */
321 gfc_init_se (&se, NULL);
322 gfc_start_block (&se.pre);
325 if (code->expr == NULL)
327 tmp = build_int_cst (gfc_int4_type_node, code->ext.stop_code);
328 args = gfc_chainon_list (NULL_TREE, tmp);
329 fndecl = gfor_fndecl_stop_numeric;
333 gfc_conv_expr_reference (&se, code->expr);
334 args = gfc_chainon_list (NULL_TREE, se.expr);
335 args = gfc_chainon_list (args, se.string_length);
336 fndecl = gfor_fndecl_stop_string;
339 tmp = gfc_build_function_call (fndecl, args);
340 gfc_add_expr_to_block (&se.pre, tmp);
342 gfc_add_block_to_block (&se.pre, &se.post);
344 return gfc_finish_block (&se.pre);
348 /* Generate GENERIC for the IF construct. This function also deals with
349 the simple IF statement, because the front end translates the IF
350 statement into an IF construct.
382 where COND_S is the simplified version of the predicate. PRE_COND_S
383 are the pre side-effects produced by the translation of the
385 We need to build the chain recursively otherwise we run into
386 problems with folding incomplete statements. */
389 gfc_trans_if_1 (gfc_code * code)
394 /* Check for an unconditional ELSE clause. */
396 return gfc_trans_code (code->next);
398 /* Initialize a statement builder for each block. Puts in NULL_TREEs. */
399 gfc_init_se (&if_se, NULL);
400 gfc_start_block (&if_se.pre);
402 /* Calculate the IF condition expression. */
403 gfc_conv_expr_val (&if_se, code->expr);
405 /* Translate the THEN clause. */
406 stmt = gfc_trans_code (code->next);
408 /* Translate the ELSE clause. */
410 elsestmt = gfc_trans_if_1 (code->block);
412 elsestmt = build_empty_stmt ();
414 /* Build the condition expression and add it to the condition block. */
415 stmt = build3_v (COND_EXPR, if_se.expr, stmt, elsestmt);
417 gfc_add_expr_to_block (&if_se.pre, stmt);
419 /* Finish off this statement. */
420 return gfc_finish_block (&if_se.pre);
424 gfc_trans_if (gfc_code * code)
426 /* Ignore the top EXEC_IF, it only announces an IF construct. The
427 actual code we must translate is in code->block. */
429 return gfc_trans_if_1 (code->block);
433 /* Translage an arithmetic IF expression.
435 IF (cond) label1, label2, label3 translates to
449 gfc_trans_arithmetic_if (gfc_code * code)
457 /* Start a new block. */
458 gfc_init_se (&se, NULL);
459 gfc_start_block (&se.pre);
461 /* Pre-evaluate COND. */
462 gfc_conv_expr_val (&se, code->expr);
464 /* Build something to compare with. */
465 zero = gfc_build_const (TREE_TYPE (se.expr), integer_zero_node);
467 /* If (cond < 0) take branch1 else take branch2.
468 First build jumps to the COND .LT. 0 and the COND .EQ. 0 cases. */
469 branch1 = build1_v (GOTO_EXPR, gfc_get_label_decl (code->label));
470 branch2 = build1_v (GOTO_EXPR, gfc_get_label_decl (code->label2));
472 tmp = build2 (LT_EXPR, boolean_type_node, se.expr, zero);
473 branch1 = build3_v (COND_EXPR, tmp, branch1, branch2);
475 /* if (cond <= 0) take branch1 else take branch2. */
476 branch2 = build1_v (GOTO_EXPR, gfc_get_label_decl (code->label3));
477 tmp = build2 (LE_EXPR, boolean_type_node, se.expr, zero);
478 branch1 = build3_v (COND_EXPR, tmp, branch1, branch2);
480 /* Append the COND_EXPR to the evaluation of COND, and return. */
481 gfc_add_expr_to_block (&se.pre, branch1);
482 return gfc_finish_block (&se.pre);
486 /* Translate the simple DO construct. This is where the loop variable has
487 integer type and step +-1. We can't use this in the general case
488 because integer overflow and floating point errors could give incorrect
490 We translate a do loop from:
492 DO dovar = from, to, step
498 [Evaluate loop bounds and step]
500 if ((step > 0) ? (dovar <= to) : (dovar => to))
506 cond = (dovar == to);
508 if (cond) goto end_label;
513 This helps the optimizers by avoiding the extra induction variable
514 used in the general case. */
517 gfc_trans_simple_do (gfc_code * code, stmtblock_t *pblock, tree dovar,
518 tree from, tree to, tree step)
527 type = TREE_TYPE (dovar);
529 /* Initialize the DO variable: dovar = from. */
530 gfc_add_modify_expr (pblock, dovar, from);
532 /* Cycle and exit statements are implemented with gotos. */
533 cycle_label = gfc_build_label_decl (NULL_TREE);
534 exit_label = gfc_build_label_decl (NULL_TREE);
536 /* Put the labels where they can be found later. See gfc_trans_do(). */
537 code->block->backend_decl = tree_cons (cycle_label, exit_label, NULL);
540 gfc_start_block (&body);
542 /* Main loop body. */
543 tmp = gfc_trans_code (code->block->next);
544 gfc_add_expr_to_block (&body, tmp);
546 /* Label for cycle statements (if needed). */
547 if (TREE_USED (cycle_label))
549 tmp = build1_v (LABEL_EXPR, cycle_label);
550 gfc_add_expr_to_block (&body, tmp);
553 /* Evaluate the loop condition. */
554 cond = build2 (EQ_EXPR, boolean_type_node, dovar, to);
555 cond = gfc_evaluate_now (cond, &body);
557 /* Increment the loop variable. */
558 tmp = build2 (PLUS_EXPR, type, dovar, step);
559 gfc_add_modify_expr (&body, dovar, tmp);
562 tmp = build1_v (GOTO_EXPR, exit_label);
563 TREE_USED (exit_label) = 1;
564 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
565 gfc_add_expr_to_block (&body, tmp);
567 /* Finish the loop body. */
568 tmp = gfc_finish_block (&body);
569 tmp = build1_v (LOOP_EXPR, tmp);
571 /* Only execute the loop if the number of iterations is positive. */
572 if (tree_int_cst_sgn (step) > 0)
573 cond = fold (build2 (LE_EXPR, boolean_type_node, dovar, to));
575 cond = fold (build2 (GE_EXPR, boolean_type_node, dovar, to));
576 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
577 gfc_add_expr_to_block (pblock, tmp);
579 /* Add the exit label. */
580 tmp = build1_v (LABEL_EXPR, exit_label);
581 gfc_add_expr_to_block (pblock, tmp);
583 return gfc_finish_block (pblock);
586 /* Translate the DO construct. This obviously is one of the most
587 important ones to get right with any compiler, but especially
590 We special case some loop forms as described in gfc_trans_simple_do.
591 For other cases we implement them with a separate loop count,
592 as described in the standard.
594 We translate a do loop from:
596 DO dovar = from, to, step
602 [evaluate loop bounds and step]
603 count = to + step - from;
611 if (count <=0) goto exit_label;
615 TODO: Large loop counts
616 The code above assumes the loop count fits into a signed integer kind,
617 i.e. Does not work for loop counts > 2^31 for integer(kind=4) variables
618 We must support the full range. */
621 gfc_trans_do (gfc_code * code)
638 gfc_start_block (&block);
640 /* Evaluate all the expressions in the iterator. */
641 gfc_init_se (&se, NULL);
642 gfc_conv_expr_lhs (&se, code->ext.iterator->var);
643 gfc_add_block_to_block (&block, &se.pre);
645 type = TREE_TYPE (dovar);
647 gfc_init_se (&se, NULL);
648 gfc_conv_expr_val (&se, code->ext.iterator->start);
649 gfc_add_block_to_block (&block, &se.pre);
650 from = gfc_evaluate_now (se.expr, &block);
652 gfc_init_se (&se, NULL);
653 gfc_conv_expr_val (&se, code->ext.iterator->end);
654 gfc_add_block_to_block (&block, &se.pre);
655 to = gfc_evaluate_now (se.expr, &block);
657 gfc_init_se (&se, NULL);
658 gfc_conv_expr_val (&se, code->ext.iterator->step);
659 gfc_add_block_to_block (&block, &se.pre);
660 step = gfc_evaluate_now (se.expr, &block);
662 /* Special case simple loops. */
663 if (TREE_CODE (type) == INTEGER_TYPE
664 && (integer_onep (step)
665 || tree_int_cst_equal (step, integer_minus_one_node)))
666 return gfc_trans_simple_do (code, &block, dovar, from, to, step);
668 /* Initialize loop count. This code is executed before we enter the
669 loop body. We generate: count = (to + step - from) / step. */
671 tmp = fold (build2 (MINUS_EXPR, type, step, from));
672 tmp = fold (build2 (PLUS_EXPR, type, to, tmp));
673 if (TREE_CODE (type) == INTEGER_TYPE)
675 tmp = fold (build2 (TRUNC_DIV_EXPR, type, tmp, step));
676 count = gfc_create_var (type, "count");
680 /* TODO: We could use the same width as the real type.
681 This would probably cause more problems that it solves
682 when we implement "long double" types. */
683 tmp = fold (build2 (RDIV_EXPR, type, tmp, step));
684 tmp = fold (build1 (FIX_TRUNC_EXPR, gfc_array_index_type, tmp));
685 count = gfc_create_var (gfc_array_index_type, "count");
687 gfc_add_modify_expr (&block, count, tmp);
689 count_one = convert (TREE_TYPE (count), integer_one_node);
691 /* Initialize the DO variable: dovar = from. */
692 gfc_add_modify_expr (&block, dovar, from);
695 gfc_start_block (&body);
697 /* Cycle and exit statements are implemented with gotos. */
698 cycle_label = gfc_build_label_decl (NULL_TREE);
699 exit_label = gfc_build_label_decl (NULL_TREE);
701 /* Start with the loop condition. Loop until count <= 0. */
702 cond = build2 (LE_EXPR, boolean_type_node, count,
703 convert (TREE_TYPE (count), integer_zero_node));
704 tmp = build1_v (GOTO_EXPR, exit_label);
705 TREE_USED (exit_label) = 1;
706 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
707 gfc_add_expr_to_block (&body, tmp);
709 /* Put these labels where they can be found later. We put the
710 labels in a TREE_LIST node (because TREE_CHAIN is already
711 used). cycle_label goes in TREE_PURPOSE (backend_decl), exit
712 label in TREE_VALUE (backend_decl). */
714 code->block->backend_decl = tree_cons (cycle_label, exit_label, NULL);
716 /* Main loop body. */
717 tmp = gfc_trans_code (code->block->next);
718 gfc_add_expr_to_block (&body, tmp);
720 /* Label for cycle statements (if needed). */
721 if (TREE_USED (cycle_label))
723 tmp = build1_v (LABEL_EXPR, cycle_label);
724 gfc_add_expr_to_block (&body, tmp);
727 /* Increment the loop variable. */
728 tmp = build2 (PLUS_EXPR, type, dovar, step);
729 gfc_add_modify_expr (&body, dovar, tmp);
731 /* Decrement the loop count. */
732 tmp = build2 (MINUS_EXPR, TREE_TYPE (count), count, count_one);
733 gfc_add_modify_expr (&body, count, tmp);
735 /* End of loop body. */
736 tmp = gfc_finish_block (&body);
738 /* The for loop itself. */
739 tmp = build1_v (LOOP_EXPR, tmp);
740 gfc_add_expr_to_block (&block, tmp);
742 /* Add the exit label. */
743 tmp = build1_v (LABEL_EXPR, exit_label);
744 gfc_add_expr_to_block (&block, tmp);
746 return gfc_finish_block (&block);
750 /* Translate the DO WHILE construct.
763 if (! cond) goto exit_label;
769 Because the evaluation of the exit condition `cond' may have side
770 effects, we can't do much for empty loop bodies. The backend optimizers
771 should be smart enough to eliminate any dead loops. */
774 gfc_trans_do_while (gfc_code * code)
782 /* Everything we build here is part of the loop body. */
783 gfc_start_block (&block);
785 /* Cycle and exit statements are implemented with gotos. */
786 cycle_label = gfc_build_label_decl (NULL_TREE);
787 exit_label = gfc_build_label_decl (NULL_TREE);
789 /* Put the labels where they can be found later. See gfc_trans_do(). */
790 code->block->backend_decl = tree_cons (cycle_label, exit_label, NULL);
792 /* Create a GIMPLE version of the exit condition. */
793 gfc_init_se (&cond, NULL);
794 gfc_conv_expr_val (&cond, code->expr);
795 gfc_add_block_to_block (&block, &cond.pre);
796 cond.expr = fold (build1 (TRUTH_NOT_EXPR, boolean_type_node, cond.expr));
798 /* Build "IF (! cond) GOTO exit_label". */
799 tmp = build1_v (GOTO_EXPR, exit_label);
800 TREE_USED (exit_label) = 1;
801 tmp = build3_v (COND_EXPR, cond.expr, tmp, build_empty_stmt ());
802 gfc_add_expr_to_block (&block, tmp);
804 /* The main body of the loop. */
805 tmp = gfc_trans_code (code->block->next);
806 gfc_add_expr_to_block (&block, tmp);
808 /* Label for cycle statements (if needed). */
809 if (TREE_USED (cycle_label))
811 tmp = build1_v (LABEL_EXPR, cycle_label);
812 gfc_add_expr_to_block (&block, tmp);
815 /* End of loop body. */
816 tmp = gfc_finish_block (&block);
818 gfc_init_block (&block);
819 /* Build the loop. */
820 tmp = build1_v (LOOP_EXPR, tmp);
821 gfc_add_expr_to_block (&block, tmp);
823 /* Add the exit label. */
824 tmp = build1_v (LABEL_EXPR, exit_label);
825 gfc_add_expr_to_block (&block, tmp);
827 return gfc_finish_block (&block);
831 /* Translate the SELECT CASE construct for INTEGER case expressions,
832 without killing all potential optimizations. The problem is that
833 Fortran allows unbounded cases, but the back-end does not, so we
834 need to intercept those before we enter the equivalent SWITCH_EXPR
837 For example, we translate this,
840 CASE (:100,101,105:115)
850 to the GENERIC equivalent,
854 case (minimum value for typeof(expr) ... 100:
860 case 200 ... (maximum value for typeof(expr):
877 gfc_trans_integer_select (gfc_code * code)
887 gfc_start_block (&block);
889 /* Calculate the switch expression. */
890 gfc_init_se (&se, NULL);
891 gfc_conv_expr_val (&se, code->expr);
892 gfc_add_block_to_block (&block, &se.pre);
894 end_label = gfc_build_label_decl (NULL_TREE);
896 gfc_init_block (&body);
898 for (c = code->block; c; c = c->block)
900 for (cp = c->ext.case_list; cp; cp = cp->next)
905 /* Assume it's the default case. */
906 low = high = NULL_TREE;
910 low = gfc_conv_constant_to_tree (cp->low);
912 /* If there's only a lower bound, set the high bound to the
913 maximum value of the case expression. */
915 high = TYPE_MAX_VALUE (TREE_TYPE (se.expr));
920 /* Three cases are possible here:
922 1) There is no lower bound, e.g. CASE (:N).
923 2) There is a lower bound .NE. high bound, that is
924 a case range, e.g. CASE (N:M) where M>N (we make
925 sure that M>N during type resolution).
926 3) There is a lower bound, and it has the same value
927 as the high bound, e.g. CASE (N:N). This is our
928 internal representation of CASE(N).
930 In the first and second case, we need to set a value for
931 high. In the thirth case, we don't because the GCC middle
932 end represents a single case value by just letting high be
933 a NULL_TREE. We can't do that because we need to be able
934 to represent unbounded cases. */
938 && mpz_cmp (cp->low->value.integer,
939 cp->high->value.integer) != 0))
940 high = gfc_conv_constant_to_tree (cp->high);
942 /* Unbounded case. */
944 low = TYPE_MIN_VALUE (TREE_TYPE (se.expr));
948 label = gfc_build_label_decl (NULL_TREE);
950 /* Add this case label.
951 Add parameter 'label', make it match GCC backend. */
952 tmp = build3 (CASE_LABEL_EXPR, void_type_node, low, high, label);
953 gfc_add_expr_to_block (&body, tmp);
956 /* Add the statements for this case. */
957 tmp = gfc_trans_code (c->next);
958 gfc_add_expr_to_block (&body, tmp);
960 /* Break to the end of the construct. */
961 tmp = build1_v (GOTO_EXPR, end_label);
962 gfc_add_expr_to_block (&body, tmp);
965 tmp = gfc_finish_block (&body);
966 tmp = build3_v (SWITCH_EXPR, se.expr, tmp, NULL_TREE);
967 gfc_add_expr_to_block (&block, tmp);
969 tmp = build1_v (LABEL_EXPR, end_label);
970 gfc_add_expr_to_block (&block, tmp);
972 return gfc_finish_block (&block);
976 /* Translate the SELECT CASE construct for LOGICAL case expressions.
978 There are only two cases possible here, even though the standard
979 does allow three cases in a LOGICAL SELECT CASE construct: .TRUE.,
980 .FALSE., and DEFAULT.
982 We never generate more than two blocks here. Instead, we always
983 try to eliminate the DEFAULT case. This way, we can translate this
984 kind of SELECT construct to a simple
988 expression in GENERIC. */
991 gfc_trans_logical_select (gfc_code * code)
999 /* Assume we don't have any cases at all. */
1002 /* Now see which ones we actually do have. We can have at most two
1003 cases in a single case list: one for .TRUE. and one for .FALSE.
1004 The default case is always separate. If the cases for .TRUE. and
1005 .FALSE. are in the same case list, the block for that case list
1006 always executed, and we don't generate code a COND_EXPR. */
1007 for (c = code->block; c; c = c->block)
1009 for (cp = c->ext.case_list; cp; cp = cp->next)
1013 if (cp->low->value.logical == 0) /* .FALSE. */
1015 else /* if (cp->value.logical != 0), thus .TRUE. */
1023 /* Start a new block. */
1024 gfc_start_block (&block);
1026 /* Calculate the switch expression. We always need to do this
1027 because it may have side effects. */
1028 gfc_init_se (&se, NULL);
1029 gfc_conv_expr_val (&se, code->expr);
1030 gfc_add_block_to_block (&block, &se.pre);
1032 if (t == f && t != NULL)
1034 /* Cases for .TRUE. and .FALSE. are in the same block. Just
1035 translate the code for these cases, append it to the current
1037 gfc_add_expr_to_block (&block, gfc_trans_code (t->next));
1041 tree true_tree, false_tree;
1043 true_tree = build_empty_stmt ();
1044 false_tree = build_empty_stmt ();
1046 /* If we have a case for .TRUE. and for .FALSE., discard the default case.
1047 Otherwise, if .TRUE. or .FALSE. is missing and there is a default case,
1048 make the missing case the default case. */
1049 if (t != NULL && f != NULL)
1059 /* Translate the code for each of these blocks, and append it to
1060 the current block. */
1062 true_tree = gfc_trans_code (t->next);
1065 false_tree = gfc_trans_code (f->next);
1067 gfc_add_expr_to_block (&block, build3_v (COND_EXPR, se.expr,
1068 true_tree, false_tree));
1071 return gfc_finish_block (&block);
1075 /* Translate the SELECT CASE construct for CHARACTER case expressions.
1076 Instead of generating compares and jumps, it is far simpler to
1077 generate a data structure describing the cases in order and call a
1078 library subroutine that locates the right case.
1079 This is particularly true because this is the only case where we
1080 might have to dispose of a temporary.
1081 The library subroutine returns a pointer to jump to or NULL if no
1082 branches are to be taken. */
1085 gfc_trans_character_select (gfc_code *code)
1087 tree init, node, end_label, tmp, type, args, *labels;
1088 stmtblock_t block, body;
1094 static tree select_struct;
1095 static tree ss_string1, ss_string1_len;
1096 static tree ss_string2, ss_string2_len;
1097 static tree ss_target;
1099 if (select_struct == NULL)
1101 tree gfc_int4_type_node = gfc_get_int_type (4);
1103 select_struct = make_node (RECORD_TYPE);
1104 TYPE_NAME (select_struct) = get_identifier ("_jump_struct");
1107 #define ADD_FIELD(NAME, TYPE) \
1108 ss_##NAME = gfc_add_field_to_struct \
1109 (&(TYPE_FIELDS (select_struct)), select_struct, \
1110 get_identifier (stringize(NAME)), TYPE)
1112 ADD_FIELD (string1, pchar_type_node);
1113 ADD_FIELD (string1_len, gfc_int4_type_node);
1115 ADD_FIELD (string2, pchar_type_node);
1116 ADD_FIELD (string2_len, gfc_int4_type_node);
1118 ADD_FIELD (target, pvoid_type_node);
1121 gfc_finish_type (select_struct);
1124 cp = code->block->ext.case_list;
1125 while (cp->left != NULL)
1129 for (d = cp; d; d = d->right)
1133 labels = gfc_getmem (n * sizeof (tree));
1137 for(i = 0; i < n; i++)
1139 labels[i] = gfc_build_label_decl (NULL_TREE);
1140 TREE_USED (labels[i]) = 1;
1141 /* TODO: The gimplifier should do this for us, but it has
1142 inadequacies when dealing with static initializers. */
1143 FORCED_LABEL (labels[i]) = 1;
1146 end_label = gfc_build_label_decl (NULL_TREE);
1148 /* Generate the body */
1149 gfc_start_block (&block);
1150 gfc_init_block (&body);
1152 for (c = code->block; c; c = c->block)
1154 for (d = c->ext.case_list; d; d = d->next)
1156 tmp = build1_v (LABEL_EXPR, labels[d->n]);
1157 gfc_add_expr_to_block (&body, tmp);
1160 tmp = gfc_trans_code (c->next);
1161 gfc_add_expr_to_block (&body, tmp);
1163 tmp = build1_v (GOTO_EXPR, end_label);
1164 gfc_add_expr_to_block (&body, tmp);
1167 /* Generate the structure describing the branches */
1171 for(d = cp; d; d = d->right, i++)
1175 gfc_init_se (&se, NULL);
1179 node = tree_cons (ss_string1, null_pointer_node, node);
1180 node = tree_cons (ss_string1_len, integer_zero_node, node);
1184 gfc_conv_expr_reference (&se, d->low);
1186 node = tree_cons (ss_string1, se.expr, node);
1187 node = tree_cons (ss_string1_len, se.string_length, node);
1190 if (d->high == NULL)
1192 node = tree_cons (ss_string2, null_pointer_node, node);
1193 node = tree_cons (ss_string2_len, integer_zero_node, node);
1197 gfc_init_se (&se, NULL);
1198 gfc_conv_expr_reference (&se, d->high);
1200 node = tree_cons (ss_string2, se.expr, node);
1201 node = tree_cons (ss_string2_len, se.string_length, node);
1204 tmp = gfc_build_addr_expr (pvoid_type_node, labels[i]);
1205 node = tree_cons (ss_target, tmp, node);
1207 tmp = build1 (CONSTRUCTOR, select_struct, nreverse (node));
1208 init = tree_cons (NULL_TREE, tmp, init);
1211 type = build_array_type (select_struct, build_index_type
1212 (build_int_cst (NULL_TREE, n - 1)));
1214 init = build1 (CONSTRUCTOR, type, nreverse(init));
1215 TREE_CONSTANT (init) = 1;
1216 TREE_INVARIANT (init) = 1;
1217 TREE_STATIC (init) = 1;
1218 /* Create a static variable to hold the jump table. */
1219 tmp = gfc_create_var (type, "jumptable");
1220 TREE_CONSTANT (tmp) = 1;
1221 TREE_INVARIANT (tmp) = 1;
1222 TREE_STATIC (tmp) = 1;
1223 DECL_INITIAL (tmp) = init;
1226 /* Build an argument list for the library call */
1227 init = gfc_build_addr_expr (pvoid_type_node, init);
1228 args = gfc_chainon_list (NULL_TREE, init);
1230 tmp = build_int_cst (NULL_TREE, n);
1231 args = gfc_chainon_list (args, tmp);
1233 tmp = gfc_build_addr_expr (pvoid_type_node, end_label);
1234 args = gfc_chainon_list (args, tmp);
1236 gfc_init_se (&se, NULL);
1237 gfc_conv_expr_reference (&se, code->expr);
1239 args = gfc_chainon_list (args, se.expr);
1240 args = gfc_chainon_list (args, se.string_length);
1242 gfc_add_block_to_block (&block, &se.pre);
1244 tmp = gfc_build_function_call (gfor_fndecl_select_string, args);
1245 tmp = build1 (GOTO_EXPR, void_type_node, tmp);
1246 gfc_add_expr_to_block (&block, tmp);
1248 tmp = gfc_finish_block (&body);
1249 gfc_add_expr_to_block (&block, tmp);
1250 tmp = build1_v (LABEL_EXPR, end_label);
1251 gfc_add_expr_to_block (&block, tmp);
1256 return gfc_finish_block (&block);
1260 /* Translate the three variants of the SELECT CASE construct.
1262 SELECT CASEs with INTEGER case expressions can be translated to an
1263 equivalent GENERIC switch statement, and for LOGICAL case
1264 expressions we build one or two if-else compares.
1266 SELECT CASEs with CHARACTER case expressions are a whole different
1267 story, because they don't exist in GENERIC. So we sort them and
1268 do a binary search at runtime.
1270 Fortran has no BREAK statement, and it does not allow jumps from
1271 one case block to another. That makes things a lot easier for
1275 gfc_trans_select (gfc_code * code)
1277 gcc_assert (code && code->expr);
1279 /* Empty SELECT constructs are legal. */
1280 if (code->block == NULL)
1281 return build_empty_stmt ();
1283 /* Select the correct translation function. */
1284 switch (code->expr->ts.type)
1286 case BT_LOGICAL: return gfc_trans_logical_select (code);
1287 case BT_INTEGER: return gfc_trans_integer_select (code);
1288 case BT_CHARACTER: return gfc_trans_character_select (code);
1290 gfc_internal_error ("gfc_trans_select(): Bad type for case expr.");
1296 /* Generate the loops for a FORALL block. The normal loop format:
1297 count = (end - start + step) / step
1310 gfc_trans_forall_loop (forall_info *forall_tmp, int nvar, tree body, int mask_flag)
1318 tree var, start, end, step, mask, maskindex;
1321 iter = forall_tmp->this_loop;
1322 for (n = 0; n < nvar; n++)
1325 start = iter->start;
1329 exit_label = gfc_build_label_decl (NULL_TREE);
1330 TREE_USED (exit_label) = 1;
1332 /* The loop counter. */
1333 count = gfc_create_var (TREE_TYPE (var), "count");
1335 /* The body of the loop. */
1336 gfc_init_block (&block);
1338 /* The exit condition. */
1339 cond = build2 (LE_EXPR, boolean_type_node, count, integer_zero_node);
1340 tmp = build1_v (GOTO_EXPR, exit_label);
1341 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
1342 gfc_add_expr_to_block (&block, tmp);
1344 /* The main loop body. */
1345 gfc_add_expr_to_block (&block, body);
1347 /* Increment the loop variable. */
1348 tmp = build2 (PLUS_EXPR, TREE_TYPE (var), var, step);
1349 gfc_add_modify_expr (&block, var, tmp);
1351 /* Advance to the next mask element. */
1354 mask = forall_tmp->mask;
1355 maskindex = forall_tmp->maskindex;
1358 tmp = build2 (PLUS_EXPR, gfc_array_index_type,
1359 maskindex, gfc_index_one_node);
1360 gfc_add_modify_expr (&block, maskindex, tmp);
1363 /* Decrement the loop counter. */
1364 tmp = build2 (MINUS_EXPR, TREE_TYPE (var), count, gfc_index_one_node);
1365 gfc_add_modify_expr (&block, count, tmp);
1367 body = gfc_finish_block (&block);
1369 /* Loop var initialization. */
1370 gfc_init_block (&block);
1371 gfc_add_modify_expr (&block, var, start);
1373 /* Initialize the loop counter. */
1374 tmp = fold (build2 (MINUS_EXPR, TREE_TYPE (var), step, start));
1375 tmp = fold (build2 (PLUS_EXPR, TREE_TYPE (var), end, tmp));
1376 tmp = fold (build2 (TRUNC_DIV_EXPR, TREE_TYPE (var), tmp, step));
1377 gfc_add_modify_expr (&block, count, tmp);
1379 /* The loop expression. */
1380 tmp = build1_v (LOOP_EXPR, body);
1381 gfc_add_expr_to_block (&block, tmp);
1383 /* The exit label. */
1384 tmp = build1_v (LABEL_EXPR, exit_label);
1385 gfc_add_expr_to_block (&block, tmp);
1387 body = gfc_finish_block (&block);
1394 /* Generate the body and loops according to MASK_FLAG and NEST_FLAG.
1395 if MASK_FLAG is nonzero, the body is controlled by maskes in forall
1396 nest, otherwise, the body is not controlled by maskes.
1397 if NEST_FLAG is nonzero, generate loops for nested forall, otherwise,
1398 only generate loops for the current forall level. */
1401 gfc_trans_nested_forall_loop (forall_info * nested_forall_info, tree body,
1402 int mask_flag, int nest_flag)
1406 forall_info *forall_tmp;
1407 tree pmask, mask, maskindex;
1409 forall_tmp = nested_forall_info;
1410 /* Generate loops for nested forall. */
1413 while (forall_tmp->next_nest != NULL)
1414 forall_tmp = forall_tmp->next_nest;
1415 while (forall_tmp != NULL)
1417 /* Generate body with masks' control. */
1420 pmask = forall_tmp->pmask;
1421 mask = forall_tmp->mask;
1422 maskindex = forall_tmp->maskindex;
1426 /* If a mask was specified make the assignment conditional. */
1428 tmp = gfc_build_indirect_ref (mask);
1431 tmp = gfc_build_array_ref (tmp, maskindex);
1433 body = build3_v (COND_EXPR, tmp, body, build_empty_stmt ());
1436 nvar = forall_tmp->nvar;
1437 body = gfc_trans_forall_loop (forall_tmp, nvar, body, mask_flag);
1438 forall_tmp = forall_tmp->outer;
1443 nvar = forall_tmp->nvar;
1444 body = gfc_trans_forall_loop (forall_tmp, nvar, body, mask_flag);
1451 /* Allocate data for holding a temporary array. Returns either a local
1452 temporary array or a pointer variable. */
1455 gfc_do_allocate (tree bytesize, tree size, tree * pdata, stmtblock_t * pblock,
1463 if (INTEGER_CST_P (size))
1465 tmp = fold (build2 (MINUS_EXPR, gfc_array_index_type, size,
1466 gfc_index_one_node));
1471 type = build_range_type (gfc_array_index_type, gfc_index_zero_node, tmp);
1472 type = build_array_type (elem_type, type);
1473 if (gfc_can_put_var_on_stack (bytesize))
1475 gcc_assert (INTEGER_CST_P (size));
1476 tmpvar = gfc_create_var (type, "temp");
1481 tmpvar = gfc_create_var (build_pointer_type (type), "temp");
1482 *pdata = convert (pvoid_type_node, tmpvar);
1484 args = gfc_chainon_list (NULL_TREE, bytesize);
1485 if (gfc_index_integer_kind == 4)
1486 tmp = gfor_fndecl_internal_malloc;
1487 else if (gfc_index_integer_kind == 8)
1488 tmp = gfor_fndecl_internal_malloc64;
1491 tmp = gfc_build_function_call (tmp, args);
1492 tmp = convert (TREE_TYPE (tmpvar), tmp);
1493 gfc_add_modify_expr (pblock, tmpvar, tmp);
1499 /* Generate codes to copy the temporary to the actual lhs. */
1502 generate_loop_for_temp_to_lhs (gfc_expr *expr, tree tmp1, tree size,
1503 tree count3, tree count1, tree count2, tree wheremask)
1507 stmtblock_t block, body;
1514 lss = gfc_walk_expr (expr);
1516 if (lss == gfc_ss_terminator)
1518 gfc_start_block (&block);
1520 gfc_init_se (&lse, NULL);
1522 /* Translate the expression. */
1523 gfc_conv_expr (&lse, expr);
1525 /* Form the expression for the temporary. */
1526 tmp = gfc_build_array_ref (tmp1, count1);
1528 /* Use the scalar assignment as is. */
1529 gfc_add_block_to_block (&block, &lse.pre);
1530 gfc_add_modify_expr (&block, lse.expr, tmp);
1531 gfc_add_block_to_block (&block, &lse.post);
1533 /* Increment the count1. */
1534 tmp = fold (build2 (PLUS_EXPR, TREE_TYPE (count1), count1, size));
1535 gfc_add_modify_expr (&block, count1, tmp);
1536 tmp = gfc_finish_block (&block);
1540 gfc_start_block (&block);
1542 gfc_init_loopinfo (&loop1);
1543 gfc_init_se (&rse, NULL);
1544 gfc_init_se (&lse, NULL);
1546 /* Associate the lss with the loop. */
1547 gfc_add_ss_to_loop (&loop1, lss);
1549 /* Calculate the bounds of the scalarization. */
1550 gfc_conv_ss_startstride (&loop1);
1551 /* Setup the scalarizing loops. */
1552 gfc_conv_loop_setup (&loop1);
1554 gfc_mark_ss_chain_used (lss, 1);
1555 /* Initialize count2. */
1556 gfc_add_modify_expr (&block, count2, gfc_index_zero_node);
1558 /* Start the scalarized loop body. */
1559 gfc_start_scalarized_body (&loop1, &body);
1561 /* Setup the gfc_se structures. */
1562 gfc_copy_loopinfo_to_se (&lse, &loop1);
1565 /* Form the expression of the temporary. */
1566 if (lss != gfc_ss_terminator)
1568 index = fold (build2 (PLUS_EXPR, gfc_array_index_type,
1570 rse.expr = gfc_build_array_ref (tmp1, index);
1572 /* Translate expr. */
1573 gfc_conv_expr (&lse, expr);
1575 /* Use the scalar assignment. */
1576 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts.type);
1578 /* Form the mask expression according to the mask tree list. */
1581 wheremaskexpr = gfc_build_array_ref (wheremask, count3);
1582 tmp2 = TREE_CHAIN (wheremask);
1585 tmp1 = gfc_build_array_ref (tmp2, count3);
1586 wheremaskexpr = build2 (TRUTH_AND_EXPR, TREE_TYPE (tmp1),
1587 wheremaskexpr, tmp1);
1588 tmp2 = TREE_CHAIN (tmp2);
1590 tmp = build3_v (COND_EXPR, wheremaskexpr, tmp, build_empty_stmt ());
1593 gfc_add_expr_to_block (&body, tmp);
1595 /* Increment count2. */
1596 tmp = fold (build2 (PLUS_EXPR, gfc_array_index_type,
1597 count2, gfc_index_one_node));
1598 gfc_add_modify_expr (&body, count2, tmp);
1600 /* Increment count3. */
1603 tmp = fold (build2 (PLUS_EXPR, gfc_array_index_type,
1604 count3, gfc_index_one_node));
1605 gfc_add_modify_expr (&body, count3, tmp);
1608 /* Generate the copying loops. */
1609 gfc_trans_scalarizing_loops (&loop1, &body);
1610 gfc_add_block_to_block (&block, &loop1.pre);
1611 gfc_add_block_to_block (&block, &loop1.post);
1612 gfc_cleanup_loop (&loop1);
1614 /* Increment count1. */
1615 tmp = fold (build2 (PLUS_EXPR, TREE_TYPE (count1), count1, size));
1616 gfc_add_modify_expr (&block, count1, tmp);
1617 tmp = gfc_finish_block (&block);
1623 /* Generate codes to copy rhs to the temporary. TMP1 is the address of temporary
1624 LSS and RSS are formed in function compute_inner_temp_size(), and should
1628 generate_loop_for_rhs_to_temp (gfc_expr *expr2, tree tmp1, tree size,
1629 tree count3, tree count1, tree count2,
1630 gfc_ss *lss, gfc_ss *rss, tree wheremask)
1632 stmtblock_t block, body1;
1636 tree tmp, tmp2, index;
1639 gfc_start_block (&block);
1641 gfc_init_se (&rse, NULL);
1642 gfc_init_se (&lse, NULL);
1644 if (lss == gfc_ss_terminator)
1646 gfc_init_block (&body1);
1647 gfc_conv_expr (&rse, expr2);
1648 lse.expr = gfc_build_array_ref (tmp1, count1);
1652 /* Initialize count2. */
1653 gfc_add_modify_expr (&block, count2, gfc_index_zero_node);
1655 /* Initialize the loop. */
1656 gfc_init_loopinfo (&loop);
1658 /* We may need LSS to determine the shape of the expression. */
1659 gfc_add_ss_to_loop (&loop, lss);
1660 gfc_add_ss_to_loop (&loop, rss);
1662 gfc_conv_ss_startstride (&loop);
1663 gfc_conv_loop_setup (&loop);
1665 gfc_mark_ss_chain_used (rss, 1);
1666 /* Start the loop body. */
1667 gfc_start_scalarized_body (&loop, &body1);
1669 /* Translate the expression. */
1670 gfc_copy_loopinfo_to_se (&rse, &loop);
1672 gfc_conv_expr (&rse, expr2);
1674 /* Form the expression of the temporary. */
1675 index = fold (build2 (PLUS_EXPR, gfc_array_index_type, count1, count2));
1676 lse.expr = gfc_build_array_ref (tmp1, index);
1679 /* Use the scalar assignment. */
1680 tmp = gfc_trans_scalar_assign (&lse, &rse, expr2->ts.type);
1682 /* Form the mask expression according to the mask tree list. */
1685 wheremaskexpr = gfc_build_array_ref (wheremask, count3);
1686 tmp2 = TREE_CHAIN (wheremask);
1689 tmp1 = gfc_build_array_ref (tmp2, count3);
1690 wheremaskexpr = build2 (TRUTH_AND_EXPR, TREE_TYPE (tmp1),
1691 wheremaskexpr, tmp1);
1692 tmp2 = TREE_CHAIN (tmp2);
1694 tmp = build3_v (COND_EXPR, wheremaskexpr, tmp, build_empty_stmt ());
1697 gfc_add_expr_to_block (&body1, tmp);
1699 if (lss == gfc_ss_terminator)
1701 gfc_add_block_to_block (&block, &body1);
1705 /* Increment count2. */
1706 tmp = fold (build2 (PLUS_EXPR, gfc_array_index_type,
1707 count2, gfc_index_one_node));
1708 gfc_add_modify_expr (&body1, count2, tmp);
1710 /* Increment count3. */
1713 tmp = fold (build2 (PLUS_EXPR, gfc_array_index_type,
1714 count3, gfc_index_one_node));
1715 gfc_add_modify_expr (&body1, count3, tmp);
1718 /* Generate the copying loops. */
1719 gfc_trans_scalarizing_loops (&loop, &body1);
1721 gfc_add_block_to_block (&block, &loop.pre);
1722 gfc_add_block_to_block (&block, &loop.post);
1724 gfc_cleanup_loop (&loop);
1725 /* TODO: Reuse lss and rss when copying temp->lhs. Need to be careful
1726 as tree nodes in SS may not be valid in different scope. */
1728 /* Increment count1. */
1729 tmp = fold (build2 (PLUS_EXPR, TREE_TYPE (count1), count1, size));
1730 gfc_add_modify_expr (&block, count1, tmp);
1732 tmp = gfc_finish_block (&block);
1737 /* Calculate the size of temporary needed in the assignment inside forall.
1738 LSS and RSS are filled in this function. */
1741 compute_inner_temp_size (gfc_expr *expr1, gfc_expr *expr2,
1742 stmtblock_t * pblock,
1743 gfc_ss **lss, gfc_ss **rss)
1750 *lss = gfc_walk_expr (expr1);
1753 size = gfc_index_one_node;
1754 if (*lss != gfc_ss_terminator)
1756 gfc_init_loopinfo (&loop);
1758 /* Walk the RHS of the expression. */
1759 *rss = gfc_walk_expr (expr2);
1760 if (*rss == gfc_ss_terminator)
1762 /* The rhs is scalar. Add a ss for the expression. */
1763 *rss = gfc_get_ss ();
1764 (*rss)->next = gfc_ss_terminator;
1765 (*rss)->type = GFC_SS_SCALAR;
1766 (*rss)->expr = expr2;
1769 /* Associate the SS with the loop. */
1770 gfc_add_ss_to_loop (&loop, *lss);
1771 /* We don't actually need to add the rhs at this point, but it might
1772 make guessing the loop bounds a bit easier. */
1773 gfc_add_ss_to_loop (&loop, *rss);
1775 /* We only want the shape of the expression, not rest of the junk
1776 generated by the scalarizer. */
1777 loop.array_parameter = 1;
1779 /* Calculate the bounds of the scalarization. */
1780 gfc_conv_ss_startstride (&loop);
1781 gfc_conv_loop_setup (&loop);
1783 /* Figure out how many elements we need. */
1784 for (i = 0; i < loop.dimen; i++)
1786 tmp = fold (build2 (MINUS_EXPR, gfc_array_index_type,
1787 gfc_index_one_node, loop.from[i]));
1788 tmp = fold (build2 (PLUS_EXPR, gfc_array_index_type,
1790 size = fold (build2 (MULT_EXPR, gfc_array_index_type, size, tmp));
1792 gfc_add_block_to_block (pblock, &loop.pre);
1793 size = gfc_evaluate_now (size, pblock);
1794 gfc_add_block_to_block (pblock, &loop.post);
1796 /* TODO: write a function that cleans up a loopinfo without freeing
1797 the SS chains. Currently a NOP. */
1804 /* Calculate the overall iterator number of the nested forall construct. */
1807 compute_overall_iter_number (forall_info *nested_forall_info, tree inner_size,
1813 /* TODO: optimizing the computing process. */
1814 number = gfc_create_var (gfc_array_index_type, "num");
1815 gfc_add_modify_expr (block, number, gfc_index_zero_node);
1817 gfc_start_block (&body);
1818 if (nested_forall_info)
1819 tmp = build2 (PLUS_EXPR, gfc_array_index_type, number,
1823 gfc_add_modify_expr (&body, number, tmp);
1824 tmp = gfc_finish_block (&body);
1826 /* Generate loops. */
1827 if (nested_forall_info != NULL)
1828 tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 0, 1);
1830 gfc_add_expr_to_block (block, tmp);
1836 /* Allocate temporary for forall construct according to the information in
1837 nested_forall_info. INNER_SIZE is the size of temporary needed in the
1838 assignment inside forall. PTEMP1 is returned for space free. */
1841 allocate_temp_for_forall_nest (forall_info * nested_forall_info, tree type,
1842 tree inner_size, stmtblock_t * block,
1848 tree bytesize, size;
1850 /* Calculate the total size of temporary needed in forall construct. */
1851 size = compute_overall_iter_number (nested_forall_info, inner_size, block);
1853 unit = TYPE_SIZE_UNIT (type);
1854 bytesize = fold (build2 (MULT_EXPR, gfc_array_index_type, size, unit));
1857 temp1 = gfc_do_allocate (bytesize, size, ptemp1, block, type);
1860 tmp = gfc_build_indirect_ref (temp1);
1868 /* Handle assignments inside forall which need temporary. */
1870 gfc_trans_assign_need_temp (gfc_expr * expr1, gfc_expr * expr2, tree wheremask,
1871 forall_info * nested_forall_info,
1872 stmtblock_t * block)
1877 tree count, count1, count2;
1880 tree mask, maskindex;
1881 forall_info *forall_tmp;
1883 /* Create vars. count1 is the current iterator number of the nested forall.
1884 count2 is the current iterator number of the inner loops needed in the
1886 count1 = gfc_create_var (gfc_array_index_type, "count1");
1887 count2 = gfc_create_var (gfc_array_index_type, "count2");
1889 /* Count is the wheremask index. */
1892 count = gfc_create_var (gfc_array_index_type, "count");
1893 gfc_add_modify_expr (block, count, gfc_index_zero_node);
1898 /* Initialize count1. */
1899 gfc_add_modify_expr (block, count1, gfc_index_zero_node);
1901 /* Calculate the size of temporary needed in the assignment. Return loop, lss
1902 and rss which are used in function generate_loop_for_rhs_to_temp(). */
1903 inner_size = compute_inner_temp_size (expr1, expr2, block, &lss, &rss);
1905 /* The type of LHS. Used in function allocate_temp_for_forall_nest */
1906 type = gfc_typenode_for_spec (&expr1->ts);
1908 /* Allocate temporary for nested forall construct according to the
1909 information in nested_forall_info and inner_size. */
1910 tmp1 = allocate_temp_for_forall_nest (nested_forall_info, type,
1911 inner_size, block, &ptemp1);
1913 /* Initialize the maskindexes. */
1914 forall_tmp = nested_forall_info;
1915 while (forall_tmp != NULL)
1917 mask = forall_tmp->mask;
1918 maskindex = forall_tmp->maskindex;
1920 gfc_add_modify_expr (block, maskindex, gfc_index_zero_node);
1921 forall_tmp = forall_tmp->next_nest;
1924 /* Generate codes to copy rhs to the temporary . */
1925 tmp = generate_loop_for_rhs_to_temp (expr2, tmp1, inner_size, count,
1926 count1, count2, lss, rss, wheremask);
1928 /* Generate body and loops according to the information in
1929 nested_forall_info. */
1930 tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1, 1);
1931 gfc_add_expr_to_block (block, tmp);
1934 gfc_add_modify_expr (block, count1, gfc_index_zero_node);
1936 /* Reset maskindexed. */
1937 forall_tmp = nested_forall_info;
1938 while (forall_tmp != NULL)
1940 mask = forall_tmp->mask;
1941 maskindex = forall_tmp->maskindex;
1943 gfc_add_modify_expr (block, maskindex, gfc_index_zero_node);
1944 forall_tmp = forall_tmp->next_nest;
1949 gfc_add_modify_expr (block, count, gfc_index_zero_node);
1951 /* Generate codes to copy the temporary to lhs. */
1952 tmp = generate_loop_for_temp_to_lhs (expr1, tmp1, inner_size, count,
1953 count1, count2, wheremask);
1955 /* Generate body and loops according to the information in
1956 nested_forall_info. */
1957 tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1, 1);
1958 gfc_add_expr_to_block (block, tmp);
1962 /* Free the temporary. */
1963 tmp = gfc_chainon_list (NULL_TREE, ptemp1);
1964 tmp = gfc_build_function_call (gfor_fndecl_internal_free, tmp);
1965 gfc_add_expr_to_block (block, tmp);
1970 /* Translate pointer assignment inside FORALL which need temporary. */
1973 gfc_trans_pointer_assign_need_temp (gfc_expr * expr1, gfc_expr * expr2,
1974 forall_info * nested_forall_info,
1975 stmtblock_t * block)
1989 tree tmp, tmp1, ptemp1;
1990 tree mask, maskindex;
1991 forall_info *forall_tmp;
1993 count = gfc_create_var (gfc_array_index_type, "count");
1994 gfc_add_modify_expr (block, count, gfc_index_zero_node);
1996 inner_size = integer_one_node;
1997 lss = gfc_walk_expr (expr1);
1998 rss = gfc_walk_expr (expr2);
1999 if (lss == gfc_ss_terminator)
2001 type = gfc_typenode_for_spec (&expr1->ts);
2002 type = build_pointer_type (type);
2004 /* Allocate temporary for nested forall construct according to the
2005 information in nested_forall_info and inner_size. */
2006 tmp1 = allocate_temp_for_forall_nest (nested_forall_info,
2007 type, inner_size, block, &ptemp1);
2008 gfc_start_block (&body);
2009 gfc_init_se (&lse, NULL);
2010 lse.expr = gfc_build_array_ref (tmp1, count);
2011 gfc_init_se (&rse, NULL);
2012 rse.want_pointer = 1;
2013 gfc_conv_expr (&rse, expr2);
2014 gfc_add_block_to_block (&body, &rse.pre);
2015 gfc_add_modify_expr (&body, lse.expr, rse.expr);
2016 gfc_add_block_to_block (&body, &rse.post);
2018 /* Increment count. */
2019 tmp = fold (build2 (PLUS_EXPR, gfc_array_index_type,
2020 count, gfc_index_one_node));
2021 gfc_add_modify_expr (&body, count, tmp);
2023 tmp = gfc_finish_block (&body);
2025 /* Initialize the maskindexes. */
2026 forall_tmp = nested_forall_info;
2027 while (forall_tmp != NULL)
2029 mask = forall_tmp->mask;
2030 maskindex = forall_tmp->maskindex;
2032 gfc_add_modify_expr (block, maskindex, gfc_index_zero_node);
2033 forall_tmp = forall_tmp->next_nest;
2036 /* Generate body and loops according to the information in
2037 nested_forall_info. */
2038 tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1, 1);
2039 gfc_add_expr_to_block (block, tmp);
2042 gfc_add_modify_expr (block, count, gfc_index_zero_node);
2044 /* Reset maskindexes. */
2045 forall_tmp = nested_forall_info;
2046 while (forall_tmp != NULL)
2048 mask = forall_tmp->mask;
2049 maskindex = forall_tmp->maskindex;
2051 gfc_add_modify_expr (block, maskindex, gfc_index_zero_node);
2052 forall_tmp = forall_tmp->next_nest;
2054 gfc_start_block (&body);
2055 gfc_init_se (&lse, NULL);
2056 gfc_init_se (&rse, NULL);
2057 rse.expr = gfc_build_array_ref (tmp1, count);
2058 lse.want_pointer = 1;
2059 gfc_conv_expr (&lse, expr1);
2060 gfc_add_block_to_block (&body, &lse.pre);
2061 gfc_add_modify_expr (&body, lse.expr, rse.expr);
2062 gfc_add_block_to_block (&body, &lse.post);
2063 /* Increment count. */
2064 tmp = fold (build2 (PLUS_EXPR, gfc_array_index_type,
2065 count, gfc_index_one_node));
2066 gfc_add_modify_expr (&body, count, tmp);
2067 tmp = gfc_finish_block (&body);
2069 /* Generate body and loops according to the information in
2070 nested_forall_info. */
2071 tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1, 1);
2072 gfc_add_expr_to_block (block, tmp);
2076 gfc_init_loopinfo (&loop);
2078 /* Associate the SS with the loop. */
2079 gfc_add_ss_to_loop (&loop, rss);
2081 /* Setup the scalarizing loops and bounds. */
2082 gfc_conv_ss_startstride (&loop);
2084 gfc_conv_loop_setup (&loop);
2086 info = &rss->data.info;
2087 desc = info->descriptor;
2089 /* Make a new descriptor. */
2090 parmtype = gfc_get_element_type (TREE_TYPE (desc));
2091 parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen,
2092 loop.from, loop.to, 1);
2094 /* Allocate temporary for nested forall construct. */
2095 tmp1 = allocate_temp_for_forall_nest (nested_forall_info, parmtype,
2096 inner_size, block, &ptemp1);
2097 gfc_start_block (&body);
2098 gfc_init_se (&lse, NULL);
2099 lse.expr = gfc_build_array_ref (tmp1, count);
2100 lse.direct_byref = 1;
2101 rss = gfc_walk_expr (expr2);
2102 gfc_conv_expr_descriptor (&lse, expr2, rss);
2104 gfc_add_block_to_block (&body, &lse.pre);
2105 gfc_add_block_to_block (&body, &lse.post);
2107 /* Increment count. */
2108 tmp = fold (build2 (PLUS_EXPR, gfc_array_index_type,
2109 count, gfc_index_one_node));
2110 gfc_add_modify_expr (&body, count, tmp);
2112 tmp = gfc_finish_block (&body);
2114 /* Initialize the maskindexes. */
2115 forall_tmp = nested_forall_info;
2116 while (forall_tmp != NULL)
2118 mask = forall_tmp->mask;
2119 maskindex = forall_tmp->maskindex;
2121 gfc_add_modify_expr (block, maskindex, gfc_index_zero_node);
2122 forall_tmp = forall_tmp->next_nest;
2125 /* Generate body and loops according to the information in
2126 nested_forall_info. */
2127 tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1, 1);
2128 gfc_add_expr_to_block (block, tmp);
2131 gfc_add_modify_expr (block, count, gfc_index_zero_node);
2133 /* Reset maskindexes. */
2134 forall_tmp = nested_forall_info;
2135 while (forall_tmp != NULL)
2137 mask = forall_tmp->mask;
2138 maskindex = forall_tmp->maskindex;
2140 gfc_add_modify_expr (block, maskindex, gfc_index_zero_node);
2141 forall_tmp = forall_tmp->next_nest;
2143 parm = gfc_build_array_ref (tmp1, count);
2144 lss = gfc_walk_expr (expr1);
2145 gfc_init_se (&lse, NULL);
2146 gfc_conv_expr_descriptor (&lse, expr1, lss);
2147 gfc_add_modify_expr (&lse.pre, lse.expr, parm);
2148 gfc_start_block (&body);
2149 gfc_add_block_to_block (&body, &lse.pre);
2150 gfc_add_block_to_block (&body, &lse.post);
2152 /* Increment count. */
2153 tmp = fold (build2 (PLUS_EXPR, gfc_array_index_type,
2154 count, gfc_index_one_node));
2155 gfc_add_modify_expr (&body, count, tmp);
2157 tmp = gfc_finish_block (&body);
2159 tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1, 1);
2160 gfc_add_expr_to_block (block, tmp);
2162 /* Free the temporary. */
2165 tmp = gfc_chainon_list (NULL_TREE, ptemp1);
2166 tmp = gfc_build_function_call (gfor_fndecl_internal_free, tmp);
2167 gfc_add_expr_to_block (block, tmp);
2172 /* FORALL and WHERE statements are really nasty, especially when you nest
2173 them. All the rhs of a forall assignment must be evaluated before the
2174 actual assignments are performed. Presumably this also applies to all the
2175 assignments in an inner where statement. */
2177 /* Generate code for a FORALL statement. Any temporaries are allocated as a
2178 linear array, relying on the fact that we process in the same order in all
2181 forall (i=start:end:stride; maskexpr)
2185 (where e,f,g,h<i> are arbitrary expressions possibly involving i)
2187 count = ((end + 1 - start) / staride)
2188 masktmp(:) = maskexpr(:)
2191 for (i = start; i <= end; i += stride)
2193 if (masktmp[maskindex++])
2197 for (i = start; i <= end; i += stride)
2199 if (masktmp[maskindex++])
2203 Note that this code only works when there are no dependencies.
2204 Forall loop with array assignments and data dependencies are a real pain,
2205 because the size of the temporary cannot always be determined before the
2206 loop is executed. This problem is compounded by the presence of nested
2211 gfc_trans_forall_1 (gfc_code * code, forall_info * nested_forall_info)
2233 gfc_forall_iterator *fa;
2236 gfc_saved_var *saved_vars;
2237 iter_info *this_forall, *iter_tmp;
2238 forall_info *info, *forall_tmp;
2239 temporary_list *temp;
2241 gfc_start_block (&block);
2244 /* Count the FORALL index number. */
2245 for (fa = code->ext.forall_iterator; fa; fa = fa->next)
2249 /* Allocate the space for var, start, end, step, varexpr. */
2250 var = (tree *) gfc_getmem (nvar * sizeof (tree));
2251 start = (tree *) gfc_getmem (nvar * sizeof (tree));
2252 end = (tree *) gfc_getmem (nvar * sizeof (tree));
2253 step = (tree *) gfc_getmem (nvar * sizeof (tree));
2254 varexpr = (gfc_expr **) gfc_getmem (nvar * sizeof (gfc_expr *));
2255 saved_vars = (gfc_saved_var *) gfc_getmem (nvar * sizeof (gfc_saved_var));
2257 /* Allocate the space for info. */
2258 info = (forall_info *) gfc_getmem (sizeof (forall_info));
2260 for (fa = code->ext.forall_iterator; fa; fa = fa->next)
2262 gfc_symbol *sym = fa->var->symtree->n.sym;
2264 /* allocate space for this_forall. */
2265 this_forall = (iter_info *) gfc_getmem (sizeof (iter_info));
2267 /* Create a temporary variable for the FORALL index. */
2268 tmp = gfc_typenode_for_spec (&sym->ts);
2269 var[n] = gfc_create_var (tmp, sym->name);
2270 gfc_shadow_sym (sym, var[n], &saved_vars[n]);
2272 /* Record it in this_forall. */
2273 this_forall->var = var[n];
2275 /* Replace the index symbol's backend_decl with the temporary decl. */
2276 sym->backend_decl = var[n];
2278 /* Work out the start, end and stride for the loop. */
2279 gfc_init_se (&se, NULL);
2280 gfc_conv_expr_val (&se, fa->start);
2281 /* Record it in this_forall. */
2282 this_forall->start = se.expr;
2283 gfc_add_block_to_block (&block, &se.pre);
2286 gfc_init_se (&se, NULL);
2287 gfc_conv_expr_val (&se, fa->end);
2288 /* Record it in this_forall. */
2289 this_forall->end = se.expr;
2290 gfc_make_safe_expr (&se);
2291 gfc_add_block_to_block (&block, &se.pre);
2294 gfc_init_se (&se, NULL);
2295 gfc_conv_expr_val (&se, fa->stride);
2296 /* Record it in this_forall. */
2297 this_forall->step = se.expr;
2298 gfc_make_safe_expr (&se);
2299 gfc_add_block_to_block (&block, &se.pre);
2302 /* Set the NEXT field of this_forall to NULL. */
2303 this_forall->next = NULL;
2304 /* Link this_forall to the info construct. */
2305 if (info->this_loop == NULL)
2306 info->this_loop = this_forall;
2309 iter_tmp = info->this_loop;
2310 while (iter_tmp->next != NULL)
2311 iter_tmp = iter_tmp->next;
2312 iter_tmp->next = this_forall;
2319 /* Work out the number of elements in the mask array. */
2322 size = gfc_index_one_node;
2323 sizevar = NULL_TREE;
2325 for (n = 0; n < nvar; n++)
2327 if (lenvar && TREE_TYPE (lenvar) != TREE_TYPE (start[n]))
2330 /* size = (end + step - start) / step. */
2331 tmp = fold (build2 (MINUS_EXPR, TREE_TYPE (start[n]),
2332 step[n], start[n]));
2333 tmp = fold (build2 (PLUS_EXPR, TREE_TYPE (end[n]), end[n], tmp));
2335 tmp = fold (build2 (FLOOR_DIV_EXPR, TREE_TYPE (tmp), tmp, step[n]));
2336 tmp = convert (gfc_array_index_type, tmp);
2338 size = fold (build2 (MULT_EXPR, gfc_array_index_type, size, tmp));
2341 /* Record the nvar and size of current forall level. */
2345 /* Link the current forall level to nested_forall_info. */
2346 forall_tmp = nested_forall_info;
2347 if (forall_tmp == NULL)
2348 nested_forall_info = info;
2351 while (forall_tmp->next_nest != NULL)
2352 forall_tmp = forall_tmp->next_nest;
2353 info->outer = forall_tmp;
2354 forall_tmp->next_nest = info;
2357 /* Copy the mask into a temporary variable if required.
2358 For now we assume a mask temporary is needed. */
2361 /* Allocate the mask temporary. */
2362 bytesize = fold (build2 (MULT_EXPR, gfc_array_index_type, size,
2363 TYPE_SIZE_UNIT (boolean_type_node)));
2365 mask = gfc_do_allocate (bytesize, size, &pmask, &block, boolean_type_node);
2367 maskindex = gfc_create_var_np (gfc_array_index_type, "mi");
2368 /* Record them in the info structure. */
2369 info->pmask = pmask;
2371 info->maskindex = maskindex;
2373 gfc_add_modify_expr (&block, maskindex, gfc_index_zero_node);
2375 /* Start of mask assignment loop body. */
2376 gfc_start_block (&body);
2378 /* Evaluate the mask expression. */
2379 gfc_init_se (&se, NULL);
2380 gfc_conv_expr_val (&se, code->expr);
2381 gfc_add_block_to_block (&body, &se.pre);
2383 /* Store the mask. */
2384 se.expr = convert (boolean_type_node, se.expr);
2387 tmp = gfc_build_indirect_ref (mask);
2390 tmp = gfc_build_array_ref (tmp, maskindex);
2391 gfc_add_modify_expr (&body, tmp, se.expr);
2393 /* Advance to the next mask element. */
2394 tmp = build2 (PLUS_EXPR, gfc_array_index_type,
2395 maskindex, gfc_index_one_node);
2396 gfc_add_modify_expr (&body, maskindex, tmp);
2398 /* Generate the loops. */
2399 tmp = gfc_finish_block (&body);
2400 tmp = gfc_trans_nested_forall_loop (info, tmp, 0, 0);
2401 gfc_add_expr_to_block (&block, tmp);
2405 /* No mask was specified. */
2406 maskindex = NULL_TREE;
2407 mask = pmask = NULL_TREE;
2410 c = code->block->next;
2412 /* TODO: loop merging in FORALL statements. */
2413 /* Now that we've got a copy of the mask, generate the assignment loops. */
2419 /* A scalar or array assignment. */
2420 need_temp = gfc_check_dependency (c->expr, c->expr2, varexpr, nvar);
2421 /* Teporaries due to array assignment data dependencies introduce
2422 no end of problems. */
2424 gfc_trans_assign_need_temp (c->expr, c->expr2, NULL,
2425 nested_forall_info, &block);
2428 /* Use the normal assignment copying routines. */
2429 assign = gfc_trans_assignment (c->expr, c->expr2);
2431 /* Reset the mask index. */
2433 gfc_add_modify_expr (&block, maskindex, gfc_index_zero_node);
2435 /* Generate body and loops. */
2436 tmp = gfc_trans_nested_forall_loop (nested_forall_info, assign, 1, 1);
2437 gfc_add_expr_to_block (&block, tmp);
2444 /* Translate WHERE or WHERE construct nested in FORALL. */
2446 gfc_trans_where_2 (c, NULL, NULL, nested_forall_info, &block, &temp);
2453 /* Free the temporary. */
2454 args = gfc_chainon_list (NULL_TREE, temp->temporary);
2455 tmp = gfc_build_function_call (gfor_fndecl_internal_free, args);
2456 gfc_add_expr_to_block (&block, tmp);
2465 /* Pointer assignment inside FORALL. */
2466 case EXEC_POINTER_ASSIGN:
2467 need_temp = gfc_check_dependency (c->expr, c->expr2, varexpr, nvar);
2469 gfc_trans_pointer_assign_need_temp (c->expr, c->expr2,
2470 nested_forall_info, &block);
2473 /* Use the normal assignment copying routines. */
2474 assign = gfc_trans_pointer_assignment (c->expr, c->expr2);
2476 /* Reset the mask index. */
2478 gfc_add_modify_expr (&block, maskindex, gfc_index_zero_node);
2480 /* Generate body and loops. */
2481 tmp = gfc_trans_nested_forall_loop (nested_forall_info, assign,
2483 gfc_add_expr_to_block (&block, tmp);
2488 tmp = gfc_trans_forall_1 (c, nested_forall_info);
2489 gfc_add_expr_to_block (&block, tmp);
2499 /* Restore the original index variables. */
2500 for (fa = code->ext.forall_iterator, n = 0; fa; fa = fa->next, n++)
2501 gfc_restore_sym (fa->var->symtree->n.sym, &saved_vars[n]);
2503 /* Free the space for var, start, end, step, varexpr. */
2509 gfc_free (saved_vars);
2513 /* Free the temporary for the mask. */
2514 tmp = gfc_chainon_list (NULL_TREE, pmask);
2515 tmp = gfc_build_function_call (gfor_fndecl_internal_free, tmp);
2516 gfc_add_expr_to_block (&block, tmp);
2519 pushdecl (maskindex);
2521 return gfc_finish_block (&block);
2525 /* Translate the FORALL statement or construct. */
2527 tree gfc_trans_forall (gfc_code * code)
2529 return gfc_trans_forall_1 (code, NULL);
2533 /* Evaluate the WHERE mask expression, copy its value to a temporary.
2534 If the WHERE construct is nested in FORALL, compute the overall temporary
2535 needed by the WHERE mask expression multiplied by the iterator number of
2537 ME is the WHERE mask expression.
2538 MASK is the temporary which value is mask's value.
2539 NMASK is another temporary which value is !mask.
2540 TEMP records the temporary's address allocated in this function in order to
2541 free them outside this function.
2542 MASK, NMASK and TEMP are all OUT arguments. */
2545 gfc_evaluate_where_mask (gfc_expr * me, forall_info * nested_forall_info,
2546 tree * mask, tree * nmask, temporary_list ** temp,
2547 stmtblock_t * block)
2552 tree ptemp1, ntmp, ptemp2;
2554 stmtblock_t body, body1;
2559 gfc_init_loopinfo (&loop);
2561 /* Calculate the size of temporary needed by the mask-expr. */
2562 inner_size = compute_inner_temp_size (me, me, block, &lss, &rss);
2564 /* Allocate temporary for where mask. */
2565 tmp = allocate_temp_for_forall_nest (nested_forall_info, boolean_type_node,
2566 inner_size, block, &ptemp1);
2567 /* Record the temporary address in order to free it later. */
2570 temporary_list *tempo;
2571 tempo = (temporary_list *) gfc_getmem (sizeof (temporary_list));
2572 tempo->temporary = ptemp1;
2573 tempo->next = *temp;
2577 /* Allocate temporary for !mask. */
2578 ntmp = allocate_temp_for_forall_nest (nested_forall_info, boolean_type_node,
2579 inner_size, block, &ptemp2);
2580 /* Record the temporary in order to free it later. */
2583 temporary_list *tempo;
2584 tempo = (temporary_list *) gfc_getmem (sizeof (temporary_list));
2585 tempo->temporary = ptemp2;
2586 tempo->next = *temp;
2590 /* Variable to index the temporary. */
2591 count = gfc_create_var (gfc_array_index_type, "count");
2592 /* Initialize count. */
2593 gfc_add_modify_expr (block, count, gfc_index_zero_node);
2595 gfc_start_block (&body);
2597 gfc_init_se (&rse, NULL);
2598 gfc_init_se (&lse, NULL);
2600 if (lss == gfc_ss_terminator)
2602 gfc_init_block (&body1);
2606 /* Initialize the loop. */
2607 gfc_init_loopinfo (&loop);
2609 /* We may need LSS to determine the shape of the expression. */
2610 gfc_add_ss_to_loop (&loop, lss);
2611 gfc_add_ss_to_loop (&loop, rss);
2613 gfc_conv_ss_startstride (&loop);
2614 gfc_conv_loop_setup (&loop);
2616 gfc_mark_ss_chain_used (rss, 1);
2617 /* Start the loop body. */
2618 gfc_start_scalarized_body (&loop, &body1);
2620 /* Translate the expression. */
2621 gfc_copy_loopinfo_to_se (&rse, &loop);
2623 gfc_conv_expr (&rse, me);
2625 /* Form the expression of the temporary. */
2626 lse.expr = gfc_build_array_ref (tmp, count);
2627 tmpexpr = gfc_build_array_ref (ntmp, count);
2629 /* Use the scalar assignment to fill temporary TMP. */
2630 tmp1 = gfc_trans_scalar_assign (&lse, &rse, me->ts.type);
2631 gfc_add_expr_to_block (&body1, tmp1);
2633 /* Fill temporary NTMP. */
2634 tmp1 = build1 (TRUTH_NOT_EXPR, TREE_TYPE (lse.expr), lse.expr);
2635 gfc_add_modify_expr (&body1, tmpexpr, tmp1);
2637 if (lss == gfc_ss_terminator)
2639 gfc_add_block_to_block (&body, &body1);
2643 /* Increment count. */
2644 tmp1 = fold (build2 (PLUS_EXPR, gfc_array_index_type, count,
2645 gfc_index_one_node));
2646 gfc_add_modify_expr (&body1, count, tmp1);
2648 /* Generate the copying loops. */
2649 gfc_trans_scalarizing_loops (&loop, &body1);
2651 gfc_add_block_to_block (&body, &loop.pre);
2652 gfc_add_block_to_block (&body, &loop.post);
2654 gfc_cleanup_loop (&loop);
2655 /* TODO: Reuse lss and rss when copying temp->lhs. Need to be careful
2656 as tree nodes in SS may not be valid in different scope. */
2659 tmp1 = gfc_finish_block (&body);
2660 /* If the WHERE construct is inside FORALL, fill the full temporary. */
2661 if (nested_forall_info != NULL)
2662 tmp1 = gfc_trans_nested_forall_loop (nested_forall_info, tmp1, 1, 1);
2665 gfc_add_expr_to_block (block, tmp1);
2674 /* Translate an assignment statement in a WHERE statement or construct
2675 statement. The MASK expression is used to control which elements
2676 of EXPR1 shall be assigned. */
2679 gfc_trans_where_assign (gfc_expr *expr1, gfc_expr *expr2, tree mask,
2680 tree count1, tree count2)
2685 gfc_ss *lss_section;
2692 tree index, maskexpr, tmp1;
2695 /* TODO: handle this special case.
2696 Special case a single function returning an array. */
2697 if (expr2->expr_type == EXPR_FUNCTION && expr2->rank > 0)
2699 tmp = gfc_trans_arrayfunc_assign (expr1, expr2);
2705 /* Assignment of the form lhs = rhs. */
2706 gfc_start_block (&block);
2708 gfc_init_se (&lse, NULL);
2709 gfc_init_se (&rse, NULL);
2712 lss = gfc_walk_expr (expr1);
2715 /* In each where-assign-stmt, the mask-expr and the variable being
2716 defined shall be arrays of the same shape. */
2717 gcc_assert (lss != gfc_ss_terminator);
2719 /* The assignment needs scalarization. */
2722 /* Find a non-scalar SS from the lhs. */
2723 while (lss_section != gfc_ss_terminator
2724 && lss_section->type != GFC_SS_SECTION)
2725 lss_section = lss_section->next;
2727 gcc_assert (lss_section != gfc_ss_terminator);
2729 /* Initialize the scalarizer. */
2730 gfc_init_loopinfo (&loop);
2733 rss = gfc_walk_expr (expr2);
2734 if (rss == gfc_ss_terminator)
2736 /* The rhs is scalar. Add a ss for the expression. */
2737 rss = gfc_get_ss ();
2738 rss->next = gfc_ss_terminator;
2739 rss->type = GFC_SS_SCALAR;
2743 /* Associate the SS with the loop. */
2744 gfc_add_ss_to_loop (&loop, lss);
2745 gfc_add_ss_to_loop (&loop, rss);
2747 /* Calculate the bounds of the scalarization. */
2748 gfc_conv_ss_startstride (&loop);
2750 /* Resolve any data dependencies in the statement. */
2751 gfc_conv_resolve_dependencies (&loop, lss_section, rss);
2753 /* Setup the scalarizing loops. */
2754 gfc_conv_loop_setup (&loop);
2756 /* Setup the gfc_se structures. */
2757 gfc_copy_loopinfo_to_se (&lse, &loop);
2758 gfc_copy_loopinfo_to_se (&rse, &loop);
2761 gfc_mark_ss_chain_used (rss, 1);
2762 if (loop.temp_ss == NULL)
2765 gfc_mark_ss_chain_used (lss, 1);
2769 lse.ss = loop.temp_ss;
2770 gfc_mark_ss_chain_used (lss, 3);
2771 gfc_mark_ss_chain_used (loop.temp_ss, 3);
2774 /* Start the scalarized loop body. */
2775 gfc_start_scalarized_body (&loop, &body);
2777 /* Translate the expression. */
2778 gfc_conv_expr (&rse, expr2);
2779 if (lss != gfc_ss_terminator && loop.temp_ss != NULL)
2781 gfc_conv_tmp_array_ref (&lse);
2782 gfc_advance_se_ss_chain (&lse);
2785 gfc_conv_expr (&lse, expr1);
2787 /* Form the mask expression according to the mask tree list. */
2791 maskexpr = gfc_build_array_ref (tmp, index);
2795 tmp = TREE_CHAIN (tmp);
2798 tmp1 = gfc_build_array_ref (tmp, index);
2799 maskexpr = build2 (TRUTH_AND_EXPR, TREE_TYPE (tmp1), maskexpr, tmp1);
2800 tmp = TREE_CHAIN (tmp);
2802 /* Use the scalar assignment as is. */
2803 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts.type);
2804 tmp = build3_v (COND_EXPR, maskexpr, tmp, build_empty_stmt ());
2806 gfc_add_expr_to_block (&body, tmp);
2808 if (lss == gfc_ss_terminator)
2810 /* Increment count1. */
2811 tmp = fold (build2 (PLUS_EXPR, gfc_array_index_type,
2812 count1, gfc_index_one_node));
2813 gfc_add_modify_expr (&body, count1, tmp);
2815 /* Use the scalar assignment as is. */
2816 gfc_add_block_to_block (&block, &body);
2820 gcc_assert (lse.ss == gfc_ss_terminator
2821 && rse.ss == gfc_ss_terminator);
2823 if (loop.temp_ss != NULL)
2825 /* Increment count1 before finish the main body of a scalarized
2827 tmp = fold (build2 (PLUS_EXPR, gfc_array_index_type,
2828 count1, gfc_index_one_node));
2829 gfc_add_modify_expr (&body, count1, tmp);
2830 gfc_trans_scalarized_loop_boundary (&loop, &body);
2832 /* We need to copy the temporary to the actual lhs. */
2833 gfc_init_se (&lse, NULL);
2834 gfc_init_se (&rse, NULL);
2835 gfc_copy_loopinfo_to_se (&lse, &loop);
2836 gfc_copy_loopinfo_to_se (&rse, &loop);
2838 rse.ss = loop.temp_ss;
2841 gfc_conv_tmp_array_ref (&rse);
2842 gfc_advance_se_ss_chain (&rse);
2843 gfc_conv_expr (&lse, expr1);
2845 gcc_assert (lse.ss == gfc_ss_terminator
2846 && rse.ss == gfc_ss_terminator);
2848 /* Form the mask expression according to the mask tree list. */
2852 maskexpr = gfc_build_array_ref (tmp, index);
2856 tmp = TREE_CHAIN (tmp);
2859 tmp1 = gfc_build_array_ref (tmp, index);
2860 maskexpr = build2 (TRUTH_AND_EXPR, TREE_TYPE (tmp1),
2862 tmp = TREE_CHAIN (tmp);
2864 /* Use the scalar assignment as is. */
2865 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts.type);
2866 tmp = build3_v (COND_EXPR, maskexpr, tmp, build_empty_stmt ());
2867 gfc_add_expr_to_block (&body, tmp);
2869 /* Increment count2. */
2870 tmp = fold (build2 (PLUS_EXPR, gfc_array_index_type,
2871 count2, gfc_index_one_node));
2872 gfc_add_modify_expr (&body, count2, tmp);
2876 /* Increment count1. */
2877 tmp = fold (build2 (PLUS_EXPR, gfc_array_index_type,
2878 count1, gfc_index_one_node));
2879 gfc_add_modify_expr (&body, count1, tmp);
2882 /* Generate the copying loops. */
2883 gfc_trans_scalarizing_loops (&loop, &body);
2885 /* Wrap the whole thing up. */
2886 gfc_add_block_to_block (&block, &loop.pre);
2887 gfc_add_block_to_block (&block, &loop.post);
2888 gfc_cleanup_loop (&loop);
2891 return gfc_finish_block (&block);
2895 /* Translate the WHERE construct or statement.
2896 This fuction can be called iteratively to translate the nested WHERE
2897 construct or statement.
2898 MASK is the control mask, and PMASK is the pending control mask.
2899 TEMP records the temporary address which must be freed later. */
2902 gfc_trans_where_2 (gfc_code * code, tree mask, tree pmask,
2903 forall_info * nested_forall_info, stmtblock_t * block,
2904 temporary_list ** temp)
2910 tree tmp, tmp1, tmp2;
2911 tree count1, count2;
2915 /* the WHERE statement or the WHERE construct statement. */
2916 cblock = code->block;
2919 /* Has mask-expr. */
2922 /* Ensure that the WHERE mask be evaluated only once. */
2923 tmp2 = gfc_evaluate_where_mask (cblock->expr, nested_forall_info,
2924 &tmp, &tmp1, temp, block);
2926 /* Set the control mask and the pending control mask. */
2927 /* It's a where-stmt. */
2933 /* It's a nested where-stmt. */
2934 else if (mask && pmask == NULL)
2937 /* Use the TREE_CHAIN to list the masks. */
2938 tmp2 = copy_list (mask);
2939 pmask = chainon (mask, tmp1);
2940 mask = chainon (tmp2, tmp);
2942 /* It's a masked-elsewhere-stmt. */
2943 else if (mask && cblock->expr)
2946 tmp2 = copy_list (pmask);
2949 tmp2 = chainon (tmp2, tmp);
2950 pmask = chainon (mask, tmp1);
2954 /* It's a elsewhere-stmt. No mask-expr is present. */
2958 /* Get the assignment statement of a WHERE statement, or the first
2959 statement in where-body-construct of a WHERE construct. */
2960 cnext = cblock->next;
2965 /* WHERE assignment statement. */
2967 expr1 = cnext->expr;
2968 expr2 = cnext->expr2;
2969 if (nested_forall_info != NULL)
2974 nvar = nested_forall_info->nvar;
2975 varexpr = (gfc_expr **)
2976 gfc_getmem (nvar * sizeof (gfc_expr *));
2977 need_temp = gfc_check_dependency (expr1, expr2, varexpr,
2980 gfc_trans_assign_need_temp (expr1, expr2, mask,
2981 nested_forall_info, block);
2984 /* Variables to control maskexpr. */
2985 count1 = gfc_create_var (gfc_array_index_type, "count1");
2986 count2 = gfc_create_var (gfc_array_index_type, "count2");
2987 gfc_add_modify_expr (block, count1, gfc_index_zero_node);
2988 gfc_add_modify_expr (block, count2, gfc_index_zero_node);
2990 tmp = gfc_trans_where_assign (expr1, expr2, mask, count1,
2992 tmp = gfc_trans_nested_forall_loop (nested_forall_info,
2994 gfc_add_expr_to_block (block, tmp);
2999 /* Variables to control maskexpr. */
3000 count1 = gfc_create_var (gfc_array_index_type, "count1");
3001 count2 = gfc_create_var (gfc_array_index_type, "count2");
3002 gfc_add_modify_expr (block, count1, gfc_index_zero_node);
3003 gfc_add_modify_expr (block, count2, gfc_index_zero_node);
3005 tmp = gfc_trans_where_assign (expr1, expr2, mask, count1,
3007 gfc_add_expr_to_block (block, tmp);
3012 /* WHERE or WHERE construct is part of a where-body-construct. */
3014 /* Ensure that MASK is not modified by next gfc_trans_where_2. */
3015 mask_copy = copy_list (mask);
3016 gfc_trans_where_2 (cnext, mask_copy, NULL, nested_forall_info,
3024 /* The next statement within the same where-body-construct. */
3025 cnext = cnext->next;
3027 /* The next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt. */
3028 cblock = cblock->block;
3033 /* As the WHERE or WHERE construct statement can be nested, we call
3034 gfc_trans_where_2 to do the translation, and pass the initial
3035 NULL values for both the control mask and the pending control mask. */
3038 gfc_trans_where (gfc_code * code)
3041 temporary_list *temp, *p;
3045 gfc_start_block (&block);
3048 gfc_trans_where_2 (code, NULL, NULL, NULL, &block, &temp);
3050 /* Add calls to free temporaries which were dynamically allocated. */
3053 args = gfc_chainon_list (NULL_TREE, temp->temporary);
3054 tmp = gfc_build_function_call (gfor_fndecl_internal_free, args);
3055 gfc_add_expr_to_block (&block, tmp);
3061 return gfc_finish_block (&block);
3065 /* CYCLE a DO loop. The label decl has already been created by
3066 gfc_trans_do(), it's in TREE_PURPOSE (backend_decl) of the gfc_code
3067 node at the head of the loop. We must mark the label as used. */
3070 gfc_trans_cycle (gfc_code * code)
3074 cycle_label = TREE_PURPOSE (code->ext.whichloop->backend_decl);
3075 TREE_USED (cycle_label) = 1;
3076 return build1_v (GOTO_EXPR, cycle_label);
3080 /* EXIT a DO loop. Similar to CYCLE, but now the label is in
3081 TREE_VALUE (backend_decl) of the gfc_code node at the head of the
3085 gfc_trans_exit (gfc_code * code)
3089 exit_label = TREE_VALUE (code->ext.whichloop->backend_decl);
3090 TREE_USED (exit_label) = 1;
3091 return build1_v (GOTO_EXPR, exit_label);
3095 /* Translate the ALLOCATE statement. */
3098 gfc_trans_allocate (gfc_code * code)
3111 if (!code->ext.alloc_list)
3114 gfc_start_block (&block);
3118 tree gfc_int4_type_node = gfc_get_int_type (4);
3120 stat = gfc_create_var (gfc_int4_type_node, "stat");
3121 pstat = gfc_build_addr_expr (NULL, stat);
3123 error_label = gfc_build_label_decl (NULL_TREE);
3124 TREE_USED (error_label) = 1;
3128 pstat = integer_zero_node;
3129 stat = error_label = NULL_TREE;
3133 for (al = code->ext.alloc_list; al != NULL; al = al->next)
3137 gfc_init_se (&se, NULL);
3138 gfc_start_block (&se.pre);
3140 se.want_pointer = 1;
3141 se.descriptor_only = 1;
3142 gfc_conv_expr (&se, expr);
3146 /* Find the last reference in the chain. */
3147 while (ref && ref->next != NULL)
3149 gcc_assert (ref->type != REF_ARRAY || ref->u.ar.type == AR_ELEMENT);
3153 if (ref != NULL && ref->type == REF_ARRAY)
3156 gfc_array_allocate (&se, ref, pstat);
3160 /* A scalar or derived type. */
3163 val = gfc_create_var (ppvoid_type_node, "ptr");
3164 tmp = gfc_build_addr_expr (ppvoid_type_node, se.expr);
3165 gfc_add_modify_expr (&se.pre, val, tmp);
3167 tmp = TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (se.expr)));
3168 parm = gfc_chainon_list (NULL_TREE, val);
3169 parm = gfc_chainon_list (parm, tmp);
3170 parm = gfc_chainon_list (parm, pstat);
3171 tmp = gfc_build_function_call (gfor_fndecl_allocate, parm);
3172 gfc_add_expr_to_block (&se.pre, tmp);
3176 tmp = build1_v (GOTO_EXPR, error_label);
3178 build2 (NE_EXPR, boolean_type_node, stat, integer_zero_node);
3179 tmp = build3_v (COND_EXPR, parm, tmp, build_empty_stmt ());
3180 gfc_add_expr_to_block (&se.pre, tmp);
3184 tmp = gfc_finish_block (&se.pre);
3185 gfc_add_expr_to_block (&block, tmp);
3188 /* Assign the value to the status variable. */
3191 tmp = build1_v (LABEL_EXPR, error_label);
3192 gfc_add_expr_to_block (&block, tmp);
3194 gfc_init_se (&se, NULL);
3195 gfc_conv_expr_lhs (&se, code->expr);
3196 tmp = convert (TREE_TYPE (se.expr), stat);
3197 gfc_add_modify_expr (&block, se.expr, tmp);
3200 return gfc_finish_block (&block);
3205 gfc_trans_deallocate (gfc_code * code)
3215 gfc_start_block (&block);
3217 for (al = code->ext.alloc_list; al != NULL; al = al->next)
3220 gcc_assert (expr->expr_type == EXPR_VARIABLE);
3222 gfc_init_se (&se, NULL);
3223 gfc_start_block (&se.pre);
3225 se.want_pointer = 1;
3226 se.descriptor_only = 1;
3227 gfc_conv_expr (&se, expr);
3229 if (expr->symtree->n.sym->attr.dimension)
3231 tmp = gfc_array_deallocate (se.expr);
3232 gfc_add_expr_to_block (&se.pre, tmp);
3236 type = build_pointer_type (TREE_TYPE (se.expr));
3237 var = gfc_create_var (type, "ptr");
3238 tmp = gfc_build_addr_expr (type, se.expr);
3239 gfc_add_modify_expr (&se.pre, var, tmp);
3241 tmp = gfc_chainon_list (NULL_TREE, var);
3242 tmp = gfc_chainon_list (tmp, integer_zero_node);
3243 tmp = gfc_build_function_call (gfor_fndecl_deallocate, tmp);
3244 gfc_add_expr_to_block (&se.pre, tmp);
3246 tmp = gfc_finish_block (&se.pre);
3247 gfc_add_expr_to_block (&block, tmp);
3250 return gfc_finish_block (&block);