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));
84 /* Given a variable expression which has been ASSIGNed to, find the decl
85 containing the auxiliary variables. For variables in common blocks this
89 gfc_conv_label_variable (gfc_se * se, gfc_expr * expr)
91 gcc_assert (expr->symtree->n.sym->attr.assign == 1);
92 gfc_conv_expr (se, expr);
93 /* Deals with variable in common block. Get the field declaration. */
94 if (TREE_CODE (se->expr) == COMPONENT_REF)
95 se->expr = TREE_OPERAND (se->expr, 1);
98 /* Translate a label assignment statement. */
101 gfc_trans_label_assign (gfc_code * code)
111 /* Start a new block. */
112 gfc_init_se (&se, NULL);
113 gfc_start_block (&se.pre);
114 gfc_conv_label_variable (&se, code->expr);
116 len = GFC_DECL_STRING_LEN (se.expr);
117 addr = GFC_DECL_ASSIGN_ADDR (se.expr);
119 label_tree = gfc_get_label_decl (code->label);
121 if (code->label->defined == ST_LABEL_TARGET)
123 label_tree = gfc_build_addr_expr (pvoid_type_node, label_tree);
124 len_tree = integer_minus_one_node;
128 label_str = code->label->format->value.character.string;
129 label_len = code->label->format->value.character.length;
130 len_tree = build_int_cst (NULL_TREE, label_len);
131 label_tree = gfc_build_string_const (label_len + 1, label_str);
132 label_tree = gfc_build_addr_expr (pchar_type_node, label_tree);
135 gfc_add_modify_expr (&se.pre, len, len_tree);
136 gfc_add_modify_expr (&se.pre, addr, label_tree);
138 return gfc_finish_block (&se.pre);
141 /* Translate a GOTO statement. */
144 gfc_trans_goto (gfc_code * code)
154 if (code->label != NULL)
155 return build1_v (GOTO_EXPR, gfc_get_label_decl (code->label));
158 gfc_init_se (&se, NULL);
159 gfc_start_block (&se.pre);
160 gfc_conv_label_variable (&se, code->expr);
162 gfc_build_cstring_const ("Assigned label is not a target label");
163 tmp = GFC_DECL_STRING_LEN (se.expr);
164 tmp = build2 (NE_EXPR, boolean_type_node, tmp, integer_minus_one_node);
165 gfc_trans_runtime_check (tmp, assign_error, &se.pre);
167 assigned_goto = GFC_DECL_ASSIGN_ADDR (se.expr);
168 target = build1 (GOTO_EXPR, void_type_node, assigned_goto);
173 gfc_add_expr_to_block (&se.pre, target);
174 return gfc_finish_block (&se.pre);
177 /* Check the label list. */
178 range_error = gfc_build_cstring_const ("Assigned label is not in the list");
182 tmp = gfc_get_label_decl (code->label);
183 tmp = gfc_build_addr_expr (pvoid_type_node, tmp);
184 tmp = build2 (EQ_EXPR, boolean_type_node, tmp, assigned_goto);
185 tmp = build3_v (COND_EXPR, tmp, target, build_empty_stmt ());
186 gfc_add_expr_to_block (&se.pre, tmp);
189 while (code != NULL);
190 gfc_trans_runtime_check (boolean_true_node, range_error, &se.pre);
191 return gfc_finish_block (&se.pre);
195 /* Translate an ENTRY statement. Just adds a label for this entry point. */
197 gfc_trans_entry (gfc_code * code)
199 return build1_v (LABEL_EXPR, code->ext.entry->label);
203 /* Translate the CALL statement. Builds a call to an F95 subroutine. */
206 gfc_trans_call (gfc_code * code)
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);
216 has_alternate_specifier = 0;
218 /* Translate the call. */
219 gfc_conv_function_call (&se, code->resolved_sym, code->ext.actual);
221 /* A subroutine without side-effect, by definition, does nothing! */
222 TREE_SIDE_EFFECTS (se.expr) = 1;
224 /* Chain the pieces together and return the block. */
225 if (has_alternate_specifier)
227 gfc_code *select_code;
229 select_code = code->next;
230 gcc_assert(select_code->op == EXEC_SELECT);
231 sym = select_code->expr->symtree->n.sym;
232 se.expr = convert (gfc_typenode_for_spec (&sym->ts), se.expr);
233 gfc_add_modify_expr (&se.pre, sym->backend_decl, se.expr);
236 gfc_add_expr_to_block (&se.pre, se.expr);
238 gfc_add_block_to_block (&se.pre, &se.post);
239 return gfc_finish_block (&se.pre);
243 /* Translate the RETURN statement. */
246 gfc_trans_return (gfc_code * code ATTRIBUTE_UNUSED)
254 /* if code->expr is not NULL, this return statement must appear
255 in a subroutine and current_fake_result_decl has already
258 result = gfc_get_fake_result_decl (NULL);
261 gfc_warning ("An alternate return at %L without a * dummy argument",
263 return build1_v (GOTO_EXPR, gfc_get_return_label ());
266 /* Start a new block for this statement. */
267 gfc_init_se (&se, NULL);
268 gfc_start_block (&se.pre);
270 gfc_conv_expr (&se, code->expr);
272 tmp = build2 (MODIFY_EXPR, TREE_TYPE (result), result, se.expr);
273 gfc_add_expr_to_block (&se.pre, tmp);
275 tmp = build1_v (GOTO_EXPR, gfc_get_return_label ());
276 gfc_add_expr_to_block (&se.pre, tmp);
277 gfc_add_block_to_block (&se.pre, &se.post);
278 return gfc_finish_block (&se.pre);
281 return build1_v (GOTO_EXPR, gfc_get_return_label ());
285 /* Translate the PAUSE statement. We have to translate this statement
286 to a runtime library call. */
289 gfc_trans_pause (gfc_code * code)
291 tree gfc_int4_type_node = gfc_get_int_type (4);
297 /* Start a new block for this statement. */
298 gfc_init_se (&se, NULL);
299 gfc_start_block (&se.pre);
302 if (code->expr == NULL)
304 tmp = build_int_cst (gfc_int4_type_node, code->ext.stop_code);
305 args = gfc_chainon_list (NULL_TREE, tmp);
306 fndecl = gfor_fndecl_pause_numeric;
310 gfc_conv_expr_reference (&se, code->expr);
311 args = gfc_chainon_list (NULL_TREE, se.expr);
312 args = gfc_chainon_list (args, se.string_length);
313 fndecl = gfor_fndecl_pause_string;
316 tmp = gfc_build_function_call (fndecl, args);
317 gfc_add_expr_to_block (&se.pre, tmp);
319 gfc_add_block_to_block (&se.pre, &se.post);
321 return gfc_finish_block (&se.pre);
325 /* Translate the STOP statement. We have to translate this statement
326 to a runtime library call. */
329 gfc_trans_stop (gfc_code * code)
331 tree gfc_int4_type_node = gfc_get_int_type (4);
337 /* Start a new block for this statement. */
338 gfc_init_se (&se, NULL);
339 gfc_start_block (&se.pre);
342 if (code->expr == NULL)
344 tmp = build_int_cst (gfc_int4_type_node, code->ext.stop_code);
345 args = gfc_chainon_list (NULL_TREE, tmp);
346 fndecl = gfor_fndecl_stop_numeric;
350 gfc_conv_expr_reference (&se, code->expr);
351 args = gfc_chainon_list (NULL_TREE, se.expr);
352 args = gfc_chainon_list (args, se.string_length);
353 fndecl = gfor_fndecl_stop_string;
356 tmp = gfc_build_function_call (fndecl, args);
357 gfc_add_expr_to_block (&se.pre, tmp);
359 gfc_add_block_to_block (&se.pre, &se.post);
361 return gfc_finish_block (&se.pre);
365 /* Generate GENERIC for the IF construct. This function also deals with
366 the simple IF statement, because the front end translates the IF
367 statement into an IF construct.
399 where COND_S is the simplified version of the predicate. PRE_COND_S
400 are the pre side-effects produced by the translation of the
402 We need to build the chain recursively otherwise we run into
403 problems with folding incomplete statements. */
406 gfc_trans_if_1 (gfc_code * code)
411 /* Check for an unconditional ELSE clause. */
413 return gfc_trans_code (code->next);
415 /* Initialize a statement builder for each block. Puts in NULL_TREEs. */
416 gfc_init_se (&if_se, NULL);
417 gfc_start_block (&if_se.pre);
419 /* Calculate the IF condition expression. */
420 gfc_conv_expr_val (&if_se, code->expr);
422 /* Translate the THEN clause. */
423 stmt = gfc_trans_code (code->next);
425 /* Translate the ELSE clause. */
427 elsestmt = gfc_trans_if_1 (code->block);
429 elsestmt = build_empty_stmt ();
431 /* Build the condition expression and add it to the condition block. */
432 stmt = build3_v (COND_EXPR, if_se.expr, stmt, elsestmt);
434 gfc_add_expr_to_block (&if_se.pre, stmt);
436 /* Finish off this statement. */
437 return gfc_finish_block (&if_se.pre);
441 gfc_trans_if (gfc_code * code)
443 /* Ignore the top EXEC_IF, it only announces an IF construct. The
444 actual code we must translate is in code->block. */
446 return gfc_trans_if_1 (code->block);
450 /* Translage an arithmetic IF expression.
452 IF (cond) label1, label2, label3 translates to
466 gfc_trans_arithmetic_if (gfc_code * code)
474 /* Start a new block. */
475 gfc_init_se (&se, NULL);
476 gfc_start_block (&se.pre);
478 /* Pre-evaluate COND. */
479 gfc_conv_expr_val (&se, code->expr);
481 /* Build something to compare with. */
482 zero = gfc_build_const (TREE_TYPE (se.expr), integer_zero_node);
484 /* If (cond < 0) take branch1 else take branch2.
485 First build jumps to the COND .LT. 0 and the COND .EQ. 0 cases. */
486 branch1 = build1_v (GOTO_EXPR, gfc_get_label_decl (code->label));
487 branch2 = build1_v (GOTO_EXPR, gfc_get_label_decl (code->label2));
489 tmp = build2 (LT_EXPR, boolean_type_node, se.expr, zero);
490 branch1 = build3_v (COND_EXPR, tmp, branch1, branch2);
492 /* if (cond <= 0) take branch1 else take branch2. */
493 branch2 = build1_v (GOTO_EXPR, gfc_get_label_decl (code->label3));
494 tmp = build2 (LE_EXPR, boolean_type_node, se.expr, zero);
495 branch1 = build3_v (COND_EXPR, tmp, branch1, branch2);
497 /* Append the COND_EXPR to the evaluation of COND, and return. */
498 gfc_add_expr_to_block (&se.pre, branch1);
499 return gfc_finish_block (&se.pre);
503 /* Translate the simple DO construct. This is where the loop variable has
504 integer type and step +-1. We can't use this in the general case
505 because integer overflow and floating point errors could give incorrect
507 We translate a do loop from:
509 DO dovar = from, to, step
515 [Evaluate loop bounds and step]
517 if ((step > 0) ? (dovar <= to) : (dovar => to))
523 cond = (dovar == to);
525 if (cond) goto end_label;
530 This helps the optimizers by avoiding the extra induction variable
531 used in the general case. */
534 gfc_trans_simple_do (gfc_code * code, stmtblock_t *pblock, tree dovar,
535 tree from, tree to, tree step)
544 type = TREE_TYPE (dovar);
546 /* Initialize the DO variable: dovar = from. */
547 gfc_add_modify_expr (pblock, dovar, from);
549 /* Cycle and exit statements are implemented with gotos. */
550 cycle_label = gfc_build_label_decl (NULL_TREE);
551 exit_label = gfc_build_label_decl (NULL_TREE);
553 /* Put the labels where they can be found later. See gfc_trans_do(). */
554 code->block->backend_decl = tree_cons (cycle_label, exit_label, NULL);
557 gfc_start_block (&body);
559 /* Main loop body. */
560 tmp = gfc_trans_code (code->block->next);
561 gfc_add_expr_to_block (&body, tmp);
563 /* Label for cycle statements (if needed). */
564 if (TREE_USED (cycle_label))
566 tmp = build1_v (LABEL_EXPR, cycle_label);
567 gfc_add_expr_to_block (&body, tmp);
570 /* Evaluate the loop condition. */
571 cond = build2 (EQ_EXPR, boolean_type_node, dovar, to);
572 cond = gfc_evaluate_now (cond, &body);
574 /* Increment the loop variable. */
575 tmp = build2 (PLUS_EXPR, type, dovar, step);
576 gfc_add_modify_expr (&body, dovar, tmp);
579 tmp = build1_v (GOTO_EXPR, exit_label);
580 TREE_USED (exit_label) = 1;
581 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
582 gfc_add_expr_to_block (&body, tmp);
584 /* Finish the loop body. */
585 tmp = gfc_finish_block (&body);
586 tmp = build1_v (LOOP_EXPR, tmp);
588 /* Only execute the loop if the number of iterations is positive. */
589 if (tree_int_cst_sgn (step) > 0)
590 cond = fold_build2 (LE_EXPR, boolean_type_node, dovar, to);
592 cond = fold_build2 (GE_EXPR, boolean_type_node, dovar, to);
593 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
594 gfc_add_expr_to_block (pblock, tmp);
596 /* Add the exit label. */
597 tmp = build1_v (LABEL_EXPR, exit_label);
598 gfc_add_expr_to_block (pblock, tmp);
600 return gfc_finish_block (pblock);
603 /* Translate the DO construct. This obviously is one of the most
604 important ones to get right with any compiler, but especially
607 We special case some loop forms as described in gfc_trans_simple_do.
608 For other cases we implement them with a separate loop count,
609 as described in the standard.
611 We translate a do loop from:
613 DO dovar = from, to, step
619 [evaluate loop bounds and step]
620 count = to + step - from;
628 if (count <=0) goto exit_label;
632 TODO: Large loop counts
633 The code above assumes the loop count fits into a signed integer kind,
634 i.e. Does not work for loop counts > 2^31 for integer(kind=4) variables
635 We must support the full range. */
638 gfc_trans_do (gfc_code * code)
655 gfc_start_block (&block);
657 /* Evaluate all the expressions in the iterator. */
658 gfc_init_se (&se, NULL);
659 gfc_conv_expr_lhs (&se, code->ext.iterator->var);
660 gfc_add_block_to_block (&block, &se.pre);
662 type = TREE_TYPE (dovar);
664 gfc_init_se (&se, NULL);
665 gfc_conv_expr_val (&se, code->ext.iterator->start);
666 gfc_add_block_to_block (&block, &se.pre);
667 from = gfc_evaluate_now (se.expr, &block);
669 gfc_init_se (&se, NULL);
670 gfc_conv_expr_val (&se, code->ext.iterator->end);
671 gfc_add_block_to_block (&block, &se.pre);
672 to = gfc_evaluate_now (se.expr, &block);
674 gfc_init_se (&se, NULL);
675 gfc_conv_expr_val (&se, code->ext.iterator->step);
676 gfc_add_block_to_block (&block, &se.pre);
677 step = gfc_evaluate_now (se.expr, &block);
679 /* Special case simple loops. */
680 if (TREE_CODE (type) == INTEGER_TYPE
681 && (integer_onep (step)
682 || tree_int_cst_equal (step, integer_minus_one_node)))
683 return gfc_trans_simple_do (code, &block, dovar, from, to, step);
685 /* Initialize loop count. This code is executed before we enter the
686 loop body. We generate: count = (to + step - from) / step. */
688 tmp = fold_build2 (MINUS_EXPR, type, step, from);
689 tmp = fold_build2 (PLUS_EXPR, type, to, tmp);
690 if (TREE_CODE (type) == INTEGER_TYPE)
692 tmp = fold_build2 (TRUNC_DIV_EXPR, type, tmp, step);
693 count = gfc_create_var (type, "count");
697 /* TODO: We could use the same width as the real type.
698 This would probably cause more problems that it solves
699 when we implement "long double" types. */
700 tmp = fold_build2 (RDIV_EXPR, type, tmp, step);
701 tmp = fold_build1 (FIX_TRUNC_EXPR, gfc_array_index_type, tmp);
702 count = gfc_create_var (gfc_array_index_type, "count");
704 gfc_add_modify_expr (&block, count, tmp);
706 count_one = convert (TREE_TYPE (count), integer_one_node);
708 /* Initialize the DO variable: dovar = from. */
709 gfc_add_modify_expr (&block, dovar, from);
712 gfc_start_block (&body);
714 /* Cycle and exit statements are implemented with gotos. */
715 cycle_label = gfc_build_label_decl (NULL_TREE);
716 exit_label = gfc_build_label_decl (NULL_TREE);
718 /* Start with the loop condition. Loop until count <= 0. */
719 cond = build2 (LE_EXPR, boolean_type_node, count,
720 convert (TREE_TYPE (count), integer_zero_node));
721 tmp = build1_v (GOTO_EXPR, exit_label);
722 TREE_USED (exit_label) = 1;
723 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
724 gfc_add_expr_to_block (&body, tmp);
726 /* Put these labels where they can be found later. We put the
727 labels in a TREE_LIST node (because TREE_CHAIN is already
728 used). cycle_label goes in TREE_PURPOSE (backend_decl), exit
729 label in TREE_VALUE (backend_decl). */
731 code->block->backend_decl = tree_cons (cycle_label, exit_label, NULL);
733 /* Main loop body. */
734 tmp = gfc_trans_code (code->block->next);
735 gfc_add_expr_to_block (&body, tmp);
737 /* Label for cycle statements (if needed). */
738 if (TREE_USED (cycle_label))
740 tmp = build1_v (LABEL_EXPR, cycle_label);
741 gfc_add_expr_to_block (&body, tmp);
744 /* Increment the loop variable. */
745 tmp = build2 (PLUS_EXPR, type, dovar, step);
746 gfc_add_modify_expr (&body, dovar, tmp);
748 /* Decrement the loop count. */
749 tmp = build2 (MINUS_EXPR, TREE_TYPE (count), count, count_one);
750 gfc_add_modify_expr (&body, count, tmp);
752 /* End of loop body. */
753 tmp = gfc_finish_block (&body);
755 /* The for loop itself. */
756 tmp = build1_v (LOOP_EXPR, tmp);
757 gfc_add_expr_to_block (&block, tmp);
759 /* Add the exit label. */
760 tmp = build1_v (LABEL_EXPR, exit_label);
761 gfc_add_expr_to_block (&block, tmp);
763 return gfc_finish_block (&block);
767 /* Translate the DO WHILE construct.
780 if (! cond) goto exit_label;
786 Because the evaluation of the exit condition `cond' may have side
787 effects, we can't do much for empty loop bodies. The backend optimizers
788 should be smart enough to eliminate any dead loops. */
791 gfc_trans_do_while (gfc_code * code)
799 /* Everything we build here is part of the loop body. */
800 gfc_start_block (&block);
802 /* Cycle and exit statements are implemented with gotos. */
803 cycle_label = gfc_build_label_decl (NULL_TREE);
804 exit_label = gfc_build_label_decl (NULL_TREE);
806 /* Put the labels where they can be found later. See gfc_trans_do(). */
807 code->block->backend_decl = tree_cons (cycle_label, exit_label, NULL);
809 /* Create a GIMPLE version of the exit condition. */
810 gfc_init_se (&cond, NULL);
811 gfc_conv_expr_val (&cond, code->expr);
812 gfc_add_block_to_block (&block, &cond.pre);
813 cond.expr = fold_build1 (TRUTH_NOT_EXPR, boolean_type_node, cond.expr);
815 /* Build "IF (! cond) GOTO exit_label". */
816 tmp = build1_v (GOTO_EXPR, exit_label);
817 TREE_USED (exit_label) = 1;
818 tmp = build3_v (COND_EXPR, cond.expr, tmp, build_empty_stmt ());
819 gfc_add_expr_to_block (&block, tmp);
821 /* The main body of the loop. */
822 tmp = gfc_trans_code (code->block->next);
823 gfc_add_expr_to_block (&block, tmp);
825 /* Label for cycle statements (if needed). */
826 if (TREE_USED (cycle_label))
828 tmp = build1_v (LABEL_EXPR, cycle_label);
829 gfc_add_expr_to_block (&block, tmp);
832 /* End of loop body. */
833 tmp = gfc_finish_block (&block);
835 gfc_init_block (&block);
836 /* Build the loop. */
837 tmp = build1_v (LOOP_EXPR, tmp);
838 gfc_add_expr_to_block (&block, tmp);
840 /* Add the exit label. */
841 tmp = build1_v (LABEL_EXPR, exit_label);
842 gfc_add_expr_to_block (&block, tmp);
844 return gfc_finish_block (&block);
848 /* Translate the SELECT CASE construct for INTEGER case expressions,
849 without killing all potential optimizations. The problem is that
850 Fortran allows unbounded cases, but the back-end does not, so we
851 need to intercept those before we enter the equivalent SWITCH_EXPR
854 For example, we translate this,
857 CASE (:100,101,105:115)
867 to the GENERIC equivalent,
871 case (minimum value for typeof(expr) ... 100:
877 case 200 ... (maximum value for typeof(expr):
894 gfc_trans_integer_select (gfc_code * code)
904 gfc_start_block (&block);
906 /* Calculate the switch expression. */
907 gfc_init_se (&se, NULL);
908 gfc_conv_expr_val (&se, code->expr);
909 gfc_add_block_to_block (&block, &se.pre);
911 end_label = gfc_build_label_decl (NULL_TREE);
913 gfc_init_block (&body);
915 for (c = code->block; c; c = c->block)
917 for (cp = c->ext.case_list; cp; cp = cp->next)
922 /* Assume it's the default case. */
923 low = high = NULL_TREE;
927 low = gfc_conv_constant_to_tree (cp->low);
929 /* If there's only a lower bound, set the high bound to the
930 maximum value of the case expression. */
932 high = TYPE_MAX_VALUE (TREE_TYPE (se.expr));
937 /* Three cases are possible here:
939 1) There is no lower bound, e.g. CASE (:N).
940 2) There is a lower bound .NE. high bound, that is
941 a case range, e.g. CASE (N:M) where M>N (we make
942 sure that M>N during type resolution).
943 3) There is a lower bound, and it has the same value
944 as the high bound, e.g. CASE (N:N). This is our
945 internal representation of CASE(N).
947 In the first and second case, we need to set a value for
948 high. In the thirth case, we don't because the GCC middle
949 end represents a single case value by just letting high be
950 a NULL_TREE. We can't do that because we need to be able
951 to represent unbounded cases. */
955 && mpz_cmp (cp->low->value.integer,
956 cp->high->value.integer) != 0))
957 high = gfc_conv_constant_to_tree (cp->high);
959 /* Unbounded case. */
961 low = TYPE_MIN_VALUE (TREE_TYPE (se.expr));
965 label = gfc_build_label_decl (NULL_TREE);
967 /* Add this case label.
968 Add parameter 'label', make it match GCC backend. */
969 tmp = build3 (CASE_LABEL_EXPR, void_type_node, low, high, label);
970 gfc_add_expr_to_block (&body, tmp);
973 /* Add the statements for this case. */
974 tmp = gfc_trans_code (c->next);
975 gfc_add_expr_to_block (&body, tmp);
977 /* Break to the end of the construct. */
978 tmp = build1_v (GOTO_EXPR, end_label);
979 gfc_add_expr_to_block (&body, tmp);
982 tmp = gfc_finish_block (&body);
983 tmp = build3_v (SWITCH_EXPR, se.expr, tmp, NULL_TREE);
984 gfc_add_expr_to_block (&block, tmp);
986 tmp = build1_v (LABEL_EXPR, end_label);
987 gfc_add_expr_to_block (&block, tmp);
989 return gfc_finish_block (&block);
993 /* Translate the SELECT CASE construct for LOGICAL case expressions.
995 There are only two cases possible here, even though the standard
996 does allow three cases in a LOGICAL SELECT CASE construct: .TRUE.,
997 .FALSE., and DEFAULT.
999 We never generate more than two blocks here. Instead, we always
1000 try to eliminate the DEFAULT case. This way, we can translate this
1001 kind of SELECT construct to a simple
1005 expression in GENERIC. */
1008 gfc_trans_logical_select (gfc_code * code)
1011 gfc_code *t, *f, *d;
1016 /* Assume we don't have any cases at all. */
1019 /* Now see which ones we actually do have. We can have at most two
1020 cases in a single case list: one for .TRUE. and one for .FALSE.
1021 The default case is always separate. If the cases for .TRUE. and
1022 .FALSE. are in the same case list, the block for that case list
1023 always executed, and we don't generate code a COND_EXPR. */
1024 for (c = code->block; c; c = c->block)
1026 for (cp = c->ext.case_list; cp; cp = cp->next)
1030 if (cp->low->value.logical == 0) /* .FALSE. */
1032 else /* if (cp->value.logical != 0), thus .TRUE. */
1040 /* Start a new block. */
1041 gfc_start_block (&block);
1043 /* Calculate the switch expression. We always need to do this
1044 because it may have side effects. */
1045 gfc_init_se (&se, NULL);
1046 gfc_conv_expr_val (&se, code->expr);
1047 gfc_add_block_to_block (&block, &se.pre);
1049 if (t == f && t != NULL)
1051 /* Cases for .TRUE. and .FALSE. are in the same block. Just
1052 translate the code for these cases, append it to the current
1054 gfc_add_expr_to_block (&block, gfc_trans_code (t->next));
1058 tree true_tree, false_tree;
1060 true_tree = build_empty_stmt ();
1061 false_tree = build_empty_stmt ();
1063 /* If we have a case for .TRUE. and for .FALSE., discard the default case.
1064 Otherwise, if .TRUE. or .FALSE. is missing and there is a default case,
1065 make the missing case the default case. */
1066 if (t != NULL && f != NULL)
1076 /* Translate the code for each of these blocks, and append it to
1077 the current block. */
1079 true_tree = gfc_trans_code (t->next);
1082 false_tree = gfc_trans_code (f->next);
1084 gfc_add_expr_to_block (&block, build3_v (COND_EXPR, se.expr,
1085 true_tree, false_tree));
1088 return gfc_finish_block (&block);
1092 /* Translate the SELECT CASE construct for CHARACTER case expressions.
1093 Instead of generating compares and jumps, it is far simpler to
1094 generate a data structure describing the cases in order and call a
1095 library subroutine that locates the right case.
1096 This is particularly true because this is the only case where we
1097 might have to dispose of a temporary.
1098 The library subroutine returns a pointer to jump to or NULL if no
1099 branches are to be taken. */
1102 gfc_trans_character_select (gfc_code *code)
1104 tree init, node, end_label, tmp, type, args, *labels;
1105 stmtblock_t block, body;
1111 static tree select_struct;
1112 static tree ss_string1, ss_string1_len;
1113 static tree ss_string2, ss_string2_len;
1114 static tree ss_target;
1116 if (select_struct == NULL)
1118 tree gfc_int4_type_node = gfc_get_int_type (4);
1120 select_struct = make_node (RECORD_TYPE);
1121 TYPE_NAME (select_struct) = get_identifier ("_jump_struct");
1124 #define ADD_FIELD(NAME, TYPE) \
1125 ss_##NAME = gfc_add_field_to_struct \
1126 (&(TYPE_FIELDS (select_struct)), select_struct, \
1127 get_identifier (stringize(NAME)), TYPE)
1129 ADD_FIELD (string1, pchar_type_node);
1130 ADD_FIELD (string1_len, gfc_int4_type_node);
1132 ADD_FIELD (string2, pchar_type_node);
1133 ADD_FIELD (string2_len, gfc_int4_type_node);
1135 ADD_FIELD (target, pvoid_type_node);
1138 gfc_finish_type (select_struct);
1141 cp = code->block->ext.case_list;
1142 while (cp->left != NULL)
1146 for (d = cp; d; d = d->right)
1150 labels = gfc_getmem (n * sizeof (tree));
1154 for(i = 0; i < n; i++)
1156 labels[i] = gfc_build_label_decl (NULL_TREE);
1157 TREE_USED (labels[i]) = 1;
1158 /* TODO: The gimplifier should do this for us, but it has
1159 inadequacies when dealing with static initializers. */
1160 FORCED_LABEL (labels[i]) = 1;
1163 end_label = gfc_build_label_decl (NULL_TREE);
1165 /* Generate the body */
1166 gfc_start_block (&block);
1167 gfc_init_block (&body);
1169 for (c = code->block; c; c = c->block)
1171 for (d = c->ext.case_list; d; d = d->next)
1173 tmp = build1_v (LABEL_EXPR, labels[d->n]);
1174 gfc_add_expr_to_block (&body, tmp);
1177 tmp = gfc_trans_code (c->next);
1178 gfc_add_expr_to_block (&body, tmp);
1180 tmp = build1_v (GOTO_EXPR, end_label);
1181 gfc_add_expr_to_block (&body, tmp);
1184 /* Generate the structure describing the branches */
1188 for(d = cp; d; d = d->right, i++)
1192 gfc_init_se (&se, NULL);
1196 node = tree_cons (ss_string1, null_pointer_node, node);
1197 node = tree_cons (ss_string1_len, integer_zero_node, node);
1201 gfc_conv_expr_reference (&se, d->low);
1203 node = tree_cons (ss_string1, se.expr, node);
1204 node = tree_cons (ss_string1_len, se.string_length, node);
1207 if (d->high == NULL)
1209 node = tree_cons (ss_string2, null_pointer_node, node);
1210 node = tree_cons (ss_string2_len, integer_zero_node, node);
1214 gfc_init_se (&se, NULL);
1215 gfc_conv_expr_reference (&se, d->high);
1217 node = tree_cons (ss_string2, se.expr, node);
1218 node = tree_cons (ss_string2_len, se.string_length, node);
1221 tmp = gfc_build_addr_expr (pvoid_type_node, labels[i]);
1222 node = tree_cons (ss_target, tmp, node);
1224 tmp = build1 (CONSTRUCTOR, select_struct, nreverse (node));
1225 init = tree_cons (NULL_TREE, tmp, init);
1228 type = build_array_type (select_struct, build_index_type
1229 (build_int_cst (NULL_TREE, n - 1)));
1231 init = build1 (CONSTRUCTOR, type, nreverse(init));
1232 TREE_CONSTANT (init) = 1;
1233 TREE_INVARIANT (init) = 1;
1234 TREE_STATIC (init) = 1;
1235 /* Create a static variable to hold the jump table. */
1236 tmp = gfc_create_var (type, "jumptable");
1237 TREE_CONSTANT (tmp) = 1;
1238 TREE_INVARIANT (tmp) = 1;
1239 TREE_STATIC (tmp) = 1;
1240 DECL_INITIAL (tmp) = init;
1243 /* Build an argument list for the library call */
1244 init = gfc_build_addr_expr (pvoid_type_node, init);
1245 args = gfc_chainon_list (NULL_TREE, init);
1247 tmp = build_int_cst (NULL_TREE, n);
1248 args = gfc_chainon_list (args, tmp);
1250 tmp = gfc_build_addr_expr (pvoid_type_node, end_label);
1251 args = gfc_chainon_list (args, tmp);
1253 gfc_init_se (&se, NULL);
1254 gfc_conv_expr_reference (&se, code->expr);
1256 args = gfc_chainon_list (args, se.expr);
1257 args = gfc_chainon_list (args, se.string_length);
1259 gfc_add_block_to_block (&block, &se.pre);
1261 tmp = gfc_build_function_call (gfor_fndecl_select_string, args);
1262 tmp = build1 (GOTO_EXPR, void_type_node, tmp);
1263 gfc_add_expr_to_block (&block, tmp);
1265 tmp = gfc_finish_block (&body);
1266 gfc_add_expr_to_block (&block, tmp);
1267 tmp = build1_v (LABEL_EXPR, end_label);
1268 gfc_add_expr_to_block (&block, tmp);
1273 return gfc_finish_block (&block);
1277 /* Translate the three variants of the SELECT CASE construct.
1279 SELECT CASEs with INTEGER case expressions can be translated to an
1280 equivalent GENERIC switch statement, and for LOGICAL case
1281 expressions we build one or two if-else compares.
1283 SELECT CASEs with CHARACTER case expressions are a whole different
1284 story, because they don't exist in GENERIC. So we sort them and
1285 do a binary search at runtime.
1287 Fortran has no BREAK statement, and it does not allow jumps from
1288 one case block to another. That makes things a lot easier for
1292 gfc_trans_select (gfc_code * code)
1294 gcc_assert (code && code->expr);
1296 /* Empty SELECT constructs are legal. */
1297 if (code->block == NULL)
1298 return build_empty_stmt ();
1300 /* Select the correct translation function. */
1301 switch (code->expr->ts.type)
1303 case BT_LOGICAL: return gfc_trans_logical_select (code);
1304 case BT_INTEGER: return gfc_trans_integer_select (code);
1305 case BT_CHARACTER: return gfc_trans_character_select (code);
1307 gfc_internal_error ("gfc_trans_select(): Bad type for case expr.");
1313 /* Generate the loops for a FORALL block. The normal loop format:
1314 count = (end - start + step) / step
1327 gfc_trans_forall_loop (forall_info *forall_tmp, int nvar, tree body, int mask_flag)
1335 tree var, start, end, step, mask, maskindex;
1338 iter = forall_tmp->this_loop;
1339 for (n = 0; n < nvar; n++)
1342 start = iter->start;
1346 exit_label = gfc_build_label_decl (NULL_TREE);
1347 TREE_USED (exit_label) = 1;
1349 /* The loop counter. */
1350 count = gfc_create_var (TREE_TYPE (var), "count");
1352 /* The body of the loop. */
1353 gfc_init_block (&block);
1355 /* The exit condition. */
1356 cond = build2 (LE_EXPR, boolean_type_node, count, integer_zero_node);
1357 tmp = build1_v (GOTO_EXPR, exit_label);
1358 tmp = build3_v (COND_EXPR, cond, tmp, build_empty_stmt ());
1359 gfc_add_expr_to_block (&block, tmp);
1361 /* The main loop body. */
1362 gfc_add_expr_to_block (&block, body);
1364 /* Increment the loop variable. */
1365 tmp = build2 (PLUS_EXPR, TREE_TYPE (var), var, step);
1366 gfc_add_modify_expr (&block, var, tmp);
1368 /* Advance to the next mask element. */
1371 mask = forall_tmp->mask;
1372 maskindex = forall_tmp->maskindex;
1375 tmp = build2 (PLUS_EXPR, gfc_array_index_type,
1376 maskindex, gfc_index_one_node);
1377 gfc_add_modify_expr (&block, maskindex, tmp);
1380 /* Decrement the loop counter. */
1381 tmp = build2 (MINUS_EXPR, TREE_TYPE (var), count, gfc_index_one_node);
1382 gfc_add_modify_expr (&block, count, tmp);
1384 body = gfc_finish_block (&block);
1386 /* Loop var initialization. */
1387 gfc_init_block (&block);
1388 gfc_add_modify_expr (&block, var, start);
1390 /* Initialize the loop counter. */
1391 tmp = fold_build2 (MINUS_EXPR, TREE_TYPE (var), step, start);
1392 tmp = fold_build2 (PLUS_EXPR, TREE_TYPE (var), end, tmp);
1393 tmp = fold_build2 (TRUNC_DIV_EXPR, TREE_TYPE (var), tmp, step);
1394 gfc_add_modify_expr (&block, count, tmp);
1396 /* The loop expression. */
1397 tmp = build1_v (LOOP_EXPR, body);
1398 gfc_add_expr_to_block (&block, tmp);
1400 /* The exit label. */
1401 tmp = build1_v (LABEL_EXPR, exit_label);
1402 gfc_add_expr_to_block (&block, tmp);
1404 body = gfc_finish_block (&block);
1411 /* Generate the body and loops according to MASK_FLAG and NEST_FLAG.
1412 if MASK_FLAG is nonzero, the body is controlled by maskes in forall
1413 nest, otherwise, the body is not controlled by maskes.
1414 if NEST_FLAG is nonzero, generate loops for nested forall, otherwise,
1415 only generate loops for the current forall level. */
1418 gfc_trans_nested_forall_loop (forall_info * nested_forall_info, tree body,
1419 int mask_flag, int nest_flag)
1423 forall_info *forall_tmp;
1424 tree pmask, mask, maskindex;
1426 forall_tmp = nested_forall_info;
1427 /* Generate loops for nested forall. */
1430 while (forall_tmp->next_nest != NULL)
1431 forall_tmp = forall_tmp->next_nest;
1432 while (forall_tmp != NULL)
1434 /* Generate body with masks' control. */
1437 pmask = forall_tmp->pmask;
1438 mask = forall_tmp->mask;
1439 maskindex = forall_tmp->maskindex;
1443 /* If a mask was specified make the assignment conditional. */
1445 tmp = gfc_build_indirect_ref (mask);
1448 tmp = gfc_build_array_ref (tmp, maskindex);
1450 body = build3_v (COND_EXPR, tmp, body, build_empty_stmt ());
1453 nvar = forall_tmp->nvar;
1454 body = gfc_trans_forall_loop (forall_tmp, nvar, body, mask_flag);
1455 forall_tmp = forall_tmp->outer;
1460 nvar = forall_tmp->nvar;
1461 body = gfc_trans_forall_loop (forall_tmp, nvar, body, mask_flag);
1468 /* Allocate data for holding a temporary array. Returns either a local
1469 temporary array or a pointer variable. */
1472 gfc_do_allocate (tree bytesize, tree size, tree * pdata, stmtblock_t * pblock,
1480 if (INTEGER_CST_P (size))
1482 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type, size,
1483 gfc_index_one_node);
1488 type = build_range_type (gfc_array_index_type, gfc_index_zero_node, tmp);
1489 type = build_array_type (elem_type, type);
1490 if (gfc_can_put_var_on_stack (bytesize))
1492 gcc_assert (INTEGER_CST_P (size));
1493 tmpvar = gfc_create_var (type, "temp");
1498 tmpvar = gfc_create_var (build_pointer_type (type), "temp");
1499 *pdata = convert (pvoid_type_node, tmpvar);
1501 args = gfc_chainon_list (NULL_TREE, bytesize);
1502 if (gfc_index_integer_kind == 4)
1503 tmp = gfor_fndecl_internal_malloc;
1504 else if (gfc_index_integer_kind == 8)
1505 tmp = gfor_fndecl_internal_malloc64;
1508 tmp = gfc_build_function_call (tmp, args);
1509 tmp = convert (TREE_TYPE (tmpvar), tmp);
1510 gfc_add_modify_expr (pblock, tmpvar, tmp);
1516 /* Generate codes to copy the temporary to the actual lhs. */
1519 generate_loop_for_temp_to_lhs (gfc_expr *expr, tree tmp1, tree size,
1520 tree count3, tree count1, tree count2, tree wheremask)
1524 stmtblock_t block, body;
1531 lss = gfc_walk_expr (expr);
1533 if (lss == gfc_ss_terminator)
1535 gfc_start_block (&block);
1537 gfc_init_se (&lse, NULL);
1539 /* Translate the expression. */
1540 gfc_conv_expr (&lse, expr);
1542 /* Form the expression for the temporary. */
1543 tmp = gfc_build_array_ref (tmp1, count1);
1545 /* Use the scalar assignment as is. */
1546 gfc_add_block_to_block (&block, &lse.pre);
1547 gfc_add_modify_expr (&block, lse.expr, tmp);
1548 gfc_add_block_to_block (&block, &lse.post);
1550 /* Increment the count1. */
1551 tmp = fold_build2 (PLUS_EXPR, TREE_TYPE (count1), count1, size);
1552 gfc_add_modify_expr (&block, count1, tmp);
1553 tmp = gfc_finish_block (&block);
1557 gfc_start_block (&block);
1559 gfc_init_loopinfo (&loop1);
1560 gfc_init_se (&rse, NULL);
1561 gfc_init_se (&lse, NULL);
1563 /* Associate the lss with the loop. */
1564 gfc_add_ss_to_loop (&loop1, lss);
1566 /* Calculate the bounds of the scalarization. */
1567 gfc_conv_ss_startstride (&loop1);
1568 /* Setup the scalarizing loops. */
1569 gfc_conv_loop_setup (&loop1);
1571 gfc_mark_ss_chain_used (lss, 1);
1572 /* Initialize count2. */
1573 gfc_add_modify_expr (&block, count2, gfc_index_zero_node);
1575 /* Start the scalarized loop body. */
1576 gfc_start_scalarized_body (&loop1, &body);
1578 /* Setup the gfc_se structures. */
1579 gfc_copy_loopinfo_to_se (&lse, &loop1);
1582 /* Form the expression of the temporary. */
1583 if (lss != gfc_ss_terminator)
1585 index = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1587 rse.expr = gfc_build_array_ref (tmp1, index);
1589 /* Translate expr. */
1590 gfc_conv_expr (&lse, expr);
1592 /* Use the scalar assignment. */
1593 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts.type);
1595 /* Form the mask expression according to the mask tree list. */
1598 wheremaskexpr = gfc_build_array_ref (wheremask, count3);
1599 tmp2 = TREE_CHAIN (wheremask);
1602 tmp1 = gfc_build_array_ref (tmp2, count3);
1603 wheremaskexpr = build2 (TRUTH_AND_EXPR, TREE_TYPE (tmp1),
1604 wheremaskexpr, tmp1);
1605 tmp2 = TREE_CHAIN (tmp2);
1607 tmp = build3_v (COND_EXPR, wheremaskexpr, tmp, build_empty_stmt ());
1610 gfc_add_expr_to_block (&body, tmp);
1612 /* Increment count2. */
1613 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1614 count2, gfc_index_one_node);
1615 gfc_add_modify_expr (&body, count2, tmp);
1617 /* Increment count3. */
1620 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1621 count3, gfc_index_one_node);
1622 gfc_add_modify_expr (&body, count3, tmp);
1625 /* Generate the copying loops. */
1626 gfc_trans_scalarizing_loops (&loop1, &body);
1627 gfc_add_block_to_block (&block, &loop1.pre);
1628 gfc_add_block_to_block (&block, &loop1.post);
1629 gfc_cleanup_loop (&loop1);
1631 /* Increment count1. */
1632 tmp = fold_build2 (PLUS_EXPR, TREE_TYPE (count1), count1, size);
1633 gfc_add_modify_expr (&block, count1, tmp);
1634 tmp = gfc_finish_block (&block);
1640 /* Generate codes to copy rhs to the temporary. TMP1 is the address of temporary
1641 LSS and RSS are formed in function compute_inner_temp_size(), and should
1645 generate_loop_for_rhs_to_temp (gfc_expr *expr2, tree tmp1, tree size,
1646 tree count3, tree count1, tree count2,
1647 gfc_ss *lss, gfc_ss *rss, tree wheremask)
1649 stmtblock_t block, body1;
1653 tree tmp, tmp2, index;
1656 gfc_start_block (&block);
1658 gfc_init_se (&rse, NULL);
1659 gfc_init_se (&lse, NULL);
1661 if (lss == gfc_ss_terminator)
1663 gfc_init_block (&body1);
1664 gfc_conv_expr (&rse, expr2);
1665 lse.expr = gfc_build_array_ref (tmp1, count1);
1669 /* Initialize count2. */
1670 gfc_add_modify_expr (&block, count2, gfc_index_zero_node);
1672 /* Initialize the loop. */
1673 gfc_init_loopinfo (&loop);
1675 /* We may need LSS to determine the shape of the expression. */
1676 gfc_add_ss_to_loop (&loop, lss);
1677 gfc_add_ss_to_loop (&loop, rss);
1679 gfc_conv_ss_startstride (&loop);
1680 gfc_conv_loop_setup (&loop);
1682 gfc_mark_ss_chain_used (rss, 1);
1683 /* Start the loop body. */
1684 gfc_start_scalarized_body (&loop, &body1);
1686 /* Translate the expression. */
1687 gfc_copy_loopinfo_to_se (&rse, &loop);
1689 gfc_conv_expr (&rse, expr2);
1691 /* Form the expression of the temporary. */
1692 index = fold_build2 (PLUS_EXPR, gfc_array_index_type, count1, count2);
1693 lse.expr = gfc_build_array_ref (tmp1, index);
1696 /* Use the scalar assignment. */
1697 tmp = gfc_trans_scalar_assign (&lse, &rse, expr2->ts.type);
1699 /* Form the mask expression according to the mask tree list. */
1702 wheremaskexpr = gfc_build_array_ref (wheremask, count3);
1703 tmp2 = TREE_CHAIN (wheremask);
1706 tmp1 = gfc_build_array_ref (tmp2, count3);
1707 wheremaskexpr = build2 (TRUTH_AND_EXPR, TREE_TYPE (tmp1),
1708 wheremaskexpr, tmp1);
1709 tmp2 = TREE_CHAIN (tmp2);
1711 tmp = build3_v (COND_EXPR, wheremaskexpr, tmp, build_empty_stmt ());
1714 gfc_add_expr_to_block (&body1, tmp);
1716 if (lss == gfc_ss_terminator)
1718 gfc_add_block_to_block (&block, &body1);
1722 /* Increment count2. */
1723 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1724 count2, gfc_index_one_node);
1725 gfc_add_modify_expr (&body1, count2, tmp);
1727 /* Increment count3. */
1730 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1731 count3, gfc_index_one_node);
1732 gfc_add_modify_expr (&body1, count3, tmp);
1735 /* Generate the copying loops. */
1736 gfc_trans_scalarizing_loops (&loop, &body1);
1738 gfc_add_block_to_block (&block, &loop.pre);
1739 gfc_add_block_to_block (&block, &loop.post);
1741 gfc_cleanup_loop (&loop);
1742 /* TODO: Reuse lss and rss when copying temp->lhs. Need to be careful
1743 as tree nodes in SS may not be valid in different scope. */
1745 /* Increment count1. */
1746 tmp = fold_build2 (PLUS_EXPR, TREE_TYPE (count1), count1, size);
1747 gfc_add_modify_expr (&block, count1, tmp);
1749 tmp = gfc_finish_block (&block);
1754 /* Calculate the size of temporary needed in the assignment inside forall.
1755 LSS and RSS are filled in this function. */
1758 compute_inner_temp_size (gfc_expr *expr1, gfc_expr *expr2,
1759 stmtblock_t * pblock,
1760 gfc_ss **lss, gfc_ss **rss)
1767 *lss = gfc_walk_expr (expr1);
1770 size = gfc_index_one_node;
1771 if (*lss != gfc_ss_terminator)
1773 gfc_init_loopinfo (&loop);
1775 /* Walk the RHS of the expression. */
1776 *rss = gfc_walk_expr (expr2);
1777 if (*rss == gfc_ss_terminator)
1779 /* The rhs is scalar. Add a ss for the expression. */
1780 *rss = gfc_get_ss ();
1781 (*rss)->next = gfc_ss_terminator;
1782 (*rss)->type = GFC_SS_SCALAR;
1783 (*rss)->expr = expr2;
1786 /* Associate the SS with the loop. */
1787 gfc_add_ss_to_loop (&loop, *lss);
1788 /* We don't actually need to add the rhs at this point, but it might
1789 make guessing the loop bounds a bit easier. */
1790 gfc_add_ss_to_loop (&loop, *rss);
1792 /* We only want the shape of the expression, not rest of the junk
1793 generated by the scalarizer. */
1794 loop.array_parameter = 1;
1796 /* Calculate the bounds of the scalarization. */
1797 gfc_conv_ss_startstride (&loop);
1798 gfc_conv_loop_setup (&loop);
1800 /* Figure out how many elements we need. */
1801 for (i = 0; i < loop.dimen; i++)
1803 tmp = fold_build2 (MINUS_EXPR, gfc_array_index_type,
1804 gfc_index_one_node, loop.from[i]);
1805 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
1807 size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
1809 gfc_add_block_to_block (pblock, &loop.pre);
1810 size = gfc_evaluate_now (size, pblock);
1811 gfc_add_block_to_block (pblock, &loop.post);
1813 /* TODO: write a function that cleans up a loopinfo without freeing
1814 the SS chains. Currently a NOP. */
1821 /* Calculate the overall iterator number of the nested forall construct. */
1824 compute_overall_iter_number (forall_info *nested_forall_info, tree inner_size,
1830 /* TODO: optimizing the computing process. */
1831 number = gfc_create_var (gfc_array_index_type, "num");
1832 gfc_add_modify_expr (block, number, gfc_index_zero_node);
1834 gfc_start_block (&body);
1835 if (nested_forall_info)
1836 tmp = build2 (PLUS_EXPR, gfc_array_index_type, number,
1840 gfc_add_modify_expr (&body, number, tmp);
1841 tmp = gfc_finish_block (&body);
1843 /* Generate loops. */
1844 if (nested_forall_info != NULL)
1845 tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 0, 1);
1847 gfc_add_expr_to_block (block, tmp);
1853 /* Allocate temporary for forall construct according to the information in
1854 nested_forall_info. INNER_SIZE is the size of temporary needed in the
1855 assignment inside forall. PTEMP1 is returned for space free. */
1858 allocate_temp_for_forall_nest (forall_info * nested_forall_info, tree type,
1859 tree inner_size, stmtblock_t * block,
1865 tree bytesize, size;
1867 /* Calculate the total size of temporary needed in forall construct. */
1868 size = compute_overall_iter_number (nested_forall_info, inner_size, block);
1870 unit = TYPE_SIZE_UNIT (type);
1871 bytesize = fold_build2 (MULT_EXPR, gfc_array_index_type, size, unit);
1874 temp1 = gfc_do_allocate (bytesize, size, ptemp1, block, type);
1877 tmp = gfc_build_indirect_ref (temp1);
1885 /* Handle assignments inside forall which need temporary. */
1887 gfc_trans_assign_need_temp (gfc_expr * expr1, gfc_expr * expr2, tree wheremask,
1888 forall_info * nested_forall_info,
1889 stmtblock_t * block)
1894 tree count, count1, count2;
1897 tree mask, maskindex;
1898 forall_info *forall_tmp;
1900 /* Create vars. count1 is the current iterator number of the nested forall.
1901 count2 is the current iterator number of the inner loops needed in the
1903 count1 = gfc_create_var (gfc_array_index_type, "count1");
1904 count2 = gfc_create_var (gfc_array_index_type, "count2");
1906 /* Count is the wheremask index. */
1909 count = gfc_create_var (gfc_array_index_type, "count");
1910 gfc_add_modify_expr (block, count, gfc_index_zero_node);
1915 /* Initialize count1. */
1916 gfc_add_modify_expr (block, count1, gfc_index_zero_node);
1918 /* Calculate the size of temporary needed in the assignment. Return loop, lss
1919 and rss which are used in function generate_loop_for_rhs_to_temp(). */
1920 inner_size = compute_inner_temp_size (expr1, expr2, block, &lss, &rss);
1922 /* The type of LHS. Used in function allocate_temp_for_forall_nest */
1923 type = gfc_typenode_for_spec (&expr1->ts);
1925 /* Allocate temporary for nested forall construct according to the
1926 information in nested_forall_info and inner_size. */
1927 tmp1 = allocate_temp_for_forall_nest (nested_forall_info, type,
1928 inner_size, block, &ptemp1);
1930 /* Initialize the maskindexes. */
1931 forall_tmp = nested_forall_info;
1932 while (forall_tmp != NULL)
1934 mask = forall_tmp->mask;
1935 maskindex = forall_tmp->maskindex;
1937 gfc_add_modify_expr (block, maskindex, gfc_index_zero_node);
1938 forall_tmp = forall_tmp->next_nest;
1941 /* Generate codes to copy rhs to the temporary . */
1942 tmp = generate_loop_for_rhs_to_temp (expr2, tmp1, inner_size, count,
1943 count1, count2, lss, rss, wheremask);
1945 /* Generate body and loops according to the information in
1946 nested_forall_info. */
1947 tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1, 1);
1948 gfc_add_expr_to_block (block, tmp);
1951 gfc_add_modify_expr (block, count1, gfc_index_zero_node);
1953 /* Reset maskindexed. */
1954 forall_tmp = nested_forall_info;
1955 while (forall_tmp != NULL)
1957 mask = forall_tmp->mask;
1958 maskindex = forall_tmp->maskindex;
1960 gfc_add_modify_expr (block, maskindex, gfc_index_zero_node);
1961 forall_tmp = forall_tmp->next_nest;
1966 gfc_add_modify_expr (block, count, gfc_index_zero_node);
1968 /* Generate codes to copy the temporary to lhs. */
1969 tmp = generate_loop_for_temp_to_lhs (expr1, tmp1, inner_size, count,
1970 count1, count2, wheremask);
1972 /* Generate body and loops according to the information in
1973 nested_forall_info. */
1974 tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1, 1);
1975 gfc_add_expr_to_block (block, tmp);
1979 /* Free the temporary. */
1980 tmp = gfc_chainon_list (NULL_TREE, ptemp1);
1981 tmp = gfc_build_function_call (gfor_fndecl_internal_free, tmp);
1982 gfc_add_expr_to_block (block, tmp);
1987 /* Translate pointer assignment inside FORALL which need temporary. */
1990 gfc_trans_pointer_assign_need_temp (gfc_expr * expr1, gfc_expr * expr2,
1991 forall_info * nested_forall_info,
1992 stmtblock_t * block)
2006 tree tmp, tmp1, ptemp1;
2007 tree mask, maskindex;
2008 forall_info *forall_tmp;
2010 count = gfc_create_var (gfc_array_index_type, "count");
2011 gfc_add_modify_expr (block, count, gfc_index_zero_node);
2013 inner_size = integer_one_node;
2014 lss = gfc_walk_expr (expr1);
2015 rss = gfc_walk_expr (expr2);
2016 if (lss == gfc_ss_terminator)
2018 type = gfc_typenode_for_spec (&expr1->ts);
2019 type = build_pointer_type (type);
2021 /* Allocate temporary for nested forall construct according to the
2022 information in nested_forall_info and inner_size. */
2023 tmp1 = allocate_temp_for_forall_nest (nested_forall_info,
2024 type, inner_size, block, &ptemp1);
2025 gfc_start_block (&body);
2026 gfc_init_se (&lse, NULL);
2027 lse.expr = gfc_build_array_ref (tmp1, count);
2028 gfc_init_se (&rse, NULL);
2029 rse.want_pointer = 1;
2030 gfc_conv_expr (&rse, expr2);
2031 gfc_add_block_to_block (&body, &rse.pre);
2032 gfc_add_modify_expr (&body, lse.expr, rse.expr);
2033 gfc_add_block_to_block (&body, &rse.post);
2035 /* Increment count. */
2036 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2037 count, gfc_index_one_node);
2038 gfc_add_modify_expr (&body, count, tmp);
2040 tmp = gfc_finish_block (&body);
2042 /* Initialize the maskindexes. */
2043 forall_tmp = nested_forall_info;
2044 while (forall_tmp != NULL)
2046 mask = forall_tmp->mask;
2047 maskindex = forall_tmp->maskindex;
2049 gfc_add_modify_expr (block, maskindex, gfc_index_zero_node);
2050 forall_tmp = forall_tmp->next_nest;
2053 /* Generate body and loops according to the information in
2054 nested_forall_info. */
2055 tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1, 1);
2056 gfc_add_expr_to_block (block, tmp);
2059 gfc_add_modify_expr (block, count, gfc_index_zero_node);
2061 /* Reset maskindexes. */
2062 forall_tmp = nested_forall_info;
2063 while (forall_tmp != NULL)
2065 mask = forall_tmp->mask;
2066 maskindex = forall_tmp->maskindex;
2068 gfc_add_modify_expr (block, maskindex, gfc_index_zero_node);
2069 forall_tmp = forall_tmp->next_nest;
2071 gfc_start_block (&body);
2072 gfc_init_se (&lse, NULL);
2073 gfc_init_se (&rse, NULL);
2074 rse.expr = gfc_build_array_ref (tmp1, count);
2075 lse.want_pointer = 1;
2076 gfc_conv_expr (&lse, expr1);
2077 gfc_add_block_to_block (&body, &lse.pre);
2078 gfc_add_modify_expr (&body, lse.expr, rse.expr);
2079 gfc_add_block_to_block (&body, &lse.post);
2080 /* Increment count. */
2081 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2082 count, gfc_index_one_node);
2083 gfc_add_modify_expr (&body, count, tmp);
2084 tmp = gfc_finish_block (&body);
2086 /* Generate body and loops according to the information in
2087 nested_forall_info. */
2088 tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1, 1);
2089 gfc_add_expr_to_block (block, tmp);
2093 gfc_init_loopinfo (&loop);
2095 /* Associate the SS with the loop. */
2096 gfc_add_ss_to_loop (&loop, rss);
2098 /* Setup the scalarizing loops and bounds. */
2099 gfc_conv_ss_startstride (&loop);
2101 gfc_conv_loop_setup (&loop);
2103 info = &rss->data.info;
2104 desc = info->descriptor;
2106 /* Make a new descriptor. */
2107 parmtype = gfc_get_element_type (TREE_TYPE (desc));
2108 parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen,
2109 loop.from, loop.to, 1);
2111 /* Allocate temporary for nested forall construct. */
2112 tmp1 = allocate_temp_for_forall_nest (nested_forall_info, parmtype,
2113 inner_size, block, &ptemp1);
2114 gfc_start_block (&body);
2115 gfc_init_se (&lse, NULL);
2116 lse.expr = gfc_build_array_ref (tmp1, count);
2117 lse.direct_byref = 1;
2118 rss = gfc_walk_expr (expr2);
2119 gfc_conv_expr_descriptor (&lse, expr2, rss);
2121 gfc_add_block_to_block (&body, &lse.pre);
2122 gfc_add_block_to_block (&body, &lse.post);
2124 /* Increment count. */
2125 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2126 count, gfc_index_one_node);
2127 gfc_add_modify_expr (&body, count, tmp);
2129 tmp = gfc_finish_block (&body);
2131 /* Initialize the maskindexes. */
2132 forall_tmp = nested_forall_info;
2133 while (forall_tmp != NULL)
2135 mask = forall_tmp->mask;
2136 maskindex = forall_tmp->maskindex;
2138 gfc_add_modify_expr (block, maskindex, gfc_index_zero_node);
2139 forall_tmp = forall_tmp->next_nest;
2142 /* Generate body and loops according to the information in
2143 nested_forall_info. */
2144 tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1, 1);
2145 gfc_add_expr_to_block (block, tmp);
2148 gfc_add_modify_expr (block, count, gfc_index_zero_node);
2150 /* Reset maskindexes. */
2151 forall_tmp = nested_forall_info;
2152 while (forall_tmp != NULL)
2154 mask = forall_tmp->mask;
2155 maskindex = forall_tmp->maskindex;
2157 gfc_add_modify_expr (block, maskindex, gfc_index_zero_node);
2158 forall_tmp = forall_tmp->next_nest;
2160 parm = gfc_build_array_ref (tmp1, count);
2161 lss = gfc_walk_expr (expr1);
2162 gfc_init_se (&lse, NULL);
2163 gfc_conv_expr_descriptor (&lse, expr1, lss);
2164 gfc_add_modify_expr (&lse.pre, lse.expr, parm);
2165 gfc_start_block (&body);
2166 gfc_add_block_to_block (&body, &lse.pre);
2167 gfc_add_block_to_block (&body, &lse.post);
2169 /* Increment count. */
2170 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2171 count, gfc_index_one_node);
2172 gfc_add_modify_expr (&body, count, tmp);
2174 tmp = gfc_finish_block (&body);
2176 tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1, 1);
2177 gfc_add_expr_to_block (block, tmp);
2179 /* Free the temporary. */
2182 tmp = gfc_chainon_list (NULL_TREE, ptemp1);
2183 tmp = gfc_build_function_call (gfor_fndecl_internal_free, tmp);
2184 gfc_add_expr_to_block (block, tmp);
2189 /* FORALL and WHERE statements are really nasty, especially when you nest
2190 them. All the rhs of a forall assignment must be evaluated before the
2191 actual assignments are performed. Presumably this also applies to all the
2192 assignments in an inner where statement. */
2194 /* Generate code for a FORALL statement. Any temporaries are allocated as a
2195 linear array, relying on the fact that we process in the same order in all
2198 forall (i=start:end:stride; maskexpr)
2202 (where e,f,g,h<i> are arbitrary expressions possibly involving i)
2204 count = ((end + 1 - start) / staride)
2205 masktmp(:) = maskexpr(:)
2208 for (i = start; i <= end; i += stride)
2210 if (masktmp[maskindex++])
2214 for (i = start; i <= end; i += stride)
2216 if (masktmp[maskindex++])
2220 Note that this code only works when there are no dependencies.
2221 Forall loop with array assignments and data dependencies are a real pain,
2222 because the size of the temporary cannot always be determined before the
2223 loop is executed. This problem is compounded by the presence of nested
2228 gfc_trans_forall_1 (gfc_code * code, forall_info * nested_forall_info)
2250 gfc_forall_iterator *fa;
2253 gfc_saved_var *saved_vars;
2254 iter_info *this_forall, *iter_tmp;
2255 forall_info *info, *forall_tmp;
2256 temporary_list *temp;
2258 gfc_start_block (&block);
2261 /* Count the FORALL index number. */
2262 for (fa = code->ext.forall_iterator; fa; fa = fa->next)
2266 /* Allocate the space for var, start, end, step, varexpr. */
2267 var = (tree *) gfc_getmem (nvar * sizeof (tree));
2268 start = (tree *) gfc_getmem (nvar * sizeof (tree));
2269 end = (tree *) gfc_getmem (nvar * sizeof (tree));
2270 step = (tree *) gfc_getmem (nvar * sizeof (tree));
2271 varexpr = (gfc_expr **) gfc_getmem (nvar * sizeof (gfc_expr *));
2272 saved_vars = (gfc_saved_var *) gfc_getmem (nvar * sizeof (gfc_saved_var));
2274 /* Allocate the space for info. */
2275 info = (forall_info *) gfc_getmem (sizeof (forall_info));
2277 for (fa = code->ext.forall_iterator; fa; fa = fa->next)
2279 gfc_symbol *sym = fa->var->symtree->n.sym;
2281 /* allocate space for this_forall. */
2282 this_forall = (iter_info *) gfc_getmem (sizeof (iter_info));
2284 /* Create a temporary variable for the FORALL index. */
2285 tmp = gfc_typenode_for_spec (&sym->ts);
2286 var[n] = gfc_create_var (tmp, sym->name);
2287 gfc_shadow_sym (sym, var[n], &saved_vars[n]);
2289 /* Record it in this_forall. */
2290 this_forall->var = var[n];
2292 /* Replace the index symbol's backend_decl with the temporary decl. */
2293 sym->backend_decl = var[n];
2295 /* Work out the start, end and stride for the loop. */
2296 gfc_init_se (&se, NULL);
2297 gfc_conv_expr_val (&se, fa->start);
2298 /* Record it in this_forall. */
2299 this_forall->start = se.expr;
2300 gfc_add_block_to_block (&block, &se.pre);
2303 gfc_init_se (&se, NULL);
2304 gfc_conv_expr_val (&se, fa->end);
2305 /* Record it in this_forall. */
2306 this_forall->end = se.expr;
2307 gfc_make_safe_expr (&se);
2308 gfc_add_block_to_block (&block, &se.pre);
2311 gfc_init_se (&se, NULL);
2312 gfc_conv_expr_val (&se, fa->stride);
2313 /* Record it in this_forall. */
2314 this_forall->step = se.expr;
2315 gfc_make_safe_expr (&se);
2316 gfc_add_block_to_block (&block, &se.pre);
2319 /* Set the NEXT field of this_forall to NULL. */
2320 this_forall->next = NULL;
2321 /* Link this_forall to the info construct. */
2322 if (info->this_loop == NULL)
2323 info->this_loop = this_forall;
2326 iter_tmp = info->this_loop;
2327 while (iter_tmp->next != NULL)
2328 iter_tmp = iter_tmp->next;
2329 iter_tmp->next = this_forall;
2336 /* Work out the number of elements in the mask array. */
2339 size = gfc_index_one_node;
2340 sizevar = NULL_TREE;
2342 for (n = 0; n < nvar; n++)
2344 if (lenvar && TREE_TYPE (lenvar) != TREE_TYPE (start[n]))
2347 /* size = (end + step - start) / step. */
2348 tmp = fold_build2 (MINUS_EXPR, TREE_TYPE (start[n]),
2350 tmp = fold_build2 (PLUS_EXPR, TREE_TYPE (end[n]), end[n], tmp);
2352 tmp = fold_build2 (FLOOR_DIV_EXPR, TREE_TYPE (tmp), tmp, step[n]);
2353 tmp = convert (gfc_array_index_type, tmp);
2355 size = fold_build2 (MULT_EXPR, gfc_array_index_type, size, tmp);
2358 /* Record the nvar and size of current forall level. */
2362 /* Link the current forall level to nested_forall_info. */
2363 forall_tmp = nested_forall_info;
2364 if (forall_tmp == NULL)
2365 nested_forall_info = info;
2368 while (forall_tmp->next_nest != NULL)
2369 forall_tmp = forall_tmp->next_nest;
2370 info->outer = forall_tmp;
2371 forall_tmp->next_nest = info;
2374 /* Copy the mask into a temporary variable if required.
2375 For now we assume a mask temporary is needed. */
2378 /* Allocate the mask temporary. */
2379 bytesize = fold_build2 (MULT_EXPR, gfc_array_index_type, size,
2380 TYPE_SIZE_UNIT (boolean_type_node));
2382 mask = gfc_do_allocate (bytesize, size, &pmask, &block, boolean_type_node);
2384 maskindex = gfc_create_var_np (gfc_array_index_type, "mi");
2385 /* Record them in the info structure. */
2386 info->pmask = pmask;
2388 info->maskindex = maskindex;
2390 gfc_add_modify_expr (&block, maskindex, gfc_index_zero_node);
2392 /* Start of mask assignment loop body. */
2393 gfc_start_block (&body);
2395 /* Evaluate the mask expression. */
2396 gfc_init_se (&se, NULL);
2397 gfc_conv_expr_val (&se, code->expr);
2398 gfc_add_block_to_block (&body, &se.pre);
2400 /* Store the mask. */
2401 se.expr = convert (boolean_type_node, se.expr);
2404 tmp = gfc_build_indirect_ref (mask);
2407 tmp = gfc_build_array_ref (tmp, maskindex);
2408 gfc_add_modify_expr (&body, tmp, se.expr);
2410 /* Advance to the next mask element. */
2411 tmp = build2 (PLUS_EXPR, gfc_array_index_type,
2412 maskindex, gfc_index_one_node);
2413 gfc_add_modify_expr (&body, maskindex, tmp);
2415 /* Generate the loops. */
2416 tmp = gfc_finish_block (&body);
2417 tmp = gfc_trans_nested_forall_loop (info, tmp, 0, 0);
2418 gfc_add_expr_to_block (&block, tmp);
2422 /* No mask was specified. */
2423 maskindex = NULL_TREE;
2424 mask = pmask = NULL_TREE;
2427 c = code->block->next;
2429 /* TODO: loop merging in FORALL statements. */
2430 /* Now that we've got a copy of the mask, generate the assignment loops. */
2436 /* A scalar or array assignment. */
2437 need_temp = gfc_check_dependency (c->expr, c->expr2, varexpr, nvar);
2438 /* Temporaries due to array assignment data dependencies introduce
2439 no end of problems. */
2441 gfc_trans_assign_need_temp (c->expr, c->expr2, NULL,
2442 nested_forall_info, &block);
2445 /* Use the normal assignment copying routines. */
2446 assign = gfc_trans_assignment (c->expr, c->expr2);
2448 /* Reset the mask index. */
2450 gfc_add_modify_expr (&block, maskindex, gfc_index_zero_node);
2452 /* Generate body and loops. */
2453 tmp = gfc_trans_nested_forall_loop (nested_forall_info, assign, 1, 1);
2454 gfc_add_expr_to_block (&block, tmp);
2461 /* Translate WHERE or WHERE construct nested in FORALL. */
2463 gfc_trans_where_2 (c, NULL, NULL, nested_forall_info, &block, &temp);
2470 /* Free the temporary. */
2471 args = gfc_chainon_list (NULL_TREE, temp->temporary);
2472 tmp = gfc_build_function_call (gfor_fndecl_internal_free, args);
2473 gfc_add_expr_to_block (&block, tmp);
2482 /* Pointer assignment inside FORALL. */
2483 case EXEC_POINTER_ASSIGN:
2484 need_temp = gfc_check_dependency (c->expr, c->expr2, varexpr, nvar);
2486 gfc_trans_pointer_assign_need_temp (c->expr, c->expr2,
2487 nested_forall_info, &block);
2490 /* Use the normal assignment copying routines. */
2491 assign = gfc_trans_pointer_assignment (c->expr, c->expr2);
2493 /* Reset the mask index. */
2495 gfc_add_modify_expr (&block, maskindex, gfc_index_zero_node);
2497 /* Generate body and loops. */
2498 tmp = gfc_trans_nested_forall_loop (nested_forall_info, assign,
2500 gfc_add_expr_to_block (&block, tmp);
2505 tmp = gfc_trans_forall_1 (c, nested_forall_info);
2506 gfc_add_expr_to_block (&block, tmp);
2516 /* Restore the original index variables. */
2517 for (fa = code->ext.forall_iterator, n = 0; fa; fa = fa->next, n++)
2518 gfc_restore_sym (fa->var->symtree->n.sym, &saved_vars[n]);
2520 /* Free the space for var, start, end, step, varexpr. */
2526 gfc_free (saved_vars);
2530 /* Free the temporary for the mask. */
2531 tmp = gfc_chainon_list (NULL_TREE, pmask);
2532 tmp = gfc_build_function_call (gfor_fndecl_internal_free, tmp);
2533 gfc_add_expr_to_block (&block, tmp);
2536 pushdecl (maskindex);
2538 return gfc_finish_block (&block);
2542 /* Translate the FORALL statement or construct. */
2544 tree gfc_trans_forall (gfc_code * code)
2546 return gfc_trans_forall_1 (code, NULL);
2550 /* Evaluate the WHERE mask expression, copy its value to a temporary.
2551 If the WHERE construct is nested in FORALL, compute the overall temporary
2552 needed by the WHERE mask expression multiplied by the iterator number of
2554 ME is the WHERE mask expression.
2555 MASK is the temporary which value is mask's value.
2556 NMASK is another temporary which value is !mask.
2557 TEMP records the temporary's address allocated in this function in order to
2558 free them outside this function.
2559 MASK, NMASK and TEMP are all OUT arguments. */
2562 gfc_evaluate_where_mask (gfc_expr * me, forall_info * nested_forall_info,
2563 tree * mask, tree * nmask, temporary_list ** temp,
2564 stmtblock_t * block)
2569 tree ptemp1, ntmp, ptemp2;
2571 stmtblock_t body, body1;
2576 gfc_init_loopinfo (&loop);
2578 /* Calculate the size of temporary needed by the mask-expr. */
2579 inner_size = compute_inner_temp_size (me, me, block, &lss, &rss);
2581 /* Allocate temporary for where mask. */
2582 tmp = allocate_temp_for_forall_nest (nested_forall_info, boolean_type_node,
2583 inner_size, block, &ptemp1);
2584 /* Record the temporary address in order to free it later. */
2587 temporary_list *tempo;
2588 tempo = (temporary_list *) gfc_getmem (sizeof (temporary_list));
2589 tempo->temporary = ptemp1;
2590 tempo->next = *temp;
2594 /* Allocate temporary for !mask. */
2595 ntmp = allocate_temp_for_forall_nest (nested_forall_info, boolean_type_node,
2596 inner_size, block, &ptemp2);
2597 /* Record the temporary in order to free it later. */
2600 temporary_list *tempo;
2601 tempo = (temporary_list *) gfc_getmem (sizeof (temporary_list));
2602 tempo->temporary = ptemp2;
2603 tempo->next = *temp;
2607 /* Variable to index the temporary. */
2608 count = gfc_create_var (gfc_array_index_type, "count");
2609 /* Initialize count. */
2610 gfc_add_modify_expr (block, count, gfc_index_zero_node);
2612 gfc_start_block (&body);
2614 gfc_init_se (&rse, NULL);
2615 gfc_init_se (&lse, NULL);
2617 if (lss == gfc_ss_terminator)
2619 gfc_init_block (&body1);
2623 /* Initialize the loop. */
2624 gfc_init_loopinfo (&loop);
2626 /* We may need LSS to determine the shape of the expression. */
2627 gfc_add_ss_to_loop (&loop, lss);
2628 gfc_add_ss_to_loop (&loop, rss);
2630 gfc_conv_ss_startstride (&loop);
2631 gfc_conv_loop_setup (&loop);
2633 gfc_mark_ss_chain_used (rss, 1);
2634 /* Start the loop body. */
2635 gfc_start_scalarized_body (&loop, &body1);
2637 /* Translate the expression. */
2638 gfc_copy_loopinfo_to_se (&rse, &loop);
2640 gfc_conv_expr (&rse, me);
2642 /* Form the expression of the temporary. */
2643 lse.expr = gfc_build_array_ref (tmp, count);
2644 tmpexpr = gfc_build_array_ref (ntmp, count);
2646 /* Use the scalar assignment to fill temporary TMP. */
2647 tmp1 = gfc_trans_scalar_assign (&lse, &rse, me->ts.type);
2648 gfc_add_expr_to_block (&body1, tmp1);
2650 /* Fill temporary NTMP. */
2651 tmp1 = build1 (TRUTH_NOT_EXPR, TREE_TYPE (lse.expr), lse.expr);
2652 gfc_add_modify_expr (&body1, tmpexpr, tmp1);
2654 if (lss == gfc_ss_terminator)
2656 gfc_add_block_to_block (&body, &body1);
2660 /* Increment count. */
2661 tmp1 = fold_build2 (PLUS_EXPR, gfc_array_index_type, count,
2662 gfc_index_one_node);
2663 gfc_add_modify_expr (&body1, count, tmp1);
2665 /* Generate the copying loops. */
2666 gfc_trans_scalarizing_loops (&loop, &body1);
2668 gfc_add_block_to_block (&body, &loop.pre);
2669 gfc_add_block_to_block (&body, &loop.post);
2671 gfc_cleanup_loop (&loop);
2672 /* TODO: Reuse lss and rss when copying temp->lhs. Need to be careful
2673 as tree nodes in SS may not be valid in different scope. */
2676 tmp1 = gfc_finish_block (&body);
2677 /* If the WHERE construct is inside FORALL, fill the full temporary. */
2678 if (nested_forall_info != NULL)
2679 tmp1 = gfc_trans_nested_forall_loop (nested_forall_info, tmp1, 1, 1);
2682 gfc_add_expr_to_block (block, tmp1);
2691 /* Translate an assignment statement in a WHERE statement or construct
2692 statement. The MASK expression is used to control which elements
2693 of EXPR1 shall be assigned. */
2696 gfc_trans_where_assign (gfc_expr *expr1, gfc_expr *expr2, tree mask,
2697 tree count1, tree count2)
2702 gfc_ss *lss_section;
2709 tree index, maskexpr, tmp1;
2712 /* TODO: handle this special case.
2713 Special case a single function returning an array. */
2714 if (expr2->expr_type == EXPR_FUNCTION && expr2->rank > 0)
2716 tmp = gfc_trans_arrayfunc_assign (expr1, expr2);
2722 /* Assignment of the form lhs = rhs. */
2723 gfc_start_block (&block);
2725 gfc_init_se (&lse, NULL);
2726 gfc_init_se (&rse, NULL);
2729 lss = gfc_walk_expr (expr1);
2732 /* In each where-assign-stmt, the mask-expr and the variable being
2733 defined shall be arrays of the same shape. */
2734 gcc_assert (lss != gfc_ss_terminator);
2736 /* The assignment needs scalarization. */
2739 /* Find a non-scalar SS from the lhs. */
2740 while (lss_section != gfc_ss_terminator
2741 && lss_section->type != GFC_SS_SECTION)
2742 lss_section = lss_section->next;
2744 gcc_assert (lss_section != gfc_ss_terminator);
2746 /* Initialize the scalarizer. */
2747 gfc_init_loopinfo (&loop);
2750 rss = gfc_walk_expr (expr2);
2751 if (rss == gfc_ss_terminator)
2753 /* The rhs is scalar. Add a ss for the expression. */
2754 rss = gfc_get_ss ();
2755 rss->next = gfc_ss_terminator;
2756 rss->type = GFC_SS_SCALAR;
2760 /* Associate the SS with the loop. */
2761 gfc_add_ss_to_loop (&loop, lss);
2762 gfc_add_ss_to_loop (&loop, rss);
2764 /* Calculate the bounds of the scalarization. */
2765 gfc_conv_ss_startstride (&loop);
2767 /* Resolve any data dependencies in the statement. */
2768 gfc_conv_resolve_dependencies (&loop, lss_section, rss);
2770 /* Setup the scalarizing loops. */
2771 gfc_conv_loop_setup (&loop);
2773 /* Setup the gfc_se structures. */
2774 gfc_copy_loopinfo_to_se (&lse, &loop);
2775 gfc_copy_loopinfo_to_se (&rse, &loop);
2778 gfc_mark_ss_chain_used (rss, 1);
2779 if (loop.temp_ss == NULL)
2782 gfc_mark_ss_chain_used (lss, 1);
2786 lse.ss = loop.temp_ss;
2787 gfc_mark_ss_chain_used (lss, 3);
2788 gfc_mark_ss_chain_used (loop.temp_ss, 3);
2791 /* Start the scalarized loop body. */
2792 gfc_start_scalarized_body (&loop, &body);
2794 /* Translate the expression. */
2795 gfc_conv_expr (&rse, expr2);
2796 if (lss != gfc_ss_terminator && loop.temp_ss != NULL)
2798 gfc_conv_tmp_array_ref (&lse);
2799 gfc_advance_se_ss_chain (&lse);
2802 gfc_conv_expr (&lse, expr1);
2804 /* Form the mask expression according to the mask tree list. */
2808 maskexpr = gfc_build_array_ref (tmp, index);
2812 tmp = TREE_CHAIN (tmp);
2815 tmp1 = gfc_build_array_ref (tmp, index);
2816 maskexpr = build2 (TRUTH_AND_EXPR, TREE_TYPE (tmp1), maskexpr, tmp1);
2817 tmp = TREE_CHAIN (tmp);
2819 /* Use the scalar assignment as is. */
2820 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts.type);
2821 tmp = build3_v (COND_EXPR, maskexpr, tmp, build_empty_stmt ());
2823 gfc_add_expr_to_block (&body, tmp);
2825 if (lss == gfc_ss_terminator)
2827 /* Increment count1. */
2828 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2829 count1, gfc_index_one_node);
2830 gfc_add_modify_expr (&body, count1, tmp);
2832 /* Use the scalar assignment as is. */
2833 gfc_add_block_to_block (&block, &body);
2837 gcc_assert (lse.ss == gfc_ss_terminator
2838 && rse.ss == gfc_ss_terminator);
2840 if (loop.temp_ss != NULL)
2842 /* Increment count1 before finish the main body of a scalarized
2844 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2845 count1, gfc_index_one_node);
2846 gfc_add_modify_expr (&body, count1, tmp);
2847 gfc_trans_scalarized_loop_boundary (&loop, &body);
2849 /* We need to copy the temporary to the actual lhs. */
2850 gfc_init_se (&lse, NULL);
2851 gfc_init_se (&rse, NULL);
2852 gfc_copy_loopinfo_to_se (&lse, &loop);
2853 gfc_copy_loopinfo_to_se (&rse, &loop);
2855 rse.ss = loop.temp_ss;
2858 gfc_conv_tmp_array_ref (&rse);
2859 gfc_advance_se_ss_chain (&rse);
2860 gfc_conv_expr (&lse, expr1);
2862 gcc_assert (lse.ss == gfc_ss_terminator
2863 && rse.ss == gfc_ss_terminator);
2865 /* Form the mask expression according to the mask tree list. */
2869 maskexpr = gfc_build_array_ref (tmp, index);
2873 tmp = TREE_CHAIN (tmp);
2876 tmp1 = gfc_build_array_ref (tmp, index);
2877 maskexpr = build2 (TRUTH_AND_EXPR, TREE_TYPE (tmp1),
2879 tmp = TREE_CHAIN (tmp);
2881 /* Use the scalar assignment as is. */
2882 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts.type);
2883 tmp = build3_v (COND_EXPR, maskexpr, tmp, build_empty_stmt ());
2884 gfc_add_expr_to_block (&body, tmp);
2886 /* Increment count2. */
2887 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2888 count2, gfc_index_one_node);
2889 gfc_add_modify_expr (&body, count2, tmp);
2893 /* Increment count1. */
2894 tmp = fold_build2 (PLUS_EXPR, gfc_array_index_type,
2895 count1, gfc_index_one_node);
2896 gfc_add_modify_expr (&body, count1, tmp);
2899 /* Generate the copying loops. */
2900 gfc_trans_scalarizing_loops (&loop, &body);
2902 /* Wrap the whole thing up. */
2903 gfc_add_block_to_block (&block, &loop.pre);
2904 gfc_add_block_to_block (&block, &loop.post);
2905 gfc_cleanup_loop (&loop);
2908 return gfc_finish_block (&block);
2912 /* Translate the WHERE construct or statement.
2913 This fuction can be called iteratively to translate the nested WHERE
2914 construct or statement.
2915 MASK is the control mask, and PMASK is the pending control mask.
2916 TEMP records the temporary address which must be freed later. */
2919 gfc_trans_where_2 (gfc_code * code, tree mask, tree pmask,
2920 forall_info * nested_forall_info, stmtblock_t * block,
2921 temporary_list ** temp)
2927 tree tmp, tmp1, tmp2;
2928 tree count1, count2;
2932 /* the WHERE statement or the WHERE construct statement. */
2933 cblock = code->block;
2936 /* Has mask-expr. */
2939 /* Ensure that the WHERE mask be evaluated only once. */
2940 tmp2 = gfc_evaluate_where_mask (cblock->expr, nested_forall_info,
2941 &tmp, &tmp1, temp, block);
2943 /* Set the control mask and the pending control mask. */
2944 /* It's a where-stmt. */
2950 /* It's a nested where-stmt. */
2951 else if (mask && pmask == NULL)
2954 /* Use the TREE_CHAIN to list the masks. */
2955 tmp2 = copy_list (mask);
2956 pmask = chainon (mask, tmp1);
2957 mask = chainon (tmp2, tmp);
2959 /* It's a masked-elsewhere-stmt. */
2960 else if (mask && cblock->expr)
2963 tmp2 = copy_list (pmask);
2966 tmp2 = chainon (tmp2, tmp);
2967 pmask = chainon (mask, tmp1);
2971 /* It's a elsewhere-stmt. No mask-expr is present. */
2975 /* Get the assignment statement of a WHERE statement, or the first
2976 statement in where-body-construct of a WHERE construct. */
2977 cnext = cblock->next;
2982 /* WHERE assignment statement. */
2984 expr1 = cnext->expr;
2985 expr2 = cnext->expr2;
2986 if (nested_forall_info != NULL)
2991 nvar = nested_forall_info->nvar;
2992 varexpr = (gfc_expr **)
2993 gfc_getmem (nvar * sizeof (gfc_expr *));
2994 need_temp = gfc_check_dependency (expr1, expr2, varexpr,
2997 gfc_trans_assign_need_temp (expr1, expr2, mask,
2998 nested_forall_info, block);
3001 /* Variables to control maskexpr. */
3002 count1 = gfc_create_var (gfc_array_index_type, "count1");
3003 count2 = gfc_create_var (gfc_array_index_type, "count2");
3004 gfc_add_modify_expr (block, count1, gfc_index_zero_node);
3005 gfc_add_modify_expr (block, count2, gfc_index_zero_node);
3007 tmp = gfc_trans_where_assign (expr1, expr2, mask, count1,
3009 tmp = gfc_trans_nested_forall_loop (nested_forall_info,
3011 gfc_add_expr_to_block (block, tmp);
3016 /* Variables to control maskexpr. */
3017 count1 = gfc_create_var (gfc_array_index_type, "count1");
3018 count2 = gfc_create_var (gfc_array_index_type, "count2");
3019 gfc_add_modify_expr (block, count1, gfc_index_zero_node);
3020 gfc_add_modify_expr (block, count2, gfc_index_zero_node);
3022 tmp = gfc_trans_where_assign (expr1, expr2, mask, count1,
3024 gfc_add_expr_to_block (block, tmp);
3029 /* WHERE or WHERE construct is part of a where-body-construct. */
3031 /* Ensure that MASK is not modified by next gfc_trans_where_2. */
3032 mask_copy = copy_list (mask);
3033 gfc_trans_where_2 (cnext, mask_copy, NULL, nested_forall_info,
3041 /* The next statement within the same where-body-construct. */
3042 cnext = cnext->next;
3044 /* The next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt. */
3045 cblock = cblock->block;
3050 /* As the WHERE or WHERE construct statement can be nested, we call
3051 gfc_trans_where_2 to do the translation, and pass the initial
3052 NULL values for both the control mask and the pending control mask. */
3055 gfc_trans_where (gfc_code * code)
3058 temporary_list *temp, *p;
3062 gfc_start_block (&block);
3065 gfc_trans_where_2 (code, NULL, NULL, NULL, &block, &temp);
3067 /* Add calls to free temporaries which were dynamically allocated. */
3070 args = gfc_chainon_list (NULL_TREE, temp->temporary);
3071 tmp = gfc_build_function_call (gfor_fndecl_internal_free, args);
3072 gfc_add_expr_to_block (&block, tmp);
3078 return gfc_finish_block (&block);
3082 /* CYCLE a DO loop. The label decl has already been created by
3083 gfc_trans_do(), it's in TREE_PURPOSE (backend_decl) of the gfc_code
3084 node at the head of the loop. We must mark the label as used. */
3087 gfc_trans_cycle (gfc_code * code)
3091 cycle_label = TREE_PURPOSE (code->ext.whichloop->backend_decl);
3092 TREE_USED (cycle_label) = 1;
3093 return build1_v (GOTO_EXPR, cycle_label);
3097 /* EXIT a DO loop. Similar to CYCLE, but now the label is in
3098 TREE_VALUE (backend_decl) of the gfc_code node at the head of the
3102 gfc_trans_exit (gfc_code * code)
3106 exit_label = TREE_VALUE (code->ext.whichloop->backend_decl);
3107 TREE_USED (exit_label) = 1;
3108 return build1_v (GOTO_EXPR, exit_label);
3112 /* Translate the ALLOCATE statement. */
3115 gfc_trans_allocate (gfc_code * code)
3128 if (!code->ext.alloc_list)
3131 gfc_start_block (&block);
3135 tree gfc_int4_type_node = gfc_get_int_type (4);
3137 stat = gfc_create_var (gfc_int4_type_node, "stat");
3138 pstat = gfc_build_addr_expr (NULL, stat);
3140 error_label = gfc_build_label_decl (NULL_TREE);
3141 TREE_USED (error_label) = 1;
3145 pstat = integer_zero_node;
3146 stat = error_label = NULL_TREE;
3150 for (al = code->ext.alloc_list; al != NULL; al = al->next)
3154 gfc_init_se (&se, NULL);
3155 gfc_start_block (&se.pre);
3157 se.want_pointer = 1;
3158 se.descriptor_only = 1;
3159 gfc_conv_expr (&se, expr);
3163 /* Find the last reference in the chain. */
3164 while (ref && ref->next != NULL)
3166 gcc_assert (ref->type != REF_ARRAY || ref->u.ar.type == AR_ELEMENT);
3170 if (ref != NULL && ref->type == REF_ARRAY)
3173 gfc_array_allocate (&se, ref, pstat);
3177 /* A scalar or derived type. */
3180 val = gfc_create_var (ppvoid_type_node, "ptr");
3181 tmp = gfc_build_addr_expr (ppvoid_type_node, se.expr);
3182 gfc_add_modify_expr (&se.pre, val, tmp);
3184 tmp = TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (se.expr)));
3185 parm = gfc_chainon_list (NULL_TREE, val);
3186 parm = gfc_chainon_list (parm, tmp);
3187 parm = gfc_chainon_list (parm, pstat);
3188 tmp = gfc_build_function_call (gfor_fndecl_allocate, parm);
3189 gfc_add_expr_to_block (&se.pre, tmp);
3193 tmp = build1_v (GOTO_EXPR, error_label);
3195 build2 (NE_EXPR, boolean_type_node, stat, integer_zero_node);
3196 tmp = build3_v (COND_EXPR, parm, tmp, build_empty_stmt ());
3197 gfc_add_expr_to_block (&se.pre, tmp);
3201 tmp = gfc_finish_block (&se.pre);
3202 gfc_add_expr_to_block (&block, tmp);
3205 /* Assign the value to the status variable. */
3208 tmp = build1_v (LABEL_EXPR, error_label);
3209 gfc_add_expr_to_block (&block, tmp);
3211 gfc_init_se (&se, NULL);
3212 gfc_conv_expr_lhs (&se, code->expr);
3213 tmp = convert (TREE_TYPE (se.expr), stat);
3214 gfc_add_modify_expr (&block, se.expr, tmp);
3217 return gfc_finish_block (&block);
3222 gfc_trans_deallocate (gfc_code * code)
3232 gfc_start_block (&block);
3234 for (al = code->ext.alloc_list; al != NULL; al = al->next)
3237 gcc_assert (expr->expr_type == EXPR_VARIABLE);
3239 gfc_init_se (&se, NULL);
3240 gfc_start_block (&se.pre);
3242 se.want_pointer = 1;
3243 se.descriptor_only = 1;
3244 gfc_conv_expr (&se, expr);
3246 if (expr->symtree->n.sym->attr.dimension)
3248 tmp = gfc_array_deallocate (se.expr);
3249 gfc_add_expr_to_block (&se.pre, tmp);
3253 type = build_pointer_type (TREE_TYPE (se.expr));
3254 var = gfc_create_var (type, "ptr");
3255 tmp = gfc_build_addr_expr (type, se.expr);
3256 gfc_add_modify_expr (&se.pre, var, tmp);
3258 tmp = gfc_chainon_list (NULL_TREE, var);
3259 tmp = gfc_chainon_list (tmp, integer_zero_node);
3260 tmp = gfc_build_function_call (gfor_fndecl_deallocate, tmp);
3261 gfc_add_expr_to_block (&se.pre, tmp);
3263 tmp = gfc_finish_block (&se.pre);
3264 gfc_add_expr_to_block (&block, tmp);
3267 return gfc_finish_block (&block);