1 /* Statement translation -- generate GCC trees from gfc_code.
2 Copyright (C) 2002, 2003, 2004 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"
37 #include "trans-stmt.h"
38 #include "trans-types.h"
39 #include "trans-array.h"
40 #include "trans-const.h"
43 int has_alternate_specifier;
45 typedef struct iter_info
51 struct iter_info *next;
55 typedef struct temporary_list
58 struct temporary_list *next;
62 typedef struct forall_info
70 struct forall_info *outer;
71 struct forall_info *next_nest;
75 static void gfc_trans_where_2 (gfc_code *, tree, tree, forall_info *,
76 stmtblock_t *, temporary_list **temp);
78 /* Translate a F95 label number to a LABEL_EXPR. */
81 gfc_trans_label_here (gfc_code * code)
83 return build1_v (LABEL_EXPR, gfc_get_label_decl (code->here));
86 /* Translate a label assignment statement. */
88 gfc_trans_label_assign (gfc_code * code)
98 /* Start a new block. */
99 gfc_init_se (&se, NULL);
100 gfc_start_block (&se.pre);
101 gfc_conv_expr (&se, code->expr);
102 len = GFC_DECL_STRING_LEN (se.expr);
103 addr = GFC_DECL_ASSIGN_ADDR (se.expr);
105 label_tree = gfc_get_label_decl (code->label);
107 if (code->label->defined == ST_LABEL_TARGET)
109 label_tree = gfc_build_addr_expr (pvoid_type_node, label_tree);
110 len_tree = integer_minus_one_node;
114 label_str = code->label->format->value.character.string;
115 label_len = code->label->format->value.character.length;
116 len_tree = build_int_cst (NULL_TREE, label_len, 0);
117 label_tree = gfc_build_string_const (label_len + 1, label_str);
118 label_tree = gfc_build_addr_expr (pchar_type_node, label_tree);
121 gfc_add_modify_expr (&se.pre, len, len_tree);
122 gfc_add_modify_expr (&se.pre, addr, label_tree);
124 return gfc_finish_block (&se.pre);
127 /* Translate a GOTO statement. */
130 gfc_trans_goto (gfc_code * code)
140 if (code->label != NULL)
141 return build1_v (GOTO_EXPR, gfc_get_label_decl (code->label));
144 gfc_init_se (&se, NULL);
145 gfc_start_block (&se.pre);
146 gfc_conv_expr (&se, code->expr);
148 gfc_build_string_const (37, "Assigned label is not a target label");
149 tmp = GFC_DECL_STRING_LEN (se.expr);
150 tmp = build (NE_EXPR, boolean_type_node, tmp, integer_minus_one_node);
151 gfc_trans_runtime_check (tmp, assign_error, &se.pre);
153 assigned_goto = GFC_DECL_ASSIGN_ADDR (se.expr);
154 target = build1 (GOTO_EXPR, void_type_node, assigned_goto);
159 gfc_add_expr_to_block (&se.pre, target);
160 return gfc_finish_block (&se.pre);
163 /* Check the label list. */
165 gfc_build_string_const (34, "Assigned label is not in the list");
169 tmp = gfc_get_label_decl (code->label);
170 tmp = gfc_build_addr_expr (pvoid_type_node, tmp);
171 tmp = build (EQ_EXPR, boolean_type_node, tmp, assigned_goto);
172 tmp = build_v (COND_EXPR, tmp, target, build_empty_stmt ());
173 gfc_add_expr_to_block (&se.pre, tmp);
176 while (code != NULL);
177 gfc_trans_runtime_check (boolean_true_node, range_error, &se.pre);
178 return gfc_finish_block (&se.pre);
182 /* Translate the CALL statement. Builds a call to an F95 subroutine. */
185 gfc_trans_call (gfc_code * code)
189 /* A CALL starts a new block because the actual arguments may have to
190 be evaluated first. */
191 gfc_init_se (&se, NULL);
192 gfc_start_block (&se.pre);
194 assert (code->resolved_sym);
195 has_alternate_specifier = 0;
197 /* Translate the call. */
198 gfc_conv_function_call (&se, code->resolved_sym, code->ext.actual);
200 /* A subroutine without side-effect, by definition, does nothing! */
201 TREE_SIDE_EFFECTS (se.expr) = 1;
203 /* Chain the pieces together and return the block. */
204 if (has_alternate_specifier)
206 gfc_code *select_code;
208 select_code = code->next;
209 assert(select_code->op == EXEC_SELECT);
210 sym = select_code->expr->symtree->n.sym;
211 se.expr = convert (gfc_typenode_for_spec (&sym->ts), se.expr);
212 gfc_add_modify_expr (&se.pre, sym->backend_decl, se.expr);
215 gfc_add_expr_to_block (&se.pre, se.expr);
217 gfc_add_block_to_block (&se.pre, &se.post);
218 return gfc_finish_block (&se.pre);
222 /* Translate the RETURN statement. */
225 gfc_trans_return (gfc_code * code ATTRIBUTE_UNUSED)
233 /* if code->expr is not NULL, this return statement must appear
234 in a subroutine and current_fake_result_decl has already
237 result = gfc_get_fake_result_decl (NULL);
240 gfc_warning ("An alternate return at %L without a * dummy argument",
242 return build1_v (GOTO_EXPR, gfc_get_return_label ());
245 /* Start a new block for this statement. */
246 gfc_init_se (&se, NULL);
247 gfc_start_block (&se.pre);
249 gfc_conv_expr (&se, code->expr);
251 tmp = build (MODIFY_EXPR, TREE_TYPE (result), result, se.expr);
252 gfc_add_expr_to_block (&se.pre, tmp);
254 tmp = build1_v (GOTO_EXPR, gfc_get_return_label ());
255 gfc_add_expr_to_block (&se.pre, tmp);
256 gfc_add_block_to_block (&se.pre, &se.post);
257 return gfc_finish_block (&se.pre);
260 return build1_v (GOTO_EXPR, gfc_get_return_label ());
264 /* Translate the PAUSE statement. We have to translate this statement
265 to a runtime library call. */
268 gfc_trans_pause (gfc_code * code)
275 /* Start a new block for this statement. */
276 gfc_init_se (&se, NULL);
277 gfc_start_block (&se.pre);
280 if (code->expr == NULL)
282 tmp = build_int_cst (gfc_int4_type_node, code->ext.stop_code, 0);
283 args = gfc_chainon_list (NULL_TREE, tmp);
284 fndecl = gfor_fndecl_pause_numeric;
288 gfc_conv_expr_reference (&se, code->expr);
289 args = gfc_chainon_list (NULL_TREE, se.expr);
290 args = gfc_chainon_list (args, se.string_length);
291 fndecl = gfor_fndecl_pause_string;
294 tmp = gfc_build_function_call (fndecl, args);
295 gfc_add_expr_to_block (&se.pre, tmp);
297 gfc_add_block_to_block (&se.pre, &se.post);
299 return gfc_finish_block (&se.pre);
303 /* Translate the STOP statement. We have to translate this statement
304 to a runtime library call. */
307 gfc_trans_stop (gfc_code * code)
314 /* Start a new block for this statement. */
315 gfc_init_se (&se, NULL);
316 gfc_start_block (&se.pre);
319 if (code->expr == NULL)
321 tmp = build_int_cst (gfc_int4_type_node, code->ext.stop_code, 0);
322 args = gfc_chainon_list (NULL_TREE, tmp);
323 fndecl = gfor_fndecl_stop_numeric;
327 gfc_conv_expr_reference (&se, code->expr);
328 args = gfc_chainon_list (NULL_TREE, se.expr);
329 args = gfc_chainon_list (args, se.string_length);
330 fndecl = gfor_fndecl_stop_string;
333 tmp = gfc_build_function_call (fndecl, args);
334 gfc_add_expr_to_block (&se.pre, tmp);
336 gfc_add_block_to_block (&se.pre, &se.post);
338 return gfc_finish_block (&se.pre);
342 /* Generate GENERIC for the IF construct. This function also deals with
343 the simple IF statement, because the front end translates the IF
344 statement into an IF construct.
376 where COND_S is the simplified version of the predicate. PRE_COND_S
377 are the pre side-effects produced by the translation of the
379 We need to build the chain recursively otherwise we run into
380 problems with folding incomplete statements. */
383 gfc_trans_if_1 (gfc_code * code)
388 /* Check for an unconditional ELSE clause. */
390 return gfc_trans_code (code->next);
392 /* Initialize a statement builder for each block. Puts in NULL_TREEs. */
393 gfc_init_se (&if_se, NULL);
394 gfc_start_block (&if_se.pre);
396 /* Calculate the IF condition expression. */
397 gfc_conv_expr_val (&if_se, code->expr);
399 /* Translate the THEN clause. */
400 stmt = gfc_trans_code (code->next);
402 /* Translate the ELSE clause. */
404 elsestmt = gfc_trans_if_1 (code->block);
406 elsestmt = build_empty_stmt ();
408 /* Build the condition expression and add it to the condition block. */
409 stmt = build_v (COND_EXPR, if_se.expr, stmt, elsestmt);
411 gfc_add_expr_to_block (&if_se.pre, stmt);
413 /* Finish off this statement. */
414 return gfc_finish_block (&if_se.pre);
418 gfc_trans_if (gfc_code * code)
420 /* Ignore the top EXEC_IF, it only announces an IF construct. The
421 actual code we must translate is in code->block. */
423 return gfc_trans_if_1 (code->block);
427 /* Translage an arithmetic IF expression.
429 IF (cond) label1, label2, label3 translates to
443 gfc_trans_arithmetic_if (gfc_code * code)
451 /* Start a new block. */
452 gfc_init_se (&se, NULL);
453 gfc_start_block (&se.pre);
455 /* Pre-evaluate COND. */
456 gfc_conv_expr_val (&se, code->expr);
458 /* Build something to compare with. */
459 zero = gfc_build_const (TREE_TYPE (se.expr), integer_zero_node);
461 /* If (cond < 0) take branch1 else take branch2.
462 First build jumps to the COND .LT. 0 and the COND .EQ. 0 cases. */
463 branch1 = build1_v (GOTO_EXPR, gfc_get_label_decl (code->label));
464 branch2 = build1_v (GOTO_EXPR, gfc_get_label_decl (code->label2));
466 tmp = build (LT_EXPR, boolean_type_node, se.expr, zero);
467 branch1 = build_v (COND_EXPR, tmp, branch1, branch2);
469 /* if (cond <= 0) take branch1 else take branch2. */
470 branch2 = build1_v (GOTO_EXPR, gfc_get_label_decl (code->label3));
471 tmp = build (LE_EXPR, boolean_type_node, se.expr, zero);
472 branch1 = build_v (COND_EXPR, tmp, branch1, branch2);
474 /* Append the COND_EXPR to the evaluation of COND, and return. */
475 gfc_add_expr_to_block (&se.pre, branch1);
476 return gfc_finish_block (&se.pre);
480 /* Translate the DO construct. This obviously is one of the most
481 important ones to get right with any compiler, but especially
484 Currently we calculate the loop count before entering the loop, but
485 it may be possible to optimize if step is a constant. The main
486 advantage is that the loop test is a single GENERIC node
488 We translate a do loop from:
490 DO dovar = from, to, step
500 temp1=to_expr-from_expr;
502 range_temp=step_tmp/range_temp;
503 for ( ; range_temp > 0 ; range_temp = range_temp - 1)
508 dovar=dovar_temp + step_temp;
512 Some optimization is done for empty do loops. We can't just let
513 dovar=to because it's possible for from+range*loopcount!=to. Anyone
514 who writes empty DO deserves sub-optimal (but correct) code anyway.
516 TODO: Large loop counts
517 Does not work loop counts which do not fit into a signed integer kind,
518 ie. Does not work for loop counts > 2^31 for integer(kind=4) variables
519 We must support the full range. */
522 gfc_trans_do (gfc_code * code)
538 gfc_start_block (&block);
540 /* Create GIMPLE versions of all expressions in the iterator. */
542 gfc_init_se (&se, NULL);
543 gfc_conv_expr_lhs (&se, code->ext.iterator->var);
544 gfc_add_block_to_block (&block, &se.pre);
546 type = TREE_TYPE (dovar);
548 gfc_init_se (&se, NULL);
549 gfc_conv_expr_type (&se, code->ext.iterator->start, type);
550 gfc_add_block_to_block (&block, &se.pre);
553 gfc_init_se (&se, NULL);
554 gfc_conv_expr_type (&se, code->ext.iterator->end, type);
555 gfc_add_block_to_block (&block, &se.pre);
558 gfc_init_se (&se, NULL);
559 gfc_conv_expr_type (&se, code->ext.iterator->step, type);
561 /* We don't want this changing part way through. */
562 gfc_make_safe_expr (&se);
563 gfc_add_block_to_block (&block, &se.pre);
566 /* Initialise loop count. This code is executed before we enter the
567 loop body. We generate: count = (to + step - from) / step. */
569 tmp = fold (build (MINUS_EXPR, type, step, from));
570 tmp = fold (build (PLUS_EXPR, type, to, tmp));
571 tmp = fold (build (TRUNC_DIV_EXPR, type, tmp, step));
573 count = gfc_create_var (type, "count");
574 gfc_add_modify_expr (&block, count, tmp);
576 /* Initialise the DO variable: dovar = from. */
577 gfc_add_modify_expr (&block, dovar, from);
580 gfc_start_block (&body);
582 /* Cycle and exit statements are implemented with gotos. */
583 cycle_label = gfc_build_label_decl (NULL_TREE);
584 exit_label = gfc_build_label_decl (NULL_TREE);
586 /* Start with the loop condition. Loop until count <= 0. */
587 cond = build (LE_EXPR, boolean_type_node, count, integer_zero_node);
588 tmp = build1_v (GOTO_EXPR, exit_label);
589 TREE_USED (exit_label) = 1;
590 tmp = build_v (COND_EXPR, cond, tmp, build_empty_stmt ());
591 gfc_add_expr_to_block (&body, tmp);
593 /* Put these labels where they can be found later. We put the
594 labels in a TREE_LIST node (because TREE_CHAIN is already
595 used). cycle_label goes in TREE_PURPOSE (backend_decl), exit
596 label in TREE_VALUE (backend_decl). */
598 code->block->backend_decl = tree_cons (cycle_label, exit_label, NULL);
600 /* Main loop body. */
601 tmp = gfc_trans_code (code->block->next);
602 gfc_add_expr_to_block (&body, tmp);
604 /* Label for cycle statements (if needed). */
605 if (TREE_USED (cycle_label))
607 tmp = build1_v (LABEL_EXPR, cycle_label);
608 gfc_add_expr_to_block (&body, tmp);
611 /* Increment the loop variable. */
612 tmp = build (PLUS_EXPR, type, dovar, step);
613 gfc_add_modify_expr (&body, dovar, tmp);
615 /* Decrement the loop count. */
616 tmp = build (MINUS_EXPR, type, count, gfc_index_one_node);
617 gfc_add_modify_expr (&body, count, tmp);
619 /* End of loop body. */
620 tmp = gfc_finish_block (&body);
622 /* The for loop itself. */
623 tmp = build_v (LOOP_EXPR, tmp);
624 gfc_add_expr_to_block (&block, tmp);
626 /* Add the exit label. */
627 tmp = build1_v (LABEL_EXPR, exit_label);
628 gfc_add_expr_to_block (&block, tmp);
630 return gfc_finish_block (&block);
634 /* Translate the DO WHILE construct.
647 if (! cond) goto exit_label;
653 Because the evaluation of the exit condition `cond' may have side
654 effects, we can't do much for empty loop bodies. The backend optimizers
655 should be smart enough to eliminate any dead loops. */
658 gfc_trans_do_while (gfc_code * code)
666 /* Everything we build here is part of the loop body. */
667 gfc_start_block (&block);
669 /* Cycle and exit statements are implemented with gotos. */
670 cycle_label = gfc_build_label_decl (NULL_TREE);
671 exit_label = gfc_build_label_decl (NULL_TREE);
673 /* Put the labels where they can be found later. See gfc_trans_do(). */
674 code->block->backend_decl = tree_cons (cycle_label, exit_label, NULL);
676 /* Create a GIMPLE version of the exit condition. */
677 gfc_init_se (&cond, NULL);
678 gfc_conv_expr_val (&cond, code->expr);
679 gfc_add_block_to_block (&block, &cond.pre);
680 cond.expr = fold (build1 (TRUTH_NOT_EXPR, boolean_type_node, cond.expr));
682 /* Build "IF (! cond) GOTO exit_label". */
683 tmp = build1_v (GOTO_EXPR, exit_label);
684 TREE_USED (exit_label) = 1;
685 tmp = build_v (COND_EXPR, cond.expr, tmp, build_empty_stmt ());
686 gfc_add_expr_to_block (&block, tmp);
688 /* The main body of the loop. */
689 tmp = gfc_trans_code (code->block->next);
690 gfc_add_expr_to_block (&block, tmp);
692 /* Label for cycle statements (if needed). */
693 if (TREE_USED (cycle_label))
695 tmp = build1_v (LABEL_EXPR, cycle_label);
696 gfc_add_expr_to_block (&block, tmp);
699 /* End of loop body. */
700 tmp = gfc_finish_block (&block);
702 gfc_init_block (&block);
703 /* Build the loop. */
704 tmp = build_v (LOOP_EXPR, tmp);
705 gfc_add_expr_to_block (&block, tmp);
707 /* Add the exit label. */
708 tmp = build1_v (LABEL_EXPR, exit_label);
709 gfc_add_expr_to_block (&block, tmp);
711 return gfc_finish_block (&block);
715 /* Translate the SELECT CASE construct for INTEGER case expressions,
716 without killing all potential optimizations. The problem is that
717 Fortran allows unbounded cases, but the back-end does not, so we
718 need to intercept those before we enter the equivalent SWITCH_EXPR
721 For example, we translate this,
724 CASE (:100,101,105:115)
734 to the GENERIC equivalent,
738 case (minimum value for typeof(expr) ... 100:
744 case 200 ... (maximum value for typeof(expr):
761 gfc_trans_integer_select (gfc_code * code)
771 gfc_start_block (&block);
773 /* Calculate the switch expression. */
774 gfc_init_se (&se, NULL);
775 gfc_conv_expr_val (&se, code->expr);
776 gfc_add_block_to_block (&block, &se.pre);
778 end_label = gfc_build_label_decl (NULL_TREE);
780 gfc_init_block (&body);
782 for (c = code->block; c; c = c->block)
784 for (cp = c->ext.case_list; cp; cp = cp->next)
789 /* Assume it's the default case. */
790 low = high = NULL_TREE;
794 low = gfc_conv_constant_to_tree (cp->low);
796 /* If there's only a lower bound, set the high bound to the
797 maximum value of the case expression. */
799 high = TYPE_MAX_VALUE (TREE_TYPE (se.expr));
804 /* Three cases are possible here:
806 1) There is no lower bound, e.g. CASE (:N).
807 2) There is a lower bound .NE. high bound, that is
808 a case range, e.g. CASE (N:M) where M>N (we make
809 sure that M>N during type resolution).
810 3) There is a lower bound, and it has the same value
811 as the high bound, e.g. CASE (N:N). This is our
812 internal representation of CASE(N).
814 In the first and second case, we need to set a value for
815 high. In the thirth case, we don't because the GCC middle
816 end represents a single case value by just letting high be
817 a NULL_TREE. We can't do that because we need to be able
818 to represent unbounded cases. */
822 && mpz_cmp (cp->low->value.integer,
823 cp->high->value.integer) != 0))
824 high = gfc_conv_constant_to_tree (cp->high);
826 /* Unbounded case. */
828 low = TYPE_MIN_VALUE (TREE_TYPE (se.expr));
832 label = build_decl (LABEL_DECL, NULL_TREE, NULL_TREE);
833 DECL_CONTEXT (label) = current_function_decl;
835 /* Add this case label.
836 Add parameter 'label', make it match GCC backend. */
837 tmp = build (CASE_LABEL_EXPR, void_type_node, low, high, label);
838 gfc_add_expr_to_block (&body, tmp);
841 /* Add the statements for this case. */
842 tmp = gfc_trans_code (c->next);
843 gfc_add_expr_to_block (&body, tmp);
845 /* Break to the end of the construct. */
846 tmp = build1_v (GOTO_EXPR, end_label);
847 gfc_add_expr_to_block (&body, tmp);
850 tmp = gfc_finish_block (&body);
851 tmp = build_v (SWITCH_EXPR, se.expr, tmp, NULL_TREE);
852 gfc_add_expr_to_block (&block, tmp);
854 tmp = build1_v (LABEL_EXPR, end_label);
855 gfc_add_expr_to_block (&block, tmp);
857 return gfc_finish_block (&block);
861 /* Translate the SELECT CASE construct for LOGICAL case expressions.
863 There are only two cases possible here, even though the standard
864 does allow three cases in a LOGICAL SELECT CASE construct: .TRUE.,
865 .FALSE., and DEFAULT.
867 We never generate more than two blocks here. Instead, we always
868 try to eliminate the DEFAULT case. This way, we can translate this
869 kind of SELECT construct to a simple
873 expression in GENERIC. */
876 gfc_trans_logical_select (gfc_code * code)
884 /* Assume we don't have any cases at all. */
887 /* Now see which ones we actually do have. We can have at most two
888 cases in a single case list: one for .TRUE. and one for .FALSE.
889 The default case is always separate. If the cases for .TRUE. and
890 .FALSE. are in the same case list, the block for that case list
891 always executed, and we don't generate code a COND_EXPR. */
892 for (c = code->block; c; c = c->block)
894 for (cp = c->ext.case_list; cp; cp = cp->next)
898 if (cp->low->value.logical == 0) /* .FALSE. */
900 else /* if (cp->value.logical != 0), thus .TRUE. */
908 /* Start a new block. */
909 gfc_start_block (&block);
911 /* Calculate the switch expression. We always need to do this
912 because it may have side effects. */
913 gfc_init_se (&se, NULL);
914 gfc_conv_expr_val (&se, code->expr);
915 gfc_add_block_to_block (&block, &se.pre);
917 if (t == f && t != NULL)
919 /* Cases for .TRUE. and .FALSE. are in the same block. Just
920 translate the code for these cases, append it to the current
922 gfc_add_expr_to_block (&block, gfc_trans_code (t->next));
926 tree true_tree, false_tree;
928 true_tree = build_empty_stmt ();
929 false_tree = build_empty_stmt ();
931 /* If we have a case for .TRUE. and for .FALSE., discard the default case.
932 Otherwise, if .TRUE. or .FALSE. is missing and there is a default case,
933 make the missing case the default case. */
934 if (t != NULL && f != NULL)
944 /* Translate the code for each of these blocks, and append it to
945 the current block. */
947 true_tree = gfc_trans_code (t->next);
950 false_tree = gfc_trans_code (f->next);
952 gfc_add_expr_to_block (&block, build_v (COND_EXPR, se.expr,
953 true_tree, false_tree));
956 return gfc_finish_block (&block);
960 /* Translate the SELECT CASE construct for CHARACTER case expressions.
961 Instead of generating compares and jumps, it is far simpler to
962 generate a data structure describing the cases in order and call a
963 library subroutine that locates the right case.
964 This is particularly true because this is the only case where we
965 might have to dispose of a temporary.
966 The library subroutine returns a pointer to jump to or NULL if no
967 branches are to be taken. */
970 gfc_trans_character_select (gfc_code *code)
972 tree init, node, end_label, tmp, type, args, *labels;
973 stmtblock_t block, body;
979 static tree select_struct;
980 static tree ss_string1, ss_string1_len;
981 static tree ss_string2, ss_string2_len;
982 static tree ss_target;
984 if (select_struct == NULL)
986 select_struct = make_node (RECORD_TYPE);
987 TYPE_NAME (select_struct) = get_identifier ("_jump_struct");
990 #define ADD_FIELD(NAME, TYPE) \
991 ss_##NAME = gfc_add_field_to_struct \
992 (&(TYPE_FIELDS (select_struct)), select_struct, \
993 get_identifier (stringize(NAME)), TYPE)
995 ADD_FIELD (string1, pchar_type_node);
996 ADD_FIELD (string1_len, gfc_int4_type_node);
998 ADD_FIELD (string2, pchar_type_node);
999 ADD_FIELD (string2_len, gfc_int4_type_node);
1001 ADD_FIELD (target, pvoid_type_node);
1004 gfc_finish_type (select_struct);
1007 cp = code->block->ext.case_list;
1008 while (cp->left != NULL)
1012 for (d = cp; d; d = d->right)
1016 labels = gfc_getmem (n * sizeof (tree));
1020 for(i = 0; i < n; i++)
1022 labels[i] = gfc_build_label_decl (NULL_TREE);
1023 TREE_USED (labels[i]) = 1;
1024 /* TODO: The gimplifier should do this for us, but it has
1025 inadequacies when dealing with static initializers. */
1026 FORCED_LABEL (labels[i]) = 1;
1029 end_label = gfc_build_label_decl (NULL_TREE);
1031 /* Generate the body */
1032 gfc_start_block (&block);
1033 gfc_init_block (&body);
1035 for (c = code->block; c; c = c->block)
1037 for (d = c->ext.case_list; d; d = d->next)
1039 tmp = build_v (LABEL_EXPR, labels[d->n]);
1040 gfc_add_expr_to_block (&body, tmp);
1043 tmp = gfc_trans_code (c->next);
1044 gfc_add_expr_to_block (&body, tmp);
1046 tmp = build_v (GOTO_EXPR, end_label);
1047 gfc_add_expr_to_block (&body, tmp);
1050 /* Generate the structure describing the branches */
1054 for(d = cp; d; d = d->right, i++)
1058 gfc_init_se (&se, NULL);
1062 node = tree_cons (ss_string1, null_pointer_node, node);
1063 node = tree_cons (ss_string1_len, integer_zero_node, node);
1067 gfc_conv_expr_reference (&se, d->low);
1069 node = tree_cons (ss_string1, se.expr, node);
1070 node = tree_cons (ss_string1_len, se.string_length, node);
1073 if (d->high == NULL)
1075 node = tree_cons (ss_string2, null_pointer_node, node);
1076 node = tree_cons (ss_string2_len, integer_zero_node, node);
1080 gfc_init_se (&se, NULL);
1081 gfc_conv_expr_reference (&se, d->high);
1083 node = tree_cons (ss_string2, se.expr, node);
1084 node = tree_cons (ss_string2_len, se.string_length, node);
1087 tmp = gfc_build_addr_expr (pvoid_type_node, labels[i]);
1088 node = tree_cons (ss_target, tmp, node);
1090 tmp = build1 (CONSTRUCTOR, select_struct, nreverse (node));
1091 init = tree_cons (NULL_TREE, tmp, init);
1094 type = build_array_type (select_struct, build_index_type
1095 (build_int_cst (NULL_TREE, n - 1, 0)));
1097 init = build1 (CONSTRUCTOR, type, nreverse(init));
1098 TREE_CONSTANT (init) = 1;
1099 TREE_INVARIANT (init) = 1;
1100 TREE_STATIC (init) = 1;
1101 /* Create a static variable to hold the jump table. */
1102 tmp = gfc_create_var (type, "jumptable");
1103 TREE_CONSTANT (tmp) = 1;
1104 TREE_INVARIANT (tmp) = 1;
1105 TREE_STATIC (tmp) = 1;
1106 DECL_INITIAL (tmp) = init;
1109 /* Build an argument list for the library call */
1110 init = gfc_build_addr_expr (pvoid_type_node, init);
1111 args = gfc_chainon_list (NULL_TREE, init);
1113 tmp = build_int_cst (NULL_TREE, n, 0);
1114 args = gfc_chainon_list (args, tmp);
1116 tmp = gfc_build_addr_expr (pvoid_type_node, end_label);
1117 args = gfc_chainon_list (args, tmp);
1119 gfc_init_se (&se, NULL);
1120 gfc_conv_expr_reference (&se, code->expr);
1122 args = gfc_chainon_list (args, se.expr);
1123 args = gfc_chainon_list (args, se.string_length);
1125 gfc_add_block_to_block (&block, &se.pre);
1127 tmp = gfc_build_function_call (gfor_fndecl_select_string, args);
1128 tmp = build1 (GOTO_EXPR, void_type_node, tmp);
1129 gfc_add_expr_to_block (&block, tmp);
1131 tmp = gfc_finish_block (&body);
1132 gfc_add_expr_to_block (&block, tmp);
1133 tmp = build_v (LABEL_EXPR, end_label);
1134 gfc_add_expr_to_block (&block, tmp);
1139 return gfc_finish_block (&block);
1143 /* Translate the three variants of the SELECT CASE construct.
1145 SELECT CASEs with INTEGER case expressions can be translated to an
1146 equivalent GENERIC switch statement, and for LOGICAL case
1147 expressions we build one or two if-else compares.
1149 SELECT CASEs with CHARACTER case expressions are a whole different
1150 story, because they don't exist in GENERIC. So we sort them and
1151 do a binary search at runtime.
1153 Fortran has no BREAK statement, and it does not allow jumps from
1154 one case block to another. That makes things a lot easier for
1158 gfc_trans_select (gfc_code * code)
1160 assert (code && code->expr);
1162 /* Empty SELECT constructs are legal. */
1163 if (code->block == NULL)
1164 return build_empty_stmt ();
1166 /* Select the correct translation function. */
1167 switch (code->expr->ts.type)
1169 case BT_LOGICAL: return gfc_trans_logical_select (code);
1170 case BT_INTEGER: return gfc_trans_integer_select (code);
1171 case BT_CHARACTER: return gfc_trans_character_select (code);
1173 gfc_internal_error ("gfc_trans_select(): Bad type for case expr.");
1179 /* Generate the loops for a FORALL block. The normal loop format:
1180 count = (end - start + step) / step
1193 gfc_trans_forall_loop (forall_info *forall_tmp, int nvar, tree body, int mask_flag)
1201 tree var, start, end, step, mask, maskindex;
1204 iter = forall_tmp->this_loop;
1205 for (n = 0; n < nvar; n++)
1208 start = iter->start;
1212 exit_label = gfc_build_label_decl (NULL_TREE);
1213 TREE_USED (exit_label) = 1;
1215 /* The loop counter. */
1216 count = gfc_create_var (TREE_TYPE (var), "count");
1218 /* The body of the loop. */
1219 gfc_init_block (&block);
1221 /* The exit condition. */
1222 cond = build (LE_EXPR, boolean_type_node, count, integer_zero_node);
1223 tmp = build1_v (GOTO_EXPR, exit_label);
1224 tmp = build_v (COND_EXPR, cond, tmp, build_empty_stmt ());
1225 gfc_add_expr_to_block (&block, tmp);
1227 /* The main loop body. */
1228 gfc_add_expr_to_block (&block, body);
1230 /* Increment the loop variable. */
1231 tmp = build (PLUS_EXPR, TREE_TYPE (var), var, step);
1232 gfc_add_modify_expr (&block, var, tmp);
1234 /* Advance to the next mask element. */
1237 mask = forall_tmp->mask;
1238 maskindex = forall_tmp->maskindex;
1241 tmp = build (PLUS_EXPR, gfc_array_index_type,
1242 maskindex, gfc_index_one_node);
1243 gfc_add_modify_expr (&block, maskindex, tmp);
1246 /* Decrement the loop counter. */
1247 tmp = build (MINUS_EXPR, TREE_TYPE (var), count, gfc_index_one_node);
1248 gfc_add_modify_expr (&block, count, tmp);
1250 body = gfc_finish_block (&block);
1252 /* Loop var initialization. */
1253 gfc_init_block (&block);
1254 gfc_add_modify_expr (&block, var, start);
1256 /* Initialize the loop counter. */
1257 tmp = fold (build (MINUS_EXPR, TREE_TYPE (var), step, start));
1258 tmp = fold (build (PLUS_EXPR, TREE_TYPE (var), end, tmp));
1259 tmp = fold (build (TRUNC_DIV_EXPR, TREE_TYPE (var), tmp, step));
1260 gfc_add_modify_expr (&block, count, tmp);
1262 /* The loop expression. */
1263 tmp = build_v (LOOP_EXPR, body);
1264 gfc_add_expr_to_block (&block, tmp);
1266 /* The exit label. */
1267 tmp = build1_v (LABEL_EXPR, exit_label);
1268 gfc_add_expr_to_block (&block, tmp);
1270 body = gfc_finish_block (&block);
1277 /* Generate the body and loops according to MASK_FLAG and NEST_FLAG.
1278 if MASK_FLAG is non-zero, the body is controlled by maskes in forall
1279 nest, otherwise, the body is not controlled by maskes.
1280 if NEST_FLAG is non-zero, generate loops for nested forall, otherwise,
1281 only generate loops for the current forall level. */
1284 gfc_trans_nested_forall_loop (forall_info * nested_forall_info, tree body,
1285 int mask_flag, int nest_flag)
1289 forall_info *forall_tmp;
1290 tree pmask, mask, maskindex;
1292 forall_tmp = nested_forall_info;
1293 /* Generate loops for nested forall. */
1296 while (forall_tmp->next_nest != NULL)
1297 forall_tmp = forall_tmp->next_nest;
1298 while (forall_tmp != NULL)
1300 /* Generate body with masks' control. */
1303 pmask = forall_tmp->pmask;
1304 mask = forall_tmp->mask;
1305 maskindex = forall_tmp->maskindex;
1309 /* If a mask was specified make the assignment contitional. */
1311 tmp = gfc_build_indirect_ref (mask);
1314 tmp = gfc_build_array_ref (tmp, maskindex);
1316 body = build_v (COND_EXPR, tmp, body, build_empty_stmt ());
1319 nvar = forall_tmp->nvar;
1320 body = gfc_trans_forall_loop (forall_tmp, nvar, body, mask_flag);
1321 forall_tmp = forall_tmp->outer;
1326 nvar = forall_tmp->nvar;
1327 body = gfc_trans_forall_loop (forall_tmp, nvar, body, mask_flag);
1334 /* Allocate data for holding a temporary array. Returns either a local
1335 temporary array or a pointer variable. */
1338 gfc_do_allocate (tree bytesize, tree size, tree * pdata, stmtblock_t * pblock,
1346 if (INTEGER_CST_P (size))
1348 tmp = fold (build (MINUS_EXPR, gfc_array_index_type, size,
1349 gfc_index_one_node));
1354 type = build_range_type (gfc_array_index_type, gfc_index_zero_node, tmp);
1355 type = build_array_type (elem_type, type);
1356 if (gfc_can_put_var_on_stack (bytesize))
1358 assert (INTEGER_CST_P (size));
1359 tmpvar = gfc_create_var (type, "temp");
1364 tmpvar = gfc_create_var (build_pointer_type (type), "temp");
1365 *pdata = convert (pvoid_type_node, tmpvar);
1367 args = gfc_chainon_list (NULL_TREE, bytesize);
1368 if (gfc_index_integer_kind == 4)
1369 tmp = gfor_fndecl_internal_malloc;
1370 else if (gfc_index_integer_kind == 8)
1371 tmp = gfor_fndecl_internal_malloc64;
1374 tmp = gfc_build_function_call (tmp, args);
1375 tmp = convert (TREE_TYPE (tmpvar), tmp);
1376 gfc_add_modify_expr (pblock, tmpvar, tmp);
1382 /* Generate codes to copy the temporary to the actual lhs. */
1385 generate_loop_for_temp_to_lhs (gfc_expr *expr, tree tmp1, tree size,
1386 tree count3, tree count1, tree count2, tree wheremask)
1390 stmtblock_t block, body;
1397 lss = gfc_walk_expr (expr);
1399 if (lss == gfc_ss_terminator)
1401 gfc_start_block (&block);
1403 gfc_init_se (&lse, NULL);
1405 /* Translate the expression. */
1406 gfc_conv_expr (&lse, expr);
1408 /* Form the expression for the temporary. */
1409 tmp = gfc_build_array_ref (tmp1, count1);
1411 /* Use the scalar assignment as is. */
1412 gfc_add_block_to_block (&block, &lse.pre);
1413 gfc_add_modify_expr (&block, lse.expr, tmp);
1414 gfc_add_block_to_block (&block, &lse.post);
1416 /* Increment the count1. */
1417 tmp = fold (build (PLUS_EXPR, TREE_TYPE (count1), count1, size));
1418 gfc_add_modify_expr (&block, count1, tmp);
1419 tmp = gfc_finish_block (&block);
1423 gfc_start_block (&block);
1425 gfc_init_loopinfo (&loop1);
1426 gfc_init_se (&rse, NULL);
1427 gfc_init_se (&lse, NULL);
1429 /* Associate the lss with the loop. */
1430 gfc_add_ss_to_loop (&loop1, lss);
1432 /* Calculate the bounds of the scalarization. */
1433 gfc_conv_ss_startstride (&loop1);
1434 /* Setup the scalarizing loops. */
1435 gfc_conv_loop_setup (&loop1);
1437 gfc_mark_ss_chain_used (lss, 1);
1438 /* Initialize count2. */
1439 gfc_add_modify_expr (&block, count2, gfc_index_zero_node);
1441 /* Start the scalarized loop body. */
1442 gfc_start_scalarized_body (&loop1, &body);
1444 /* Setup the gfc_se structures. */
1445 gfc_copy_loopinfo_to_se (&lse, &loop1);
1448 /* Form the expression of the temporary. */
1449 if (lss != gfc_ss_terminator)
1451 index = fold (build (PLUS_EXPR, gfc_array_index_type,
1453 rse.expr = gfc_build_array_ref (tmp1, index);
1455 /* Translate expr. */
1456 gfc_conv_expr (&lse, expr);
1458 /* Use the scalar assignment. */
1459 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts.type);
1461 /* Form the mask expression according to the mask tree list. */
1466 wheremaskexpr = gfc_build_array_ref (tmp2, count3);
1467 tmp2 = TREE_CHAIN (tmp2);
1470 tmp1 = gfc_build_array_ref (tmp2, count3);
1471 wheremaskexpr = build (TRUTH_AND_EXPR, TREE_TYPE (tmp1),
1472 wheremaskexpr, tmp1);
1473 tmp2 = TREE_CHAIN (tmp2);
1475 tmp = build_v (COND_EXPR, wheremaskexpr, tmp, build_empty_stmt ());
1478 gfc_add_expr_to_block (&body, tmp);
1480 /* Increment count2. */
1481 tmp = fold (build (PLUS_EXPR, gfc_array_index_type,
1482 count2, gfc_index_one_node));
1483 gfc_add_modify_expr (&body, count2, tmp);
1485 /* Increment count3. */
1488 tmp = fold (build (PLUS_EXPR, gfc_array_index_type,
1489 count3, gfc_index_one_node));
1490 gfc_add_modify_expr (&body, count3, tmp);
1493 /* Generate the copying loops. */
1494 gfc_trans_scalarizing_loops (&loop1, &body);
1495 gfc_add_block_to_block (&block, &loop1.pre);
1496 gfc_add_block_to_block (&block, &loop1.post);
1497 gfc_cleanup_loop (&loop1);
1499 /* Increment count1. */
1500 tmp = fold (build (PLUS_EXPR, TREE_TYPE (count1), count1, size));
1501 gfc_add_modify_expr (&block, count1, tmp);
1502 tmp = gfc_finish_block (&block);
1508 /* Generate codes to copy rhs to the temporary. TMP1 is the address of temporary
1509 LSS and RSS are formed in function compute_inner_temp_size(), and should
1513 generate_loop_for_rhs_to_temp (gfc_expr *expr2, tree tmp1, tree size,
1514 tree count3, tree count1, tree count2,
1515 gfc_ss *lss, gfc_ss *rss, tree wheremask)
1517 stmtblock_t block, body1;
1521 tree tmp, tmp2, index;
1524 gfc_start_block (&block);
1526 gfc_init_se (&rse, NULL);
1527 gfc_init_se (&lse, NULL);
1529 if (lss == gfc_ss_terminator)
1531 gfc_init_block (&body1);
1532 gfc_conv_expr (&rse, expr2);
1533 lse.expr = gfc_build_array_ref (tmp1, count1);
1537 /* Initilize count2. */
1538 gfc_add_modify_expr (&block, count2, gfc_index_zero_node);
1540 /* Initiliaze the loop. */
1541 gfc_init_loopinfo (&loop);
1543 /* We may need LSS to determine the shape of the expression. */
1544 gfc_add_ss_to_loop (&loop, lss);
1545 gfc_add_ss_to_loop (&loop, rss);
1547 gfc_conv_ss_startstride (&loop);
1548 gfc_conv_loop_setup (&loop);
1550 gfc_mark_ss_chain_used (rss, 1);
1551 /* Start the loop body. */
1552 gfc_start_scalarized_body (&loop, &body1);
1554 /* Translate the expression. */
1555 gfc_copy_loopinfo_to_se (&rse, &loop);
1557 gfc_conv_expr (&rse, expr2);
1559 /* Form the expression of the temporary. */
1560 index = fold (build (PLUS_EXPR, gfc_array_index_type, count1, count2));
1561 lse.expr = gfc_build_array_ref (tmp1, index);
1564 /* Use the scalar assignment. */
1565 tmp = gfc_trans_scalar_assign (&lse, &rse, expr2->ts.type);
1567 /* Form the mask expression according to the mask tree list. */
1572 wheremaskexpr = gfc_build_array_ref (tmp2, count3);
1573 tmp2 = TREE_CHAIN (tmp2);
1576 tmp1 = gfc_build_array_ref (tmp2, count3);
1577 wheremaskexpr = build (TRUTH_AND_EXPR, TREE_TYPE (tmp1),
1578 wheremaskexpr, tmp1);
1579 tmp2 = TREE_CHAIN (tmp2);
1581 tmp = build_v (COND_EXPR, wheremaskexpr, tmp, build_empty_stmt ());
1584 gfc_add_expr_to_block (&body1, tmp);
1586 if (lss == gfc_ss_terminator)
1588 gfc_add_block_to_block (&block, &body1);
1592 /* Increment count2. */
1593 tmp = fold (build (PLUS_EXPR, gfc_array_index_type,
1594 count2, gfc_index_one_node));
1595 gfc_add_modify_expr (&body1, count2, tmp);
1597 /* Increment count3. */
1600 tmp = fold (build (PLUS_EXPR, gfc_array_index_type,
1601 count3, gfc_index_one_node));
1602 gfc_add_modify_expr (&body1, count3, tmp);
1605 /* Generate the copying loops. */
1606 gfc_trans_scalarizing_loops (&loop, &body1);
1608 gfc_add_block_to_block (&block, &loop.pre);
1609 gfc_add_block_to_block (&block, &loop.post);
1611 gfc_cleanup_loop (&loop);
1612 /* TODO: Reuse lss and rss when copying temp->lhs. Need to be careful
1613 as tree nodes in SS may not be valid in different scope. */
1615 /* Increment count1. */
1616 tmp = fold (build (PLUS_EXPR, TREE_TYPE (count1), count1, size));
1617 gfc_add_modify_expr (&block, count1, tmp);
1619 tmp = gfc_finish_block (&block);
1624 /* Calculate the size of temporary needed in the assignment inside forall.
1625 LSS and RSS are filled in this function. */
1628 compute_inner_temp_size (gfc_expr *expr1, gfc_expr *expr2,
1629 stmtblock_t * pblock,
1630 gfc_ss **lss, gfc_ss **rss)
1637 *lss = gfc_walk_expr (expr1);
1640 size = gfc_index_one_node;
1641 if (*lss != gfc_ss_terminator)
1643 gfc_init_loopinfo (&loop);
1645 /* Walk the RHS of the expression. */
1646 *rss = gfc_walk_expr (expr2);
1647 if (*rss == gfc_ss_terminator)
1649 /* The rhs is scalar. Add a ss for the expression. */
1650 *rss = gfc_get_ss ();
1651 (*rss)->next = gfc_ss_terminator;
1652 (*rss)->type = GFC_SS_SCALAR;
1653 (*rss)->expr = expr2;
1656 /* Associate the SS with the loop. */
1657 gfc_add_ss_to_loop (&loop, *lss);
1658 /* We don't actually need to add the rhs at this point, but it might
1659 make guessing the loop bounds a bit easier. */
1660 gfc_add_ss_to_loop (&loop, *rss);
1662 /* We only want the shape of the expression, not rest of the junk
1663 generated by the scalarizer. */
1664 loop.array_parameter = 1;
1666 /* Calculate the bounds of the scalarization. */
1667 gfc_conv_ss_startstride (&loop);
1668 gfc_conv_loop_setup (&loop);
1670 /* Figure out how many elements we need. */
1671 for (i = 0; i < loop.dimen; i++)
1673 tmp = fold (build (MINUS_EXPR, gfc_array_index_type,
1674 gfc_index_one_node, loop.from[i]));
1675 tmp = fold (build (PLUS_EXPR, gfc_array_index_type,
1677 size = fold (build (MULT_EXPR, gfc_array_index_type, size, tmp));
1679 gfc_add_block_to_block (pblock, &loop.pre);
1680 size = gfc_evaluate_now (size, pblock);
1681 gfc_add_block_to_block (pblock, &loop.post);
1683 /* TODO: write a function that cleans up a loopinfo without freeing
1684 the SS chains. Currently a NOP. */
1691 /* Calculate the overall iterator number of the nested forall construct. */
1694 compute_overall_iter_number (forall_info *nested_forall_info, tree inner_size,
1700 /* TODO: optimizing the computing process. */
1701 number = gfc_create_var (gfc_array_index_type, "num");
1702 gfc_add_modify_expr (block, number, gfc_index_zero_node);
1704 gfc_start_block (&body);
1705 if (nested_forall_info)
1706 tmp = build (PLUS_EXPR, gfc_array_index_type, number,
1710 gfc_add_modify_expr (&body, number, tmp);
1711 tmp = gfc_finish_block (&body);
1713 /* Generate loops. */
1714 if (nested_forall_info != NULL)
1715 tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 0, 1);
1717 gfc_add_expr_to_block (block, tmp);
1723 /* Allocate temporary for forall construct according to the information in
1724 nested_forall_info. INNER_SIZE is the size of temporary needed in the
1725 assignment inside forall. PTEMP1 is returned for space free. */
1728 allocate_temp_for_forall_nest (forall_info * nested_forall_info, tree type,
1729 tree inner_size, stmtblock_t * block,
1735 tree bytesize, size;
1737 /* Calculate the total size of temporary needed in forall construct. */
1738 size = compute_overall_iter_number (nested_forall_info, inner_size, block);
1740 unit = TYPE_SIZE_UNIT (type);
1741 bytesize = fold (build (MULT_EXPR, gfc_array_index_type, size, unit));
1744 temp1 = gfc_do_allocate (bytesize, size, ptemp1, block, type);
1747 tmp = gfc_build_indirect_ref (temp1);
1755 /* Handle assignments inside forall which need temporary. */
1757 gfc_trans_assign_need_temp (gfc_expr * expr1, gfc_expr * expr2, tree wheremask,
1758 forall_info * nested_forall_info,
1759 stmtblock_t * block)
1764 tree count, count1, count2;
1767 tree mask, maskindex;
1768 forall_info *forall_tmp;
1770 /* Create vars. count1 is the current iterator number of the nested forall.
1771 count2 is the current iterator number of the inner loops needed in the
1773 count1 = gfc_create_var (gfc_array_index_type, "count1");
1774 count2 = gfc_create_var (gfc_array_index_type, "count2");
1776 /* Count is the wheremask index. */
1779 count = gfc_create_var (gfc_array_index_type, "count");
1780 gfc_add_modify_expr (block, count, gfc_index_zero_node);
1785 /* Initialize count1. */
1786 gfc_add_modify_expr (block, count1, gfc_index_zero_node);
1788 /* Calculate the size of temporary needed in the assignment. Return loop, lss
1789 and rss which are used in function generate_loop_for_rhs_to_temp(). */
1790 inner_size = compute_inner_temp_size (expr1, expr2, block, &lss, &rss);
1792 /* The type of LHS. Used in function allocate_temp_for_forall_nest */
1793 type = gfc_typenode_for_spec (&expr1->ts);
1795 /* Allocate temporary for nested forall construct according to the
1796 information in nested_forall_info and inner_size. */
1797 tmp1 = allocate_temp_for_forall_nest (nested_forall_info, type,
1798 inner_size, block, &ptemp1);
1800 /* Initialize the maskindexes. */
1801 forall_tmp = nested_forall_info;
1802 while (forall_tmp != NULL)
1804 mask = forall_tmp->mask;
1805 maskindex = forall_tmp->maskindex;
1807 gfc_add_modify_expr (block, maskindex, gfc_index_zero_node);
1808 forall_tmp = forall_tmp->next_nest;
1811 /* Generate codes to copy rhs to the temporary . */
1812 tmp = generate_loop_for_rhs_to_temp (expr2, tmp1, inner_size, count,
1813 count1, count2, lss, rss, wheremask);
1815 /* Generate body and loops according to the inforamtion in
1816 nested_forall_info. */
1817 tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1, 1);
1818 gfc_add_expr_to_block (block, tmp);
1821 gfc_add_modify_expr (block, count1, gfc_index_zero_node);
1823 /* Reset maskindexed. */
1824 forall_tmp = nested_forall_info;
1825 while (forall_tmp != NULL)
1827 mask = forall_tmp->mask;
1828 maskindex = forall_tmp->maskindex;
1830 gfc_add_modify_expr (block, maskindex, gfc_index_zero_node);
1831 forall_tmp = forall_tmp->next_nest;
1836 gfc_add_modify_expr (block, count, gfc_index_zero_node);
1838 /* Generate codes to copy the temporary to lhs. */
1839 tmp = generate_loop_for_temp_to_lhs (expr1, tmp1, inner_size, count,
1840 count1, count2, wheremask);
1842 /* Generate body and loops according to the inforamtion in
1843 nested_forall_info. */
1844 tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1, 1);
1845 gfc_add_expr_to_block (block, tmp);
1849 /* Free the temporary. */
1850 tmp = gfc_chainon_list (NULL_TREE, ptemp1);
1851 tmp = gfc_build_function_call (gfor_fndecl_internal_free, tmp);
1852 gfc_add_expr_to_block (block, tmp);
1857 /* Translate pointer assignment inside FORALL which need temporary. */
1860 gfc_trans_pointer_assign_need_temp (gfc_expr * expr1, gfc_expr * expr2,
1861 forall_info * nested_forall_info,
1862 stmtblock_t * block)
1876 tree tmp, tmp1, ptemp1;
1877 tree mask, maskindex;
1878 forall_info *forall_tmp;
1880 count = gfc_create_var (gfc_array_index_type, "count");
1881 gfc_add_modify_expr (block, count, gfc_index_zero_node);
1883 inner_size = integer_one_node;
1884 lss = gfc_walk_expr (expr1);
1885 rss = gfc_walk_expr (expr2);
1886 if (lss == gfc_ss_terminator)
1888 type = gfc_typenode_for_spec (&expr1->ts);
1889 type = build_pointer_type (type);
1891 /* Allocate temporary for nested forall construct according to the
1892 information in nested_forall_info and inner_size. */
1893 tmp1 = allocate_temp_for_forall_nest (nested_forall_info,
1894 type, inner_size, block, &ptemp1);
1895 gfc_start_block (&body);
1896 gfc_init_se (&lse, NULL);
1897 lse.expr = gfc_build_array_ref (tmp1, count);
1898 gfc_init_se (&rse, NULL);
1899 rse.want_pointer = 1;
1900 gfc_conv_expr (&rse, expr2);
1901 gfc_add_block_to_block (&body, &rse.pre);
1902 gfc_add_modify_expr (&body, lse.expr, rse.expr);
1903 gfc_add_block_to_block (&body, &rse.post);
1905 /* Increment count. */
1906 tmp = fold (build (PLUS_EXPR, gfc_array_index_type,
1907 count, gfc_index_one_node));
1908 gfc_add_modify_expr (&body, count, tmp);
1910 tmp = gfc_finish_block (&body);
1912 /* Initialize the maskindexes. */
1913 forall_tmp = nested_forall_info;
1914 while (forall_tmp != NULL)
1916 mask = forall_tmp->mask;
1917 maskindex = forall_tmp->maskindex;
1919 gfc_add_modify_expr (block, maskindex, gfc_index_zero_node);
1920 forall_tmp = forall_tmp->next_nest;
1923 /* Generate body and loops according to the inforamtion in
1924 nested_forall_info. */
1925 tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1, 1);
1926 gfc_add_expr_to_block (block, tmp);
1929 gfc_add_modify_expr (block, count, gfc_index_zero_node);
1931 /* Reset maskindexes. */
1932 forall_tmp = nested_forall_info;
1933 while (forall_tmp != NULL)
1935 mask = forall_tmp->mask;
1936 maskindex = forall_tmp->maskindex;
1938 gfc_add_modify_expr (block, maskindex, gfc_index_zero_node);
1939 forall_tmp = forall_tmp->next_nest;
1941 gfc_start_block (&body);
1942 gfc_init_se (&lse, NULL);
1943 gfc_init_se (&rse, NULL);
1944 rse.expr = gfc_build_array_ref (tmp1, count);
1945 lse.want_pointer = 1;
1946 gfc_conv_expr (&lse, expr1);
1947 gfc_add_block_to_block (&body, &lse.pre);
1948 gfc_add_modify_expr (&body, lse.expr, rse.expr);
1949 gfc_add_block_to_block (&body, &lse.post);
1950 /* Increment count. */
1951 tmp = fold (build (PLUS_EXPR, gfc_array_index_type,
1952 count, gfc_index_one_node));
1953 gfc_add_modify_expr (&body, count, tmp);
1954 tmp = gfc_finish_block (&body);
1956 /* Generate body and loops according to the inforamtion in
1957 nested_forall_info. */
1958 tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1, 1);
1959 gfc_add_expr_to_block (block, tmp);
1963 gfc_init_loopinfo (&loop);
1965 /* Associate the SS with the loop. */
1966 gfc_add_ss_to_loop (&loop, rss);
1968 /* Setup the scalarizing loops and bounds. */
1969 gfc_conv_ss_startstride (&loop);
1971 gfc_conv_loop_setup (&loop);
1973 info = &rss->data.info;
1974 desc = info->descriptor;
1976 /* Make a new descriptor. */
1977 parmtype = gfc_get_element_type (TREE_TYPE (desc));
1978 parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen,
1979 loop.from, loop.to, 1);
1981 /* Allocate temporary for nested forall construct. */
1982 tmp1 = allocate_temp_for_forall_nest (nested_forall_info, parmtype,
1983 inner_size, block, &ptemp1);
1984 gfc_start_block (&body);
1985 gfc_init_se (&lse, NULL);
1986 lse.expr = gfc_build_array_ref (tmp1, count);
1987 lse.direct_byref = 1;
1988 rss = gfc_walk_expr (expr2);
1989 gfc_conv_expr_descriptor (&lse, expr2, rss);
1991 gfc_add_block_to_block (&body, &lse.pre);
1992 gfc_add_block_to_block (&body, &lse.post);
1994 /* Increment count. */
1995 tmp = fold (build (PLUS_EXPR, gfc_array_index_type,
1996 count, gfc_index_one_node));
1997 gfc_add_modify_expr (&body, count, tmp);
1999 tmp = gfc_finish_block (&body);
2001 /* Initialize the maskindexes. */
2002 forall_tmp = nested_forall_info;
2003 while (forall_tmp != NULL)
2005 mask = forall_tmp->mask;
2006 maskindex = forall_tmp->maskindex;
2008 gfc_add_modify_expr (block, maskindex, gfc_index_zero_node);
2009 forall_tmp = forall_tmp->next_nest;
2012 /* Generate body and loops according to the inforamtion in
2013 nested_forall_info. */
2014 tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1, 1);
2015 gfc_add_expr_to_block (block, tmp);
2018 gfc_add_modify_expr (block, count, gfc_index_zero_node);
2020 /* Reset maskindexes. */
2021 forall_tmp = nested_forall_info;
2022 while (forall_tmp != NULL)
2024 mask = forall_tmp->mask;
2025 maskindex = forall_tmp->maskindex;
2027 gfc_add_modify_expr (block, maskindex, gfc_index_zero_node);
2028 forall_tmp = forall_tmp->next_nest;
2030 parm = gfc_build_array_ref (tmp1, count);
2031 lss = gfc_walk_expr (expr1);
2032 gfc_init_se (&lse, NULL);
2033 gfc_conv_expr_descriptor (&lse, expr1, lss);
2034 gfc_add_modify_expr (&lse.pre, lse.expr, parm);
2035 gfc_start_block (&body);
2036 gfc_add_block_to_block (&body, &lse.pre);
2037 gfc_add_block_to_block (&body, &lse.post);
2039 /* Increment count. */
2040 tmp = fold (build (PLUS_EXPR, gfc_array_index_type,
2041 count, gfc_index_one_node));
2042 gfc_add_modify_expr (&body, count, tmp);
2044 tmp = gfc_finish_block (&body);
2046 tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1, 1);
2047 gfc_add_expr_to_block (block, tmp);
2049 /* Free the temporary. */
2052 tmp = gfc_chainon_list (NULL_TREE, ptemp1);
2053 tmp = gfc_build_function_call (gfor_fndecl_internal_free, tmp);
2054 gfc_add_expr_to_block (block, tmp);
2059 /* FORALL and WHERE statements are really nasty, especially when you nest
2060 them. All the rhs of a forall assignment must be evaluated before the
2061 actual assignments are performed. Presumably this also applies to all the
2062 assignments in an inner where statement. */
2064 /* Generate code for a FORALL statement. Any temporaries are allocated as a
2065 linear array, relying on the fact that we process in the same order in all
2068 forall (i=start:end:stride; maskexpr)
2072 (where e,f,g,h<i> are arbitary expressions possibly involving i)
2074 count = ((end + 1 - start) / staride)
2075 masktmp(:) = maskexpr(:)
2078 for (i = start; i <= end; i += stride)
2080 if (masktmp[maskindex++])
2084 for (i = start; i <= end; i += stride)
2086 if (masktmp[maskindex++])
2090 Note that this code only works when there are no dependencies.
2091 Forall loop with array assignments and data dependencies are a real pain,
2092 because the size of the temporary cannot always be determined before the
2093 loop is executed. This problem is compouded by the presence of nested
2098 gfc_trans_forall_1 (gfc_code * code, forall_info * nested_forall_info)
2120 gfc_forall_iterator *fa;
2123 gfc_saved_var *saved_vars;
2124 iter_info *this_forall, *iter_tmp;
2125 forall_info *info, *forall_tmp;
2126 temporary_list *temp;
2128 gfc_start_block (&block);
2131 /* Count the FORALL index number. */
2132 for (fa = code->ext.forall_iterator; fa; fa = fa->next)
2136 /* Allocate the space for var, start, end, step, varexpr. */
2137 var = (tree *) gfc_getmem (nvar * sizeof (tree));
2138 start = (tree *) gfc_getmem (nvar * sizeof (tree));
2139 end = (tree *) gfc_getmem (nvar * sizeof (tree));
2140 step = (tree *) gfc_getmem (nvar * sizeof (tree));
2141 varexpr = (gfc_expr **) gfc_getmem (nvar * sizeof (gfc_expr *));
2142 saved_vars = (gfc_saved_var *) gfc_getmem (nvar * sizeof (gfc_saved_var));
2144 /* Allocate the space for info. */
2145 info = (forall_info *) gfc_getmem (sizeof (forall_info));
2147 for (fa = code->ext.forall_iterator; fa; fa = fa->next)
2149 gfc_symbol *sym = fa->var->symtree->n.sym;
2151 /* allocate space for this_forall. */
2152 this_forall = (iter_info *) gfc_getmem (sizeof (iter_info));
2154 /* Create a temporary variable for the FORALL index. */
2155 tmp = gfc_typenode_for_spec (&sym->ts);
2156 var[n] = gfc_create_var (tmp, sym->name);
2157 gfc_shadow_sym (sym, var[n], &saved_vars[n]);
2159 /* Record it in this_forall. */
2160 this_forall->var = var[n];
2162 /* Replace the index symbol's backend_decl with the temporary decl. */
2163 sym->backend_decl = var[n];
2165 /* Work out the start, end and stride for the loop. */
2166 gfc_init_se (&se, NULL);
2167 gfc_conv_expr_val (&se, fa->start);
2168 /* Record it in this_forall. */
2169 this_forall->start = se.expr;
2170 gfc_add_block_to_block (&block, &se.pre);
2173 gfc_init_se (&se, NULL);
2174 gfc_conv_expr_val (&se, fa->end);
2175 /* Record it in this_forall. */
2176 this_forall->end = se.expr;
2177 gfc_make_safe_expr (&se);
2178 gfc_add_block_to_block (&block, &se.pre);
2181 gfc_init_se (&se, NULL);
2182 gfc_conv_expr_val (&se, fa->stride);
2183 /* Record it in this_forall. */
2184 this_forall->step = se.expr;
2185 gfc_make_safe_expr (&se);
2186 gfc_add_block_to_block (&block, &se.pre);
2189 /* Set the NEXT field of this_forall to NULL. */
2190 this_forall->next = NULL;
2191 /* Link this_forall to the info construct. */
2192 if (info->this_loop == NULL)
2193 info->this_loop = this_forall;
2196 iter_tmp = info->this_loop;
2197 while (iter_tmp->next != NULL)
2198 iter_tmp = iter_tmp->next;
2199 iter_tmp->next = this_forall;
2206 /* Work out the number of elements in the mask array. */
2209 size = gfc_index_one_node;
2210 sizevar = NULL_TREE;
2212 for (n = 0; n < nvar; n++)
2214 if (lenvar && TREE_TYPE (lenvar) != TREE_TYPE (start[n]))
2217 /* size = (end + step - start) / step. */
2218 tmp = fold (build (MINUS_EXPR, TREE_TYPE (start[n]), step[n], start[n]));
2219 tmp = fold (build (PLUS_EXPR, TREE_TYPE (end[n]), end[n], tmp));
2221 tmp = fold (build (FLOOR_DIV_EXPR, TREE_TYPE (tmp), tmp, step[n]));
2222 tmp = convert (gfc_array_index_type, tmp);
2224 size = fold (build (MULT_EXPR, gfc_array_index_type, size, tmp));
2227 /* Record the nvar and size of current forall level. */
2231 /* Link the current forall level to nested_forall_info. */
2232 forall_tmp = nested_forall_info;
2233 if (forall_tmp == NULL)
2234 nested_forall_info = info;
2237 while (forall_tmp->next_nest != NULL)
2238 forall_tmp = forall_tmp->next_nest;
2239 info->outer = forall_tmp;
2240 forall_tmp->next_nest = info;
2243 /* Copy the mask into a temporary variable if required.
2244 For now we assume a mask temporary is needed. */
2247 /* Allocate the mask temporary. */
2248 bytesize = fold (build (MULT_EXPR, gfc_array_index_type, size,
2249 TYPE_SIZE_UNIT (boolean_type_node)));
2251 mask = gfc_do_allocate (bytesize, size, &pmask, &block, boolean_type_node);
2253 maskindex = gfc_create_var_np (gfc_array_index_type, "mi");
2254 /* Record them in the info structure. */
2255 info->pmask = pmask;
2257 info->maskindex = maskindex;
2259 gfc_add_modify_expr (&block, maskindex, gfc_index_zero_node);
2261 /* Start of mask assignment loop body. */
2262 gfc_start_block (&body);
2264 /* Evaluate the mask expression. */
2265 gfc_init_se (&se, NULL);
2266 gfc_conv_expr_val (&se, code->expr);
2267 gfc_add_block_to_block (&body, &se.pre);
2269 /* Store the mask. */
2270 se.expr = convert (boolean_type_node, se.expr);
2273 tmp = gfc_build_indirect_ref (mask);
2276 tmp = gfc_build_array_ref (tmp, maskindex);
2277 gfc_add_modify_expr (&body, tmp, se.expr);
2279 /* Advance to the next mask element. */
2280 tmp = build (PLUS_EXPR, gfc_array_index_type,
2281 maskindex, gfc_index_one_node);
2282 gfc_add_modify_expr (&body, maskindex, tmp);
2284 /* Generate the loops. */
2285 tmp = gfc_finish_block (&body);
2286 tmp = gfc_trans_nested_forall_loop (info, tmp, 0, 0);
2287 gfc_add_expr_to_block (&block, tmp);
2291 /* No mask was specified. */
2292 maskindex = NULL_TREE;
2293 mask = pmask = NULL_TREE;
2296 c = code->block->next;
2298 /* TODO: loop merging in FORALL statements. */
2299 /* Now that we've got a copy of the mask, generate the assignment loops. */
2305 /* A scalar or array assingment. */
2306 need_temp = gfc_check_dependency (c->expr, c->expr2, varexpr, nvar);
2307 /* Teporaries due to array assignment data dependencies introduce
2308 no end of problems. */
2310 gfc_trans_assign_need_temp (c->expr, c->expr2, NULL,
2311 nested_forall_info, &block);
2314 /* Use the normal assignment copying routines. */
2315 assign = gfc_trans_assignment (c->expr, c->expr2);
2317 /* Reset the mask index. */
2319 gfc_add_modify_expr (&block, maskindex, gfc_index_zero_node);
2321 /* Generate body and loops. */
2322 tmp = gfc_trans_nested_forall_loop (nested_forall_info, assign, 1, 1);
2323 gfc_add_expr_to_block (&block, tmp);
2330 /* Translate WHERE or WHERE construct nested in FORALL. */
2332 gfc_trans_where_2 (c, NULL, NULL, nested_forall_info, &block, &temp);
2339 /* Free the temporary. */
2340 args = gfc_chainon_list (NULL_TREE, temp->temporary);
2341 tmp = gfc_build_function_call (gfor_fndecl_internal_free, args);
2342 gfc_add_expr_to_block (&block, tmp);
2351 /* Pointer assignment inside FORALL. */
2352 case EXEC_POINTER_ASSIGN:
2353 need_temp = gfc_check_dependency (c->expr, c->expr2, varexpr, nvar);
2355 gfc_trans_pointer_assign_need_temp (c->expr, c->expr2,
2356 nested_forall_info, &block);
2359 /* Use the normal assignment copying routines. */
2360 assign = gfc_trans_pointer_assignment (c->expr, c->expr2);
2362 /* Reset the mask index. */
2364 gfc_add_modify_expr (&block, maskindex, gfc_index_zero_node);
2366 /* Generate body and loops. */
2367 tmp = gfc_trans_nested_forall_loop (nested_forall_info, assign,
2369 gfc_add_expr_to_block (&block, tmp);
2374 tmp = gfc_trans_forall_1 (c, nested_forall_info);
2375 gfc_add_expr_to_block (&block, tmp);
2386 /* Restore the original index variables. */
2387 for (fa = code->ext.forall_iterator, n = 0; fa; fa = fa->next, n++)
2388 gfc_restore_sym (fa->var->symtree->n.sym, &saved_vars[n]);
2390 /* Free the space for var, start, end, step, varexpr. */
2396 gfc_free (saved_vars);
2400 /* Free the temporary for the mask. */
2401 tmp = gfc_chainon_list (NULL_TREE, pmask);
2402 tmp = gfc_build_function_call (gfor_fndecl_internal_free, tmp);
2403 gfc_add_expr_to_block (&block, tmp);
2406 pushdecl (maskindex);
2408 return gfc_finish_block (&block);
2412 /* Translate the FORALL statement or construct. */
2414 tree gfc_trans_forall (gfc_code * code)
2416 return gfc_trans_forall_1 (code, NULL);
2420 /* Evaluate the WHERE mask expression, copy its value to a temporary.
2421 If the WHERE construct is nested in FORALL, compute the overall temporary
2422 needed by the WHERE mask expression multiplied by the iterator number of
2424 ME is the WHERE mask expression.
2425 MASK is the temporary which value is mask's value.
2426 NMASK is another temporary which value is !mask.
2427 TEMP records the temporary's address allocated in this function in order to
2428 free them outside this function.
2429 MASK, NMASK and TEMP are all OUT arguments. */
2432 gfc_evaluate_where_mask (gfc_expr * me, forall_info * nested_forall_info,
2433 tree * mask, tree * nmask, temporary_list ** temp,
2434 stmtblock_t * block)
2439 tree ptemp1, ntmp, ptemp2;
2441 stmtblock_t body, body1;
2446 gfc_init_loopinfo (&loop);
2448 /* Calculate the size of temporary needed by the mask-expr. */
2449 inner_size = compute_inner_temp_size (me, me, block, &lss, &rss);
2451 /* Allocate temporary for where mask. */
2452 tmp = allocate_temp_for_forall_nest (nested_forall_info, boolean_type_node,
2453 inner_size, block, &ptemp1);
2454 /* Record the temporary address in order to free it later. */
2457 temporary_list *tempo;
2458 tempo = (temporary_list *) gfc_getmem (sizeof (temporary_list));
2459 tempo->temporary = ptemp1;
2460 tempo->next = *temp;
2464 /* Allocate temporary for !mask. */
2465 ntmp = allocate_temp_for_forall_nest (nested_forall_info, boolean_type_node,
2466 inner_size, block, &ptemp2);
2467 /* Record the temporary in order to free it later. */
2470 temporary_list *tempo;
2471 tempo = (temporary_list *) gfc_getmem (sizeof (temporary_list));
2472 tempo->temporary = ptemp2;
2473 tempo->next = *temp;
2477 /* Variable to index the temporary. */
2478 count = gfc_create_var (gfc_array_index_type, "count");
2479 /* Initilize count. */
2480 gfc_add_modify_expr (block, count, gfc_index_zero_node);
2482 gfc_start_block (&body);
2484 gfc_init_se (&rse, NULL);
2485 gfc_init_se (&lse, NULL);
2487 if (lss == gfc_ss_terminator)
2489 gfc_init_block (&body1);
2493 /* Initiliaze the loop. */
2494 gfc_init_loopinfo (&loop);
2496 /* We may need LSS to determine the shape of the expression. */
2497 gfc_add_ss_to_loop (&loop, lss);
2498 gfc_add_ss_to_loop (&loop, rss);
2500 gfc_conv_ss_startstride (&loop);
2501 gfc_conv_loop_setup (&loop);
2503 gfc_mark_ss_chain_used (rss, 1);
2504 /* Start the loop body. */
2505 gfc_start_scalarized_body (&loop, &body1);
2507 /* Translate the expression. */
2508 gfc_copy_loopinfo_to_se (&rse, &loop);
2510 gfc_conv_expr (&rse, me);
2512 /* Form the expression of the temporary. */
2513 lse.expr = gfc_build_array_ref (tmp, count);
2514 tmpexpr = gfc_build_array_ref (ntmp, count);
2516 /* Use the scalar assignment to fill temporary TMP. */
2517 tmp1 = gfc_trans_scalar_assign (&lse, &rse, me->ts.type);
2518 gfc_add_expr_to_block (&body1, tmp1);
2520 /* Fill temporary NTMP. */
2521 tmp1 = build1 (TRUTH_NOT_EXPR, TREE_TYPE (lse.expr), lse.expr);
2522 gfc_add_modify_expr (&body1, tmpexpr, tmp1);
2524 if (lss == gfc_ss_terminator)
2526 gfc_add_block_to_block (&body, &body1);
2530 /* Increment count. */
2531 tmp1 = fold (build (PLUS_EXPR, gfc_array_index_type, count,
2532 gfc_index_one_node));
2533 gfc_add_modify_expr (&body1, count, tmp1);
2535 /* Generate the copying loops. */
2536 gfc_trans_scalarizing_loops (&loop, &body1);
2538 gfc_add_block_to_block (&body, &loop.pre);
2539 gfc_add_block_to_block (&body, &loop.post);
2541 gfc_cleanup_loop (&loop);
2542 /* TODO: Reuse lss and rss when copying temp->lhs. Need to be careful
2543 as tree nodes in SS may not be valid in different scope. */
2546 tmp1 = gfc_finish_block (&body);
2547 /* If the WHERE construct is inside FORALL, fill the full temporary. */
2548 if (nested_forall_info != NULL)
2549 tmp1 = gfc_trans_nested_forall_loop (nested_forall_info, tmp1, 1, 1);
2552 gfc_add_expr_to_block (block, tmp1);
2561 /* Translate an assignment statement in a WHERE statement or construct
2562 statement. The MASK expression is used to control which elements
2563 of EXPR1 shall be assigned. */
2566 gfc_trans_where_assign (gfc_expr *expr1, gfc_expr *expr2, tree mask,
2567 tree count1, tree count2)
2572 gfc_ss *lss_section;
2579 tree index, maskexpr, tmp1;
2582 /* TODO: handle this special case.
2583 Special case a single function returning an array. */
2584 if (expr2->expr_type == EXPR_FUNCTION && expr2->rank > 0)
2586 tmp = gfc_trans_arrayfunc_assign (expr1, expr2);
2592 /* Assignment of the form lhs = rhs. */
2593 gfc_start_block (&block);
2595 gfc_init_se (&lse, NULL);
2596 gfc_init_se (&rse, NULL);
2599 lss = gfc_walk_expr (expr1);
2602 /* In each where-assign-stmt, the mask-expr and the variable being
2603 defined shall be arrays of the same shape. */
2604 assert (lss != gfc_ss_terminator);
2606 /* The assignment needs scalarization. */
2609 /* Find a non-scalar SS from the lhs. */
2610 while (lss_section != gfc_ss_terminator
2611 && lss_section->type != GFC_SS_SECTION)
2612 lss_section = lss_section->next;
2614 assert (lss_section != gfc_ss_terminator);
2616 /* Initialize the scalarizer. */
2617 gfc_init_loopinfo (&loop);
2620 rss = gfc_walk_expr (expr2);
2621 if (rss == gfc_ss_terminator)
2623 /* The rhs is scalar. Add a ss for the expression. */
2624 rss = gfc_get_ss ();
2625 rss->next = gfc_ss_terminator;
2626 rss->type = GFC_SS_SCALAR;
2630 /* Associate the SS with the loop. */
2631 gfc_add_ss_to_loop (&loop, lss);
2632 gfc_add_ss_to_loop (&loop, rss);
2634 /* Calculate the bounds of the scalarization. */
2635 gfc_conv_ss_startstride (&loop);
2637 /* Resolve any data dependencies in the statement. */
2638 gfc_conv_resolve_dependencies (&loop, lss_section, rss);
2640 /* Setup the scalarizing loops. */
2641 gfc_conv_loop_setup (&loop);
2643 /* Setup the gfc_se structures. */
2644 gfc_copy_loopinfo_to_se (&lse, &loop);
2645 gfc_copy_loopinfo_to_se (&rse, &loop);
2648 gfc_mark_ss_chain_used (rss, 1);
2649 if (loop.temp_ss == NULL)
2652 gfc_mark_ss_chain_used (lss, 1);
2656 lse.ss = loop.temp_ss;
2657 gfc_mark_ss_chain_used (lss, 3);
2658 gfc_mark_ss_chain_used (loop.temp_ss, 3);
2661 /* Start the scalarized loop body. */
2662 gfc_start_scalarized_body (&loop, &body);
2664 /* Translate the expression. */
2665 gfc_conv_expr (&rse, expr2);
2666 if (lss != gfc_ss_terminator && loop.temp_ss != NULL)
2668 gfc_conv_tmp_array_ref (&lse);
2669 gfc_advance_se_ss_chain (&lse);
2672 gfc_conv_expr (&lse, expr1);
2674 /* Form the mask expression according to the mask tree list. */
2678 maskexpr = gfc_build_array_ref (tmp, index);
2682 tmp = TREE_CHAIN (tmp);
2685 tmp1 = gfc_build_array_ref (tmp, index);
2686 maskexpr = build (TRUTH_AND_EXPR, TREE_TYPE (tmp1), maskexpr, tmp1);
2687 tmp = TREE_CHAIN (tmp);
2689 /* Use the scalar assignment as is. */
2690 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts.type);
2691 tmp = build_v (COND_EXPR, maskexpr, tmp, build_empty_stmt ());
2693 gfc_add_expr_to_block (&body, tmp);
2695 if (lss == gfc_ss_terminator)
2697 /* Increment count1. */
2698 tmp = fold (build (PLUS_EXPR, gfc_array_index_type,
2699 count1, gfc_index_one_node));
2700 gfc_add_modify_expr (&body, count1, tmp);
2702 /* Use the scalar assignment as is. */
2703 gfc_add_block_to_block (&block, &body);
2707 if (lse.ss != gfc_ss_terminator)
2709 if (rse.ss != gfc_ss_terminator)
2712 if (loop.temp_ss != NULL)
2714 /* Increment count1 before finish the main body of a scalarized
2716 tmp = fold (build (PLUS_EXPR, gfc_array_index_type,
2717 count1, gfc_index_one_node));
2718 gfc_add_modify_expr (&body, count1, tmp);
2719 gfc_trans_scalarized_loop_boundary (&loop, &body);
2721 /* We need to copy the temporary to the actual lhs. */
2722 gfc_init_se (&lse, NULL);
2723 gfc_init_se (&rse, NULL);
2724 gfc_copy_loopinfo_to_se (&lse, &loop);
2725 gfc_copy_loopinfo_to_se (&rse, &loop);
2727 rse.ss = loop.temp_ss;
2730 gfc_conv_tmp_array_ref (&rse);
2731 gfc_advance_se_ss_chain (&rse);
2732 gfc_conv_expr (&lse, expr1);
2734 if (lse.ss != gfc_ss_terminator)
2737 if (rse.ss != gfc_ss_terminator)
2740 /* Form the mask expression according to the mask tree list. */
2744 maskexpr = gfc_build_array_ref (tmp, index);
2748 tmp = TREE_CHAIN (tmp);
2751 tmp1 = gfc_build_array_ref (tmp, index);
2752 maskexpr = build (TRUTH_AND_EXPR, TREE_TYPE (tmp1), maskexpr,
2754 tmp = TREE_CHAIN (tmp);
2756 /* Use the scalar assignment as is. */
2757 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts.type);
2758 tmp = build_v (COND_EXPR, maskexpr, tmp, build_empty_stmt ());
2759 gfc_add_expr_to_block (&body, tmp);
2761 /* Increment count2. */
2762 tmp = fold (build (PLUS_EXPR, gfc_array_index_type,
2763 count2, gfc_index_one_node));
2764 gfc_add_modify_expr (&body, count2, tmp);
2768 /* Increment count1. */
2769 tmp = fold (build (PLUS_EXPR, gfc_array_index_type,
2770 count1, gfc_index_one_node));
2771 gfc_add_modify_expr (&body, count1, tmp);
2774 /* Generate the copying loops. */
2775 gfc_trans_scalarizing_loops (&loop, &body);
2777 /* Wrap the whole thing up. */
2778 gfc_add_block_to_block (&block, &loop.pre);
2779 gfc_add_block_to_block (&block, &loop.post);
2780 gfc_cleanup_loop (&loop);
2783 return gfc_finish_block (&block);
2787 /* Translate the WHERE construct or statement.
2788 This fuction can be called iteratelly to translate the nested WHERE
2789 construct or statement.
2790 MASK is the control mask, and PMASK is the pending control mask.
2791 TEMP records the temporary address which must be freed later. */
2794 gfc_trans_where_2 (gfc_code * code, tree mask, tree pmask,
2795 forall_info * nested_forall_info, stmtblock_t * block,
2796 temporary_list ** temp)
2802 tree tmp, tmp1, tmp2;
2803 tree count1, count2;
2807 /* the WHERE statement or the WHERE construct statement. */
2808 cblock = code->block;
2811 /* Has mask-expr. */
2814 /* Ensure that the WHERE mask be evaluated only once. */
2815 tmp2 = gfc_evaluate_where_mask (cblock->expr, nested_forall_info,
2816 &tmp, &tmp1, temp, block);
2818 /* Set the control mask and the pending control mask. */
2819 /* It's a where-stmt. */
2825 /* It's a nested where-stmt. */
2826 else if (mask && pmask == NULL)
2829 /* Use the TREE_CHAIN to list the masks. */
2830 tmp2 = copy_list (mask);
2831 pmask = chainon (mask, tmp1);
2832 mask = chainon (tmp2, tmp);
2834 /* It's a masked-elsewhere-stmt. */
2835 else if (mask && cblock->expr)
2838 tmp2 = copy_list (pmask);
2841 tmp2 = chainon (tmp2, tmp);
2842 pmask = chainon (mask, tmp1);
2846 /* It's a elsewhere-stmt. No mask-expr is present. */
2850 /* Get the assignment statement of a WHERE statement, or the first
2851 statement in where-body-construct of a WHERE construct. */
2852 cnext = cblock->next;
2857 /* WHERE assignment statement. */
2859 expr1 = cnext->expr;
2860 expr2 = cnext->expr2;
2861 if (nested_forall_info != NULL)
2866 nvar = nested_forall_info->nvar;
2867 varexpr = (gfc_expr **)
2868 gfc_getmem (nvar * sizeof (gfc_expr *));
2869 need_temp = gfc_check_dependency (expr1, expr2, varexpr,
2872 gfc_trans_assign_need_temp (expr1, expr2, mask,
2873 nested_forall_info, block);
2876 /* Variables to control maskexpr. */
2877 count1 = gfc_create_var (gfc_array_index_type, "count1");
2878 count2 = gfc_create_var (gfc_array_index_type, "count2");
2879 gfc_add_modify_expr (block, count1, gfc_index_zero_node);
2880 gfc_add_modify_expr (block, count2, gfc_index_zero_node);
2882 tmp = gfc_trans_where_assign (expr1, expr2, mask, count1,
2884 tmp = gfc_trans_nested_forall_loop (nested_forall_info,
2886 gfc_add_expr_to_block (block, tmp);
2891 /* Variables to control maskexpr. */
2892 count1 = gfc_create_var (gfc_array_index_type, "count1");
2893 count2 = gfc_create_var (gfc_array_index_type, "count2");
2894 gfc_add_modify_expr (block, count1, gfc_index_zero_node);
2895 gfc_add_modify_expr (block, count2, gfc_index_zero_node);
2897 tmp = gfc_trans_where_assign (expr1, expr2, mask, count1,
2899 gfc_add_expr_to_block (block, tmp);
2904 /* WHERE or WHERE construct is part of a where-body-construct. */
2906 /* Ensure that MASK is not modified by next gfc_trans_where_2. */
2907 mask_copy = copy_list (mask);
2908 gfc_trans_where_2 (cnext, mask_copy, NULL, nested_forall_info,
2916 /* The next statement within the same where-body-construct. */
2917 cnext = cnext->next;
2919 /* The next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt. */
2920 cblock = cblock->block;
2925 /* As the WHERE or WHERE construct statement can be nested, we call
2926 gfc_trans_where_2 to do the translation, and pass the initial
2927 NULL values for both the control mask and the pending control mask. */
2930 gfc_trans_where (gfc_code * code)
2933 temporary_list *temp, *p;
2937 gfc_start_block (&block);
2940 gfc_trans_where_2 (code, NULL, NULL, NULL, &block, &temp);
2942 /* Add calls to free temporaries which were dynamically allocated. */
2945 args = gfc_chainon_list (NULL_TREE, temp->temporary);
2946 tmp = gfc_build_function_call (gfor_fndecl_internal_free, args);
2947 gfc_add_expr_to_block (&block, tmp);
2953 return gfc_finish_block (&block);
2957 /* CYCLE a DO loop. The label decl has already been created by
2958 gfc_trans_do(), it's in TREE_PURPOSE (backend_decl) of the gfc_code
2959 node at the head of the loop. We must mark the label as used. */
2962 gfc_trans_cycle (gfc_code * code)
2966 cycle_label = TREE_PURPOSE (code->ext.whichloop->backend_decl);
2967 TREE_USED (cycle_label) = 1;
2968 return build1_v (GOTO_EXPR, cycle_label);
2972 /* EXIT a DO loop. Similair to CYCLE, but now the label is in
2973 TREE_VALUE (backend_decl) of the gfc_code node at the head of the
2977 gfc_trans_exit (gfc_code * code)
2981 exit_label = TREE_VALUE (code->ext.whichloop->backend_decl);
2982 TREE_USED (exit_label) = 1;
2983 return build1_v (GOTO_EXPR, exit_label);
2987 /* Translate the ALLOCATE statement. */
2990 gfc_trans_allocate (gfc_code * code)
3003 if (!code->ext.alloc_list)
3006 gfc_start_block (&block);
3010 stat = gfc_create_var (gfc_int4_type_node, "stat");
3011 pstat = gfc_build_addr_expr (NULL, stat);
3013 error_label = gfc_build_label_decl (NULL_TREE);
3014 TREE_USED (error_label) = 1;
3018 pstat = integer_zero_node;
3019 stat = error_label = NULL_TREE;
3023 for (al = code->ext.alloc_list; al != NULL; al = al->next)
3027 gfc_init_se (&se, NULL);
3028 gfc_start_block (&se.pre);
3030 se.want_pointer = 1;
3031 se.descriptor_only = 1;
3032 gfc_conv_expr (&se, expr);
3036 /* Find the last reference in the chain. */
3037 while (ref && ref->next != NULL)
3039 assert (ref->type != REF_ARRAY || ref->u.ar.type == AR_ELEMENT);
3043 if (ref != NULL && ref->type == REF_ARRAY)
3046 gfc_array_allocate (&se, ref, pstat);
3050 /* A scalar or derived type. */
3053 val = gfc_create_var (ppvoid_type_node, "ptr");
3054 tmp = gfc_build_addr_expr (ppvoid_type_node, se.expr);
3055 gfc_add_modify_expr (&se.pre, val, tmp);
3057 tmp = TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (se.expr)));
3058 parm = gfc_chainon_list (NULL_TREE, val);
3059 parm = gfc_chainon_list (parm, tmp);
3060 parm = gfc_chainon_list (parm, pstat);
3061 tmp = gfc_build_function_call (gfor_fndecl_allocate, parm);
3062 gfc_add_expr_to_block (&se.pre, tmp);
3066 tmp = build1_v (GOTO_EXPR, error_label);
3068 build (NE_EXPR, boolean_type_node, stat, integer_zero_node);
3069 tmp = build_v (COND_EXPR, parm, tmp, build_empty_stmt ());
3070 gfc_add_expr_to_block (&se.pre, tmp);
3074 tmp = gfc_finish_block (&se.pre);
3075 gfc_add_expr_to_block (&block, tmp);
3078 /* Assign the value to the status variable. */
3081 tmp = build1_v (LABEL_EXPR, error_label);
3082 gfc_add_expr_to_block (&block, tmp);
3084 gfc_init_se (&se, NULL);
3085 gfc_conv_expr_lhs (&se, code->expr);
3086 tmp = convert (TREE_TYPE (se.expr), stat);
3087 gfc_add_modify_expr (&block, se.expr, tmp);
3090 return gfc_finish_block (&block);
3095 gfc_trans_deallocate (gfc_code * code)
3105 gfc_start_block (&block);
3107 for (al = code->ext.alloc_list; al != NULL; al = al->next)
3110 assert (expr->expr_type == EXPR_VARIABLE);
3112 gfc_init_se (&se, NULL);
3113 gfc_start_block (&se.pre);
3115 se.want_pointer = 1;
3116 se.descriptor_only = 1;
3117 gfc_conv_expr (&se, expr);
3119 if (expr->symtree->n.sym->attr.dimension)
3121 tmp = gfc_array_deallocate (se.expr);
3122 gfc_add_expr_to_block (&se.pre, tmp);
3126 type = build_pointer_type (TREE_TYPE (se.expr));
3127 var = gfc_create_var (type, "ptr");
3128 tmp = gfc_build_addr_expr (type, se.expr);
3129 gfc_add_modify_expr (&se.pre, var, tmp);
3131 tmp = gfc_chainon_list (NULL_TREE, var);
3132 tmp = gfc_chainon_list (tmp, integer_zero_node);
3133 tmp = gfc_build_function_call (gfor_fndecl_deallocate, tmp);
3134 gfc_add_expr_to_block (&se.pre, tmp);
3136 tmp = gfc_finish_block (&se.pre);
3137 gfc_add_expr_to_block (&block, tmp);
3140 return gfc_finish_block (&block);