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_2 (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_2 (code->ext.stop_code, 0);
283 TREE_TYPE (tmp) = gfc_int4_type_node;
284 args = gfc_chainon_list (NULL_TREE, tmp);
285 fndecl = gfor_fndecl_pause_numeric;
289 gfc_conv_expr_reference (&se, code->expr);
290 args = gfc_chainon_list (NULL_TREE, se.expr);
291 args = gfc_chainon_list (args, se.string_length);
292 fndecl = gfor_fndecl_pause_string;
295 tmp = gfc_build_function_call (fndecl, args);
296 gfc_add_expr_to_block (&se.pre, tmp);
298 gfc_add_block_to_block (&se.pre, &se.post);
300 return gfc_finish_block (&se.pre);
304 /* Translate the STOP statement. We have to translate this statement
305 to a runtime library call. */
308 gfc_trans_stop (gfc_code * code)
315 /* Start a new block for this statement. */
316 gfc_init_se (&se, NULL);
317 gfc_start_block (&se.pre);
320 if (code->expr == NULL)
322 tmp = build_int_2 (code->ext.stop_code, 0);
323 TREE_TYPE (tmp) = gfc_int4_type_node;
324 args = gfc_chainon_list (NULL_TREE, tmp);
325 fndecl = gfor_fndecl_stop_numeric;
329 gfc_conv_expr_reference (&se, code->expr);
330 args = gfc_chainon_list (NULL_TREE, se.expr);
331 args = gfc_chainon_list (args, se.string_length);
332 fndecl = gfor_fndecl_stop_string;
335 tmp = gfc_build_function_call (fndecl, args);
336 gfc_add_expr_to_block (&se.pre, tmp);
338 gfc_add_block_to_block (&se.pre, &se.post);
340 return gfc_finish_block (&se.pre);
344 /* Generate GENERIC for the IF construct. This function also deals with
345 the simple IF statement, because the front end translates the IF
346 statement into an IF construct.
378 where COND_S is the simplified version of the predicate. PRE_COND_S
379 are the pre side-effects produced by the translation of the
381 We need to build the chain recursively otherwise we run into
382 problems with folding incomplete statements. */
385 gfc_trans_if_1 (gfc_code * code)
390 /* Check for an unconditional ELSE clause. */
392 return gfc_trans_code (code->next);
394 /* Initialize a statement builder for each block. Puts in NULL_TREEs. */
395 gfc_init_se (&if_se, NULL);
396 gfc_start_block (&if_se.pre);
398 /* Calculate the IF condition expression. */
399 gfc_conv_expr_val (&if_se, code->expr);
401 /* Translate the THEN clause. */
402 stmt = gfc_trans_code (code->next);
404 /* Translate the ELSE clause. */
406 elsestmt = gfc_trans_if_1 (code->block);
408 elsestmt = build_empty_stmt ();
410 /* Build the condition expression and add it to the condition block. */
411 stmt = build_v (COND_EXPR, if_se.expr, stmt, elsestmt);
413 gfc_add_expr_to_block (&if_se.pre, stmt);
415 /* Finish off this statement. */
416 return gfc_finish_block (&if_se.pre);
420 gfc_trans_if (gfc_code * code)
422 /* Ignore the top EXEC_IF, it only announces an IF construct. The
423 actual code we must translate is in code->block. */
425 return gfc_trans_if_1 (code->block);
429 /* Translage an arithmetic IF expression.
431 IF (cond) label1, label2, label3 translates to
445 gfc_trans_arithmetic_if (gfc_code * code)
453 /* Start a new block. */
454 gfc_init_se (&se, NULL);
455 gfc_start_block (&se.pre);
457 /* Pre-evaluate COND. */
458 gfc_conv_expr_val (&se, code->expr);
460 /* Build something to compare with. */
461 zero = gfc_build_const (TREE_TYPE (se.expr), integer_zero_node);
463 /* If (cond < 0) take branch1 else take branch2.
464 First build jumps to the COND .LT. 0 and the COND .EQ. 0 cases. */
465 branch1 = build1_v (GOTO_EXPR, gfc_get_label_decl (code->label));
466 branch2 = build1_v (GOTO_EXPR, gfc_get_label_decl (code->label2));
468 tmp = build (LT_EXPR, boolean_type_node, se.expr, zero);
469 branch1 = build_v (COND_EXPR, tmp, branch1, branch2);
471 /* if (cond <= 0) take branch1 else take branch2. */
472 branch2 = build1_v (GOTO_EXPR, gfc_get_label_decl (code->label3));
473 tmp = build (LE_EXPR, boolean_type_node, se.expr, zero);
474 branch1 = build_v (COND_EXPR, tmp, branch1, branch2);
476 /* Append the COND_EXPR to the evaluation of COND, and return. */
477 gfc_add_expr_to_block (&se.pre, branch1);
478 return gfc_finish_block (&se.pre);
482 /* Translate the DO construct. This obviously is one of the most
483 important ones to get right with any compiler, but especially
486 Currently we calculate the loop count before entering the loop, but
487 it may be possible to optimize if step is a constant. The main
488 advantage is that the loop test is a single GENERIC node
490 We translate a do loop from:
492 DO dovar = from, to, step
502 temp1=to_expr-from_expr;
504 range_temp=step_tmp/range_temp;
505 for ( ; range_temp > 0 ; range_temp = range_temp - 1)
510 dovar=dovar_temp + step_temp;
514 Some optimization is done for empty do loops. We can't just let
515 dovar=to because it's possible for from+range*loopcount!=to. Anyone
516 who writes empty DO deserves sub-optimal (but correct) code anyway.
518 TODO: Large loop counts
519 Does not work loop counts which do not fit into a signed integer kind,
520 ie. Does not work for loop counts > 2^31 for integer(kind=4) variables
521 We must support the full range. */
524 gfc_trans_do (gfc_code * code)
540 gfc_start_block (&block);
542 /* Create GIMPLE versions of all expressions in the iterator. */
544 gfc_init_se (&se, NULL);
545 gfc_conv_expr_lhs (&se, code->ext.iterator->var);
546 gfc_add_block_to_block (&block, &se.pre);
548 type = TREE_TYPE (dovar);
550 gfc_init_se (&se, NULL);
551 gfc_conv_expr_type (&se, code->ext.iterator->start, type);
552 gfc_add_block_to_block (&block, &se.pre);
555 gfc_init_se (&se, NULL);
556 gfc_conv_expr_type (&se, code->ext.iterator->end, type);
557 gfc_add_block_to_block (&block, &se.pre);
560 gfc_init_se (&se, NULL);
561 gfc_conv_expr_type (&se, code->ext.iterator->step, type);
563 /* We don't want this changing part way through. */
564 gfc_make_safe_expr (&se);
565 gfc_add_block_to_block (&block, &se.pre);
568 /* Initialise loop count. This code is executed before we enter the
569 loop body. We generate: count = (to + step - from) / step. */
571 tmp = fold (build (MINUS_EXPR, type, step, from));
572 tmp = fold (build (PLUS_EXPR, type, to, tmp));
573 tmp = fold (build (TRUNC_DIV_EXPR, type, tmp, step));
575 count = gfc_create_var (type, "count");
576 gfc_add_modify_expr (&block, count, tmp);
578 /* Initialise the DO variable: dovar = from. */
579 gfc_add_modify_expr (&block, dovar, from);
582 gfc_start_block (&body);
584 /* Cycle and exit statements are implemented with gotos. */
585 cycle_label = gfc_build_label_decl (NULL_TREE);
586 exit_label = gfc_build_label_decl (NULL_TREE);
588 /* Start with the loop condition. Loop until count <= 0. */
589 cond = build (LE_EXPR, boolean_type_node, count, integer_zero_node);
590 tmp = build1_v (GOTO_EXPR, exit_label);
591 TREE_USED (exit_label) = 1;
592 tmp = build_v (COND_EXPR, cond, tmp, build_empty_stmt ());
593 gfc_add_expr_to_block (&body, tmp);
595 /* Put these labels where they can be found later. We put the
596 labels in a TREE_LIST node (because TREE_CHAIN is already
597 used). cycle_label goes in TREE_PURPOSE (backend_decl), exit
598 label in TREE_VALUE (backend_decl). */
600 code->block->backend_decl = tree_cons (cycle_label, exit_label, NULL);
602 /* Main loop body. */
603 tmp = gfc_trans_code (code->block->next);
604 gfc_add_expr_to_block (&body, tmp);
606 /* Label for cycle statements (if needed). */
607 if (TREE_USED (cycle_label))
609 tmp = build1_v (LABEL_EXPR, cycle_label);
610 gfc_add_expr_to_block (&body, tmp);
613 /* Increment the loop variable. */
614 tmp = build (PLUS_EXPR, type, dovar, step);
615 gfc_add_modify_expr (&body, dovar, tmp);
617 /* Decrement the loop count. */
618 tmp = build (MINUS_EXPR, type, count, gfc_index_one_node);
619 gfc_add_modify_expr (&body, count, tmp);
621 /* End of loop body. */
622 tmp = gfc_finish_block (&body);
624 /* The for loop itself. */
625 tmp = build_v (LOOP_EXPR, tmp);
626 gfc_add_expr_to_block (&block, tmp);
628 /* Add the exit label. */
629 tmp = build1_v (LABEL_EXPR, exit_label);
630 gfc_add_expr_to_block (&block, tmp);
632 return gfc_finish_block (&block);
636 /* Translate the DO WHILE construct.
649 if (! cond) goto exit_label;
655 Because the evaluation of the exit condition `cond' may have side
656 effects, we can't do much for empty loop bodies. The backend optimizers
657 should be smart enough to eliminate any dead loops. */
660 gfc_trans_do_while (gfc_code * code)
668 /* Everything we build here is part of the loop body. */
669 gfc_start_block (&block);
671 /* Cycle and exit statements are implemented with gotos. */
672 cycle_label = gfc_build_label_decl (NULL_TREE);
673 exit_label = gfc_build_label_decl (NULL_TREE);
675 /* Put the labels where they can be found later. See gfc_trans_do(). */
676 code->block->backend_decl = tree_cons (cycle_label, exit_label, NULL);
678 /* Create a GIMPLE version of the exit condition. */
679 gfc_init_se (&cond, NULL);
680 gfc_conv_expr_val (&cond, code->expr);
681 gfc_add_block_to_block (&block, &cond.pre);
682 cond.expr = fold (build1 (TRUTH_NOT_EXPR, boolean_type_node, cond.expr));
684 /* Build "IF (! cond) GOTO exit_label". */
685 tmp = build1_v (GOTO_EXPR, exit_label);
686 TREE_USED (exit_label) = 1;
687 tmp = build_v (COND_EXPR, cond.expr, tmp, build_empty_stmt ());
688 gfc_add_expr_to_block (&block, tmp);
690 /* The main body of the loop. */
691 tmp = gfc_trans_code (code->block->next);
692 gfc_add_expr_to_block (&block, tmp);
694 /* Label for cycle statements (if needed). */
695 if (TREE_USED (cycle_label))
697 tmp = build1_v (LABEL_EXPR, cycle_label);
698 gfc_add_expr_to_block (&block, tmp);
701 /* End of loop body. */
702 tmp = gfc_finish_block (&block);
704 gfc_init_block (&block);
705 /* Build the loop. */
706 tmp = build_v (LOOP_EXPR, tmp);
707 gfc_add_expr_to_block (&block, tmp);
709 /* Add the exit label. */
710 tmp = build1_v (LABEL_EXPR, exit_label);
711 gfc_add_expr_to_block (&block, tmp);
713 return gfc_finish_block (&block);
717 /* Translate the SELECT CASE construct for INTEGER case expressions,
718 without killing all potential optimizations. The problem is that
719 Fortran allows unbounded cases, but the back-end does not, so we
720 need to intercept those before we enter the equivalent SWITCH_EXPR
723 For example, we translate this,
726 CASE (:100,101,105:115)
736 to the GENERIC equivalent,
740 case (minimum value for typeof(expr) ... 100:
746 case 200 ... (maximum value for typeof(expr):
763 gfc_trans_integer_select (gfc_code * code)
773 gfc_start_block (&block);
775 /* Calculate the switch expression. */
776 gfc_init_se (&se, NULL);
777 gfc_conv_expr_val (&se, code->expr);
778 gfc_add_block_to_block (&block, &se.pre);
780 end_label = gfc_build_label_decl (NULL_TREE);
782 gfc_init_block (&body);
784 for (c = code->block; c; c = c->block)
786 for (cp = c->ext.case_list; cp; cp = cp->next)
791 /* Assume it's the default case. */
792 low = high = NULL_TREE;
796 low = gfc_conv_constant_to_tree (cp->low);
798 /* If there's only a lower bound, set the high bound to the
799 maximum value of the case expression. */
801 high = TYPE_MAX_VALUE (TREE_TYPE (se.expr));
806 /* Three cases are possible here:
808 1) There is no lower bound, e.g. CASE (:N).
809 2) There is a lower bound .NE. high bound, that is
810 a case range, e.g. CASE (N:M) where M>N (we make
811 sure that M>N during type resolution).
812 3) There is a lower bound, and it has the same value
813 as the high bound, e.g. CASE (N:N). This is our
814 internal representation of CASE(N).
816 In the first and second case, we need to set a value for
817 high. In the thirth case, we don't because the GCC middle
818 end represents a single case value by just letting high be
819 a NULL_TREE. We can't do that because we need to be able
820 to represent unbounded cases. */
824 && mpz_cmp (cp->low->value.integer,
825 cp->high->value.integer) != 0))
826 high = gfc_conv_constant_to_tree (cp->high);
828 /* Unbounded case. */
830 low = TYPE_MIN_VALUE (TREE_TYPE (se.expr));
834 label = build_decl (LABEL_DECL, NULL_TREE, NULL_TREE);
835 DECL_CONTEXT (label) = current_function_decl;
837 /* Add this case label.
838 Add parameter 'label', make it match GCC backend. */
839 tmp = build (CASE_LABEL_EXPR, void_type_node, low, high, label);
840 gfc_add_expr_to_block (&body, tmp);
843 /* Add the statements for this case. */
844 tmp = gfc_trans_code (c->next);
845 gfc_add_expr_to_block (&body, tmp);
847 /* Break to the end of the construct. */
848 tmp = build1_v (GOTO_EXPR, end_label);
849 gfc_add_expr_to_block (&body, tmp);
852 tmp = gfc_finish_block (&body);
853 tmp = build_v (SWITCH_EXPR, se.expr, tmp, NULL_TREE);
854 gfc_add_expr_to_block (&block, tmp);
856 tmp = build1_v (LABEL_EXPR, end_label);
857 gfc_add_expr_to_block (&block, tmp);
859 return gfc_finish_block (&block);
863 /* Translate the SELECT CASE construct for LOGICAL case expressions.
865 There are only two cases possible here, even though the standard
866 does allow three cases in a LOGICAL SELECT CASE construct: .TRUE.,
867 .FALSE., and DEFAULT.
869 We never generate more than two blocks here. Instead, we always
870 try to eliminate the DEFAULT case. This way, we can translate this
871 kind of SELECT construct to a simple
875 expression in GENERIC. */
878 gfc_trans_logical_select (gfc_code * code)
886 /* Assume we don't have any cases at all. */
889 /* Now see which ones we actually do have. We can have at most two
890 cases in a single case list: one for .TRUE. and one for .FALSE.
891 The default case is always separate. If the cases for .TRUE. and
892 .FALSE. are in the same case list, the block for that case list
893 always executed, and we don't generate code a COND_EXPR. */
894 for (c = code->block; c; c = c->block)
896 for (cp = c->ext.case_list; cp; cp = cp->next)
900 if (cp->low->value.logical == 0) /* .FALSE. */
902 else /* if (cp->value.logical != 0), thus .TRUE. */
910 /* Start a new block. */
911 gfc_start_block (&block);
913 /* Calculate the switch expression. We always need to do this
914 because it may have side effects. */
915 gfc_init_se (&se, NULL);
916 gfc_conv_expr_val (&se, code->expr);
917 gfc_add_block_to_block (&block, &se.pre);
919 if (t == f && t != NULL)
921 /* Cases for .TRUE. and .FALSE. are in the same block. Just
922 translate the code for these cases, append it to the current
924 gfc_add_expr_to_block (&block, gfc_trans_code (t->next));
928 tree true_tree, false_tree;
930 true_tree = build_empty_stmt ();
931 false_tree = build_empty_stmt ();
933 /* If we have a case for .TRUE. and for .FALSE., discard the default case.
934 Otherwise, if .TRUE. or .FALSE. is missing and there is a default case,
935 make the missing case the default case. */
936 if (t != NULL && f != NULL)
946 /* Translate the code for each of these blocks, and append it to
947 the current block. */
949 true_tree = gfc_trans_code (t->next);
952 false_tree = gfc_trans_code (f->next);
954 gfc_add_expr_to_block (&block, build_v (COND_EXPR, se.expr,
955 true_tree, false_tree));
958 return gfc_finish_block (&block);
962 /* Translate the SELECT CASE construct for CHARACTER case expressions.
963 Instead of generating compares and jumps, it is far simpler to
964 generate a data structure describing the cases in order and call a
965 library subroutine that locates the right case.
966 This is particularly true because this is the only case where we
967 might have to dispose of a temporary.
968 The library subroutine returns a pointer to jump to or NULL if no
969 branches are to be taken. */
972 gfc_trans_character_select (gfc_code *code)
974 tree init, node, end_label, tmp, type, args, *labels;
975 stmtblock_t block, body;
981 static tree select_struct;
982 static tree ss_string1, ss_string1_len;
983 static tree ss_string2, ss_string2_len;
984 static tree ss_target;
986 if (select_struct == NULL)
988 select_struct = make_node (RECORD_TYPE);
989 TYPE_NAME (select_struct) = get_identifier ("_jump_struct");
992 #define ADD_FIELD(NAME, TYPE) \
993 ss_##NAME = gfc_add_field_to_struct \
994 (&(TYPE_FIELDS (select_struct)), select_struct, \
995 get_identifier (stringize(NAME)), TYPE)
997 ADD_FIELD (string1, pchar_type_node);
998 ADD_FIELD (string1_len, gfc_int4_type_node);
1000 ADD_FIELD (string2, pchar_type_node);
1001 ADD_FIELD (string2_len, gfc_int4_type_node);
1003 ADD_FIELD (target, pvoid_type_node);
1006 gfc_finish_type (select_struct);
1009 cp = code->block->ext.case_list;
1010 while (cp->left != NULL)
1014 for (d = cp; d; d = d->right)
1018 labels = gfc_getmem (n * sizeof (tree));
1022 for(i = 0; i < n; i++)
1024 labels[i] = gfc_build_label_decl (NULL_TREE);
1025 TREE_USED (labels[i]) = 1;
1026 /* TODO: The gimplifier should do this for us, but it has
1027 inadequacies when dealing with static initializers. */
1028 FORCED_LABEL (labels[i]) = 1;
1031 end_label = gfc_build_label_decl (NULL_TREE);
1033 /* Generate the body */
1034 gfc_start_block (&block);
1035 gfc_init_block (&body);
1037 for (c = code->block; c; c = c->block)
1039 for (d = c->ext.case_list; d; d = d->next)
1041 tmp = build_v (LABEL_EXPR, labels[d->n]);
1042 gfc_add_expr_to_block (&body, tmp);
1045 tmp = gfc_trans_code (c->next);
1046 gfc_add_expr_to_block (&body, tmp);
1048 tmp = build_v (GOTO_EXPR, end_label);
1049 gfc_add_expr_to_block (&body, tmp);
1052 /* Generate the structure describing the branches */
1056 for(d = cp; d; d = d->right, i++)
1060 gfc_init_se (&se, NULL);
1064 node = tree_cons (ss_string1, null_pointer_node, node);
1065 node = tree_cons (ss_string1_len, integer_zero_node, node);
1069 gfc_conv_expr_reference (&se, d->low);
1071 node = tree_cons (ss_string1, se.expr, node);
1072 node = tree_cons (ss_string1_len, se.string_length, node);
1075 if (d->high == NULL)
1077 node = tree_cons (ss_string2, null_pointer_node, node);
1078 node = tree_cons (ss_string2_len, integer_zero_node, node);
1082 gfc_init_se (&se, NULL);
1083 gfc_conv_expr_reference (&se, d->high);
1085 node = tree_cons (ss_string2, se.expr, node);
1086 node = tree_cons (ss_string2_len, se.string_length, node);
1089 tmp = gfc_build_addr_expr (pvoid_type_node, labels[i]);
1090 node = tree_cons (ss_target, tmp, node);
1092 tmp = build1 (CONSTRUCTOR, select_struct, nreverse (node));
1093 init = tree_cons (NULL_TREE, tmp, init);
1096 type = build_array_type (select_struct,
1097 build_index_type (build_int_2(n - 1, 0)));
1099 init = build1 (CONSTRUCTOR, type, nreverse(init));
1100 TREE_CONSTANT (init) = 1;
1101 TREE_INVARIANT (init) = 1;
1102 TREE_STATIC (init) = 1;
1103 /* Create a static variable to hold the jump table. */
1104 tmp = gfc_create_var (type, "jumptable");
1105 TREE_CONSTANT (tmp) = 1;
1106 TREE_INVARIANT (tmp) = 1;
1107 TREE_STATIC (tmp) = 1;
1108 DECL_INITIAL (tmp) = init;
1111 /* Build an argument list for the library call */
1112 init = gfc_build_addr_expr (pvoid_type_node, init);
1113 args = gfc_chainon_list (NULL_TREE, init);
1115 tmp = build_int_2 (n, 0);
1116 args = gfc_chainon_list (args, tmp);
1118 tmp = gfc_build_addr_expr (pvoid_type_node, end_label);
1119 args = gfc_chainon_list (args, tmp);
1121 gfc_init_se (&se, NULL);
1122 gfc_conv_expr_reference (&se, code->expr);
1124 args = gfc_chainon_list (args, se.expr);
1125 args = gfc_chainon_list (args, se.string_length);
1127 gfc_add_block_to_block (&block, &se.pre);
1129 tmp = gfc_build_function_call (gfor_fndecl_select_string, args);
1130 tmp = build1 (GOTO_EXPR, void_type_node, tmp);
1131 gfc_add_expr_to_block (&block, tmp);
1133 tmp = gfc_finish_block (&body);
1134 gfc_add_expr_to_block (&block, tmp);
1135 tmp = build_v (LABEL_EXPR, end_label);
1136 gfc_add_expr_to_block (&block, tmp);
1141 return gfc_finish_block (&block);
1145 /* Translate the three variants of the SELECT CASE construct.
1147 SELECT CASEs with INTEGER case expressions can be translated to an
1148 equivalent GENERIC switch statement, and for LOGICAL case
1149 expressions we build one or two if-else compares.
1151 SELECT CASEs with CHARACTER case expressions are a whole different
1152 story, because they don't exist in GENERIC. So we sort them and
1153 do a binary search at runtime.
1155 Fortran has no BREAK statement, and it does not allow jumps from
1156 one case block to another. That makes things a lot easier for
1160 gfc_trans_select (gfc_code * code)
1162 assert (code && code->expr);
1164 /* Empty SELECT constructs are legal. */
1165 if (code->block == NULL)
1166 return build_empty_stmt ();
1168 /* Select the correct translation function. */
1169 switch (code->expr->ts.type)
1171 case BT_LOGICAL: return gfc_trans_logical_select (code);
1172 case BT_INTEGER: return gfc_trans_integer_select (code);
1173 case BT_CHARACTER: return gfc_trans_character_select (code);
1175 gfc_internal_error ("gfc_trans_select(): Bad type for case expr.");
1181 /* Generate the loops for a FORALL block. The normal loop format:
1182 count = (end - start + step) / step
1195 gfc_trans_forall_loop (forall_info *forall_tmp, int nvar, tree body, int mask_flag)
1203 tree var, start, end, step, mask, maskindex;
1206 iter = forall_tmp->this_loop;
1207 for (n = 0; n < nvar; n++)
1210 start = iter->start;
1214 exit_label = gfc_build_label_decl (NULL_TREE);
1215 TREE_USED (exit_label) = 1;
1217 /* The loop counter. */
1218 count = gfc_create_var (TREE_TYPE (var), "count");
1220 /* The body of the loop. */
1221 gfc_init_block (&block);
1223 /* The exit condition. */
1224 cond = build (LE_EXPR, boolean_type_node, count, integer_zero_node);
1225 tmp = build1_v (GOTO_EXPR, exit_label);
1226 tmp = build_v (COND_EXPR, cond, tmp, build_empty_stmt ());
1227 gfc_add_expr_to_block (&block, tmp);
1229 /* The main loop body. */
1230 gfc_add_expr_to_block (&block, body);
1232 /* Increment the loop variable. */
1233 tmp = build (PLUS_EXPR, TREE_TYPE (var), var, step);
1234 gfc_add_modify_expr (&block, var, tmp);
1236 /* Advance to the next mask element. */
1239 mask = forall_tmp->mask;
1240 maskindex = forall_tmp->maskindex;
1243 tmp = build (PLUS_EXPR, gfc_array_index_type,
1244 maskindex, gfc_index_one_node);
1245 gfc_add_modify_expr (&block, maskindex, tmp);
1248 /* Decrement the loop counter. */
1249 tmp = build (MINUS_EXPR, TREE_TYPE (var), count, gfc_index_one_node);
1250 gfc_add_modify_expr (&block, count, tmp);
1252 body = gfc_finish_block (&block);
1254 /* Loop var initialization. */
1255 gfc_init_block (&block);
1256 gfc_add_modify_expr (&block, var, start);
1258 /* Initialize the loop counter. */
1259 tmp = fold (build (MINUS_EXPR, TREE_TYPE (var), step, start));
1260 tmp = fold (build (PLUS_EXPR, TREE_TYPE (var), end, tmp));
1261 tmp = fold (build (TRUNC_DIV_EXPR, TREE_TYPE (var), tmp, step));
1262 gfc_add_modify_expr (&block, count, tmp);
1264 /* The loop expression. */
1265 tmp = build_v (LOOP_EXPR, body);
1266 gfc_add_expr_to_block (&block, tmp);
1268 /* The exit label. */
1269 tmp = build1_v (LABEL_EXPR, exit_label);
1270 gfc_add_expr_to_block (&block, tmp);
1272 body = gfc_finish_block (&block);
1279 /* Generate the body and loops according to MASK_FLAG and NEST_FLAG.
1280 if MASK_FLAG is non-zero, the body is controlled by maskes in forall
1281 nest, otherwise, the body is not controlled by maskes.
1282 if NEST_FLAG is non-zero, generate loops for nested forall, otherwise,
1283 only generate loops for the current forall level. */
1286 gfc_trans_nested_forall_loop (forall_info * nested_forall_info, tree body,
1287 int mask_flag, int nest_flag)
1291 forall_info *forall_tmp;
1292 tree pmask, mask, maskindex;
1294 forall_tmp = nested_forall_info;
1295 /* Generate loops for nested forall. */
1298 while (forall_tmp->next_nest != NULL)
1299 forall_tmp = forall_tmp->next_nest;
1300 while (forall_tmp != NULL)
1302 /* Generate body with masks' control. */
1305 pmask = forall_tmp->pmask;
1306 mask = forall_tmp->mask;
1307 maskindex = forall_tmp->maskindex;
1311 /* If a mask was specified make the assignment contitional. */
1313 tmp = gfc_build_indirect_ref (mask);
1316 tmp = gfc_build_array_ref (tmp, maskindex);
1318 body = build_v (COND_EXPR, tmp, body, build_empty_stmt ());
1321 nvar = forall_tmp->nvar;
1322 body = gfc_trans_forall_loop (forall_tmp, nvar, body, mask_flag);
1323 forall_tmp = forall_tmp->outer;
1328 nvar = forall_tmp->nvar;
1329 body = gfc_trans_forall_loop (forall_tmp, nvar, body, mask_flag);
1336 /* Allocate data for holding a temporary array. Returns either a local
1337 temporary array or a pointer variable. */
1340 gfc_do_allocate (tree bytesize, tree size, tree * pdata, stmtblock_t * pblock,
1348 if (INTEGER_CST_P (size))
1350 tmp = fold (build (MINUS_EXPR, gfc_array_index_type, size,
1351 gfc_index_one_node));
1356 type = build_range_type (gfc_array_index_type, gfc_index_zero_node, tmp);
1357 type = build_array_type (elem_type, type);
1358 if (gfc_can_put_var_on_stack (bytesize))
1360 assert (INTEGER_CST_P (size));
1361 tmpvar = gfc_create_var (type, "temp");
1366 tmpvar = gfc_create_var (build_pointer_type (type), "temp");
1367 *pdata = convert (pvoid_type_node, tmpvar);
1369 args = gfc_chainon_list (NULL_TREE, bytesize);
1370 if (gfc_index_integer_kind == 4)
1371 tmp = gfor_fndecl_internal_malloc;
1372 else if (gfc_index_integer_kind == 8)
1373 tmp = gfor_fndecl_internal_malloc64;
1376 tmp = gfc_build_function_call (tmp, args);
1377 tmp = convert (TREE_TYPE (tmpvar), tmp);
1378 gfc_add_modify_expr (pblock, tmpvar, tmp);
1384 /* Generate codes to copy the temporary to the actual lhs. */
1387 generate_loop_for_temp_to_lhs (gfc_expr *expr, tree tmp1, tree size,
1388 tree count3, tree count1, tree count2, tree wheremask)
1392 stmtblock_t block, body;
1399 lss = gfc_walk_expr (expr);
1401 if (lss == gfc_ss_terminator)
1403 gfc_start_block (&block);
1405 gfc_init_se (&lse, NULL);
1407 /* Translate the expression. */
1408 gfc_conv_expr (&lse, expr);
1410 /* Form the expression for the temporary. */
1411 tmp = gfc_build_array_ref (tmp1, count1);
1413 /* Use the scalar assignment as is. */
1414 gfc_add_block_to_block (&block, &lse.pre);
1415 gfc_add_modify_expr (&block, lse.expr, tmp);
1416 gfc_add_block_to_block (&block, &lse.post);
1418 /* Increment the count1. */
1419 tmp = fold (build (PLUS_EXPR, TREE_TYPE (count1), count1, size));
1420 gfc_add_modify_expr (&block, count1, tmp);
1421 tmp = gfc_finish_block (&block);
1425 gfc_start_block (&block);
1427 gfc_init_loopinfo (&loop1);
1428 gfc_init_se (&rse, NULL);
1429 gfc_init_se (&lse, NULL);
1431 /* Associate the lss with the loop. */
1432 gfc_add_ss_to_loop (&loop1, lss);
1434 /* Calculate the bounds of the scalarization. */
1435 gfc_conv_ss_startstride (&loop1);
1436 /* Setup the scalarizing loops. */
1437 gfc_conv_loop_setup (&loop1);
1439 gfc_mark_ss_chain_used (lss, 1);
1440 /* Initialize count2. */
1441 gfc_add_modify_expr (&block, count2, gfc_index_zero_node);
1443 /* Start the scalarized loop body. */
1444 gfc_start_scalarized_body (&loop1, &body);
1446 /* Setup the gfc_se structures. */
1447 gfc_copy_loopinfo_to_se (&lse, &loop1);
1450 /* Form the expression of the temporary. */
1451 if (lss != gfc_ss_terminator)
1453 index = fold (build (PLUS_EXPR, gfc_array_index_type,
1455 rse.expr = gfc_build_array_ref (tmp1, index);
1457 /* Translate expr. */
1458 gfc_conv_expr (&lse, expr);
1460 /* Use the scalar assignment. */
1461 tmp = gfc_trans_scalar_assign (&lse, &rse, expr->ts.type);
1463 /* Form the mask expression according to the mask tree list. */
1468 wheremaskexpr = gfc_build_array_ref (tmp2, count3);
1469 tmp2 = TREE_CHAIN (tmp2);
1472 tmp1 = gfc_build_array_ref (tmp2, count3);
1473 wheremaskexpr = build (TRUTH_AND_EXPR, TREE_TYPE (tmp1),
1474 wheremaskexpr, tmp1);
1475 tmp2 = TREE_CHAIN (tmp2);
1477 tmp = build_v (COND_EXPR, wheremaskexpr, tmp, build_empty_stmt ());
1480 gfc_add_expr_to_block (&body, tmp);
1482 /* Increment count2. */
1483 tmp = fold (build (PLUS_EXPR, gfc_array_index_type,
1484 count2, gfc_index_one_node));
1485 gfc_add_modify_expr (&body, count2, tmp);
1487 /* Increment count3. */
1490 tmp = fold (build (PLUS_EXPR, gfc_array_index_type,
1491 count3, gfc_index_one_node));
1492 gfc_add_modify_expr (&body, count3, tmp);
1495 /* Generate the copying loops. */
1496 gfc_trans_scalarizing_loops (&loop1, &body);
1497 gfc_add_block_to_block (&block, &loop1.pre);
1498 gfc_add_block_to_block (&block, &loop1.post);
1499 gfc_cleanup_loop (&loop1);
1501 /* Increment count1. */
1502 tmp = fold (build (PLUS_EXPR, TREE_TYPE (count1), count1, size));
1503 gfc_add_modify_expr (&block, count1, tmp);
1504 tmp = gfc_finish_block (&block);
1510 /* Generate codes to copy rhs to the temporary. TMP1 is the address of temporary
1511 LSS and RSS are formed in function compute_inner_temp_size(), and should
1515 generate_loop_for_rhs_to_temp (gfc_expr *expr2, tree tmp1, tree size,
1516 tree count3, tree count1, tree count2,
1517 gfc_ss *lss, gfc_ss *rss, tree wheremask)
1519 stmtblock_t block, body1;
1523 tree tmp, tmp2, index;
1526 gfc_start_block (&block);
1528 gfc_init_se (&rse, NULL);
1529 gfc_init_se (&lse, NULL);
1531 if (lss == gfc_ss_terminator)
1533 gfc_init_block (&body1);
1534 gfc_conv_expr (&rse, expr2);
1535 lse.expr = gfc_build_array_ref (tmp1, count1);
1539 /* Initilize count2. */
1540 gfc_add_modify_expr (&block, count2, gfc_index_zero_node);
1542 /* Initiliaze the loop. */
1543 gfc_init_loopinfo (&loop);
1545 /* We may need LSS to determine the shape of the expression. */
1546 gfc_add_ss_to_loop (&loop, lss);
1547 gfc_add_ss_to_loop (&loop, rss);
1549 gfc_conv_ss_startstride (&loop);
1550 gfc_conv_loop_setup (&loop);
1552 gfc_mark_ss_chain_used (rss, 1);
1553 /* Start the loop body. */
1554 gfc_start_scalarized_body (&loop, &body1);
1556 /* Translate the expression. */
1557 gfc_copy_loopinfo_to_se (&rse, &loop);
1559 gfc_conv_expr (&rse, expr2);
1561 /* Form the expression of the temporary. */
1562 index = fold (build (PLUS_EXPR, gfc_array_index_type, count1, count2));
1563 lse.expr = gfc_build_array_ref (tmp1, index);
1566 /* Use the scalar assignment. */
1567 tmp = gfc_trans_scalar_assign (&lse, &rse, expr2->ts.type);
1569 /* Form the mask expression according to the mask tree list. */
1574 wheremaskexpr = gfc_build_array_ref (tmp2, count3);
1575 tmp2 = TREE_CHAIN (tmp2);
1578 tmp1 = gfc_build_array_ref (tmp2, count3);
1579 wheremaskexpr = build (TRUTH_AND_EXPR, TREE_TYPE (tmp1),
1580 wheremaskexpr, tmp1);
1581 tmp2 = TREE_CHAIN (tmp2);
1583 tmp = build_v (COND_EXPR, wheremaskexpr, tmp, build_empty_stmt ());
1586 gfc_add_expr_to_block (&body1, tmp);
1588 if (lss == gfc_ss_terminator)
1590 gfc_add_block_to_block (&block, &body1);
1594 /* Increment count2. */
1595 tmp = fold (build (PLUS_EXPR, gfc_array_index_type,
1596 count2, gfc_index_one_node));
1597 gfc_add_modify_expr (&body1, count2, tmp);
1599 /* Increment count3. */
1602 tmp = fold (build (PLUS_EXPR, gfc_array_index_type,
1603 count3, gfc_index_one_node));
1604 gfc_add_modify_expr (&body1, count3, tmp);
1607 /* Generate the copying loops. */
1608 gfc_trans_scalarizing_loops (&loop, &body1);
1610 gfc_add_block_to_block (&block, &loop.pre);
1611 gfc_add_block_to_block (&block, &loop.post);
1613 gfc_cleanup_loop (&loop);
1614 /* TODO: Reuse lss and rss when copying temp->lhs. Need to be careful
1615 as tree nodes in SS may not be valid in different scope. */
1617 /* Increment count1. */
1618 tmp = fold (build (PLUS_EXPR, TREE_TYPE (count1), count1, size));
1619 gfc_add_modify_expr (&block, count1, tmp);
1621 tmp = gfc_finish_block (&block);
1626 /* Calculate the size of temporary needed in the assignment inside forall.
1627 LSS and RSS are filled in this function. */
1630 compute_inner_temp_size (gfc_expr *expr1, gfc_expr *expr2,
1631 stmtblock_t * pblock,
1632 gfc_ss **lss, gfc_ss **rss)
1639 *lss = gfc_walk_expr (expr1);
1642 size = gfc_index_one_node;
1643 if (*lss != gfc_ss_terminator)
1645 gfc_init_loopinfo (&loop);
1647 /* Walk the RHS of the expression. */
1648 *rss = gfc_walk_expr (expr2);
1649 if (*rss == gfc_ss_terminator)
1651 /* The rhs is scalar. Add a ss for the expression. */
1652 *rss = gfc_get_ss ();
1653 (*rss)->next = gfc_ss_terminator;
1654 (*rss)->type = GFC_SS_SCALAR;
1655 (*rss)->expr = expr2;
1658 /* Associate the SS with the loop. */
1659 gfc_add_ss_to_loop (&loop, *lss);
1660 /* We don't actually need to add the rhs at this point, but it might
1661 make guessing the loop bounds a bit easier. */
1662 gfc_add_ss_to_loop (&loop, *rss);
1664 /* We only want the shape of the expression, not rest of the junk
1665 generated by the scalarizer. */
1666 loop.array_parameter = 1;
1668 /* Calculate the bounds of the scalarization. */
1669 gfc_conv_ss_startstride (&loop);
1670 gfc_conv_loop_setup (&loop);
1672 /* Figure out how many elements we need. */
1673 for (i = 0; i < loop.dimen; i++)
1675 tmp = fold (build (MINUS_EXPR, gfc_array_index_type,
1676 gfc_index_one_node, loop.from[i]));
1677 tmp = fold (build (PLUS_EXPR, gfc_array_index_type,
1679 size = fold (build (MULT_EXPR, gfc_array_index_type, size, tmp));
1681 gfc_add_block_to_block (pblock, &loop.pre);
1682 size = gfc_evaluate_now (size, pblock);
1683 gfc_add_block_to_block (pblock, &loop.post);
1685 /* TODO: write a function that cleans up a loopinfo without freeing
1686 the SS chains. Currently a NOP. */
1693 /* Calculate the overall iterator number of the nested forall construct. */
1696 compute_overall_iter_number (forall_info *nested_forall_info, tree inner_size,
1702 /* TODO: optimizing the computing process. */
1703 number = gfc_create_var (gfc_array_index_type, "num");
1704 gfc_add_modify_expr (block, number, gfc_index_zero_node);
1706 gfc_start_block (&body);
1707 if (nested_forall_info)
1708 tmp = build (PLUS_EXPR, gfc_array_index_type, number,
1712 gfc_add_modify_expr (&body, number, tmp);
1713 tmp = gfc_finish_block (&body);
1715 /* Generate loops. */
1716 if (nested_forall_info != NULL)
1717 tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 0, 1);
1719 gfc_add_expr_to_block (block, tmp);
1725 /* Allocate temporary for forall construct according to the information in
1726 nested_forall_info. INNER_SIZE is the size of temporary needed in the
1727 assignment inside forall. PTEMP1 is returned for space free. */
1730 allocate_temp_for_forall_nest (forall_info * nested_forall_info, tree type,
1731 tree inner_size, stmtblock_t * block,
1737 tree bytesize, size;
1739 /* Calculate the total size of temporary needed in forall construct. */
1740 size = compute_overall_iter_number (nested_forall_info, inner_size, block);
1742 unit = TYPE_SIZE_UNIT (type);
1743 bytesize = fold (build (MULT_EXPR, gfc_array_index_type, size, unit));
1746 temp1 = gfc_do_allocate (bytesize, size, ptemp1, block, type);
1749 tmp = gfc_build_indirect_ref (temp1);
1757 /* Handle assignments inside forall which need temporary. */
1759 gfc_trans_assign_need_temp (gfc_expr * expr1, gfc_expr * expr2, tree wheremask,
1760 forall_info * nested_forall_info,
1761 stmtblock_t * block)
1766 tree count, count1, count2;
1769 tree mask, maskindex;
1770 forall_info *forall_tmp;
1772 /* Create vars. count1 is the current iterator number of the nested forall.
1773 count2 is the current iterator number of the inner loops needed in the
1775 count1 = gfc_create_var (gfc_array_index_type, "count1");
1776 count2 = gfc_create_var (gfc_array_index_type, "count2");
1778 /* Count is the wheremask index. */
1781 count = gfc_create_var (gfc_array_index_type, "count");
1782 gfc_add_modify_expr (block, count, gfc_index_zero_node);
1787 /* Initialize count1. */
1788 gfc_add_modify_expr (block, count1, gfc_index_zero_node);
1790 /* Calculate the size of temporary needed in the assignment. Return loop, lss
1791 and rss which are used in function generate_loop_for_rhs_to_temp(). */
1792 inner_size = compute_inner_temp_size (expr1, expr2, block, &lss, &rss);
1794 /* The type of LHS. Used in function allocate_temp_for_forall_nest */
1795 type = gfc_typenode_for_spec (&expr1->ts);
1797 /* Allocate temporary for nested forall construct according to the
1798 information in nested_forall_info and inner_size. */
1799 tmp1 = allocate_temp_for_forall_nest (nested_forall_info, type,
1800 inner_size, block, &ptemp1);
1802 /* Initialize the maskindexes. */
1803 forall_tmp = nested_forall_info;
1804 while (forall_tmp != NULL)
1806 mask = forall_tmp->mask;
1807 maskindex = forall_tmp->maskindex;
1809 gfc_add_modify_expr (block, maskindex, gfc_index_zero_node);
1810 forall_tmp = forall_tmp->next_nest;
1813 /* Generate codes to copy rhs to the temporary . */
1814 tmp = generate_loop_for_rhs_to_temp (expr2, tmp1, inner_size, count,
1815 count1, count2, lss, rss, wheremask);
1817 /* Generate body and loops according to the inforamtion in
1818 nested_forall_info. */
1819 tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1, 1);
1820 gfc_add_expr_to_block (block, tmp);
1823 gfc_add_modify_expr (block, count1, gfc_index_zero_node);
1825 /* Reset maskindexed. */
1826 forall_tmp = nested_forall_info;
1827 while (forall_tmp != NULL)
1829 mask = forall_tmp->mask;
1830 maskindex = forall_tmp->maskindex;
1832 gfc_add_modify_expr (block, maskindex, gfc_index_zero_node);
1833 forall_tmp = forall_tmp->next_nest;
1838 gfc_add_modify_expr (block, count, gfc_index_zero_node);
1840 /* Generate codes to copy the temporary to lhs. */
1841 tmp = generate_loop_for_temp_to_lhs (expr1, tmp1, inner_size, count,
1842 count1, count2, wheremask);
1844 /* Generate body and loops according to the inforamtion in
1845 nested_forall_info. */
1846 tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1, 1);
1847 gfc_add_expr_to_block (block, tmp);
1851 /* Free the temporary. */
1852 tmp = gfc_chainon_list (NULL_TREE, ptemp1);
1853 tmp = gfc_build_function_call (gfor_fndecl_internal_free, tmp);
1854 gfc_add_expr_to_block (block, tmp);
1859 /* Translate pointer assignment inside FORALL which need temporary. */
1862 gfc_trans_pointer_assign_need_temp (gfc_expr * expr1, gfc_expr * expr2,
1863 forall_info * nested_forall_info,
1864 stmtblock_t * block)
1878 tree tmp, tmp1, ptemp1;
1879 tree mask, maskindex;
1880 forall_info *forall_tmp;
1882 count = gfc_create_var (gfc_array_index_type, "count");
1883 gfc_add_modify_expr (block, count, gfc_index_zero_node);
1885 inner_size = integer_one_node;
1886 lss = gfc_walk_expr (expr1);
1887 rss = gfc_walk_expr (expr2);
1888 if (lss == gfc_ss_terminator)
1890 type = gfc_typenode_for_spec (&expr1->ts);
1891 type = build_pointer_type (type);
1893 /* Allocate temporary for nested forall construct according to the
1894 information in nested_forall_info and inner_size. */
1895 tmp1 = allocate_temp_for_forall_nest (nested_forall_info,
1896 type, inner_size, block, &ptemp1);
1897 gfc_start_block (&body);
1898 gfc_init_se (&lse, NULL);
1899 lse.expr = gfc_build_array_ref (tmp1, count);
1900 gfc_init_se (&rse, NULL);
1901 rse.want_pointer = 1;
1902 gfc_conv_expr (&rse, expr2);
1903 gfc_add_block_to_block (&body, &rse.pre);
1904 gfc_add_modify_expr (&body, lse.expr, rse.expr);
1905 gfc_add_block_to_block (&body, &rse.post);
1907 /* Increment count. */
1908 tmp = fold (build (PLUS_EXPR, gfc_array_index_type,
1909 count, gfc_index_one_node));
1910 gfc_add_modify_expr (&body, count, tmp);
1912 tmp = gfc_finish_block (&body);
1914 /* Initialize the maskindexes. */
1915 forall_tmp = nested_forall_info;
1916 while (forall_tmp != NULL)
1918 mask = forall_tmp->mask;
1919 maskindex = forall_tmp->maskindex;
1921 gfc_add_modify_expr (block, maskindex, gfc_index_zero_node);
1922 forall_tmp = forall_tmp->next_nest;
1925 /* Generate body and loops according to the inforamtion in
1926 nested_forall_info. */
1927 tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1, 1);
1928 gfc_add_expr_to_block (block, tmp);
1931 gfc_add_modify_expr (block, count, gfc_index_zero_node);
1933 /* Reset maskindexes. */
1934 forall_tmp = nested_forall_info;
1935 while (forall_tmp != NULL)
1937 mask = forall_tmp->mask;
1938 maskindex = forall_tmp->maskindex;
1940 gfc_add_modify_expr (block, maskindex, gfc_index_zero_node);
1941 forall_tmp = forall_tmp->next_nest;
1943 gfc_start_block (&body);
1944 gfc_init_se (&lse, NULL);
1945 gfc_init_se (&rse, NULL);
1946 rse.expr = gfc_build_array_ref (tmp1, count);
1947 lse.want_pointer = 1;
1948 gfc_conv_expr (&lse, expr1);
1949 gfc_add_block_to_block (&body, &lse.pre);
1950 gfc_add_modify_expr (&body, lse.expr, rse.expr);
1951 gfc_add_block_to_block (&body, &lse.post);
1952 /* Increment count. */
1953 tmp = fold (build (PLUS_EXPR, gfc_array_index_type,
1954 count, gfc_index_one_node));
1955 gfc_add_modify_expr (&body, count, tmp);
1956 tmp = gfc_finish_block (&body);
1958 /* Generate body and loops according to the inforamtion in
1959 nested_forall_info. */
1960 tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1, 1);
1961 gfc_add_expr_to_block (block, tmp);
1965 gfc_init_loopinfo (&loop);
1967 /* Associate the SS with the loop. */
1968 gfc_add_ss_to_loop (&loop, rss);
1970 /* Setup the scalarizing loops and bounds. */
1971 gfc_conv_ss_startstride (&loop);
1973 gfc_conv_loop_setup (&loop);
1975 info = &rss->data.info;
1976 desc = info->descriptor;
1978 /* Make a new descriptor. */
1979 parmtype = gfc_get_element_type (TREE_TYPE (desc));
1980 parmtype = gfc_get_array_type_bounds (parmtype, loop.dimen,
1981 loop.from, loop.to, 1);
1983 /* Allocate temporary for nested forall construct. */
1984 tmp1 = allocate_temp_for_forall_nest (nested_forall_info, parmtype,
1985 inner_size, block, &ptemp1);
1986 gfc_start_block (&body);
1987 gfc_init_se (&lse, NULL);
1988 lse.expr = gfc_build_array_ref (tmp1, count);
1989 lse.direct_byref = 1;
1990 rss = gfc_walk_expr (expr2);
1991 gfc_conv_expr_descriptor (&lse, expr2, rss);
1993 gfc_add_block_to_block (&body, &lse.pre);
1994 gfc_add_block_to_block (&body, &lse.post);
1996 /* Increment count. */
1997 tmp = fold (build (PLUS_EXPR, gfc_array_index_type,
1998 count, gfc_index_one_node));
1999 gfc_add_modify_expr (&body, count, tmp);
2001 tmp = gfc_finish_block (&body);
2003 /* Initialize the maskindexes. */
2004 forall_tmp = nested_forall_info;
2005 while (forall_tmp != NULL)
2007 mask = forall_tmp->mask;
2008 maskindex = forall_tmp->maskindex;
2010 gfc_add_modify_expr (block, maskindex, gfc_index_zero_node);
2011 forall_tmp = forall_tmp->next_nest;
2014 /* Generate body and loops according to the inforamtion in
2015 nested_forall_info. */
2016 tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1, 1);
2017 gfc_add_expr_to_block (block, tmp);
2020 gfc_add_modify_expr (block, count, gfc_index_zero_node);
2022 /* Reset maskindexes. */
2023 forall_tmp = nested_forall_info;
2024 while (forall_tmp != NULL)
2026 mask = forall_tmp->mask;
2027 maskindex = forall_tmp->maskindex;
2029 gfc_add_modify_expr (block, maskindex, gfc_index_zero_node);
2030 forall_tmp = forall_tmp->next_nest;
2032 parm = gfc_build_array_ref (tmp1, count);
2033 lss = gfc_walk_expr (expr1);
2034 gfc_init_se (&lse, NULL);
2035 gfc_conv_expr_descriptor (&lse, expr1, lss);
2036 gfc_add_modify_expr (&lse.pre, lse.expr, parm);
2037 gfc_start_block (&body);
2038 gfc_add_block_to_block (&body, &lse.pre);
2039 gfc_add_block_to_block (&body, &lse.post);
2041 /* Increment count. */
2042 tmp = fold (build (PLUS_EXPR, gfc_array_index_type,
2043 count, gfc_index_one_node));
2044 gfc_add_modify_expr (&body, count, tmp);
2046 tmp = gfc_finish_block (&body);
2048 tmp = gfc_trans_nested_forall_loop (nested_forall_info, tmp, 1, 1);
2049 gfc_add_expr_to_block (block, tmp);
2051 /* Free the temporary. */
2054 tmp = gfc_chainon_list (NULL_TREE, ptemp1);
2055 tmp = gfc_build_function_call (gfor_fndecl_internal_free, tmp);
2056 gfc_add_expr_to_block (block, tmp);
2061 /* FORALL and WHERE statements are really nasty, especially when you nest
2062 them. All the rhs of a forall assignment must be evaluated before the
2063 actual assignments are performed. Presumably this also applies to all the
2064 assignments in an inner where statement. */
2066 /* Generate code for a FORALL statement. Any temporaries are allocated as a
2067 linear array, relying on the fact that we process in the same order in all
2070 forall (i=start:end:stride; maskexpr)
2074 (where e,f,g,h<i> are arbitary expressions possibly involving i)
2076 count = ((end + 1 - start) / staride)
2077 masktmp(:) = maskexpr(:)
2080 for (i = start; i <= end; i += stride)
2082 if (masktmp[maskindex++])
2086 for (i = start; i <= end; i += stride)
2088 if (masktmp[maskindex++])
2092 Note that this code only works when there are no dependencies.
2093 Forall loop with array assignments and data dependencies are a real pain,
2094 because the size of the temporary cannot always be determined before the
2095 loop is executed. This problem is compouded by the presence of nested
2100 gfc_trans_forall_1 (gfc_code * code, forall_info * nested_forall_info)
2122 gfc_forall_iterator *fa;
2125 gfc_saved_var *saved_vars;
2126 iter_info *this_forall, *iter_tmp;
2127 forall_info *info, *forall_tmp;
2128 temporary_list *temp;
2130 gfc_start_block (&block);
2133 /* Count the FORALL index number. */
2134 for (fa = code->ext.forall_iterator; fa; fa = fa->next)
2138 /* Allocate the space for var, start, end, step, varexpr. */
2139 var = (tree *) gfc_getmem (nvar * sizeof (tree));
2140 start = (tree *) gfc_getmem (nvar * sizeof (tree));
2141 end = (tree *) gfc_getmem (nvar * sizeof (tree));
2142 step = (tree *) gfc_getmem (nvar * sizeof (tree));
2143 varexpr = (gfc_expr **) gfc_getmem (nvar * sizeof (gfc_expr *));
2144 saved_vars = (gfc_saved_var *) gfc_getmem (nvar * sizeof (gfc_saved_var));
2146 /* Allocate the space for info. */
2147 info = (forall_info *) gfc_getmem (sizeof (forall_info));
2149 for (fa = code->ext.forall_iterator; fa; fa = fa->next)
2151 gfc_symbol *sym = fa->var->symtree->n.sym;
2153 /* allocate space for this_forall. */
2154 this_forall = (iter_info *) gfc_getmem (sizeof (iter_info));
2156 /* Create a temporary variable for the FORALL index. */
2157 tmp = gfc_typenode_for_spec (&sym->ts);
2158 var[n] = gfc_create_var (tmp, sym->name);
2159 gfc_shadow_sym (sym, var[n], &saved_vars[n]);
2161 /* Record it in this_forall. */
2162 this_forall->var = var[n];
2164 /* Replace the index symbol's backend_decl with the temporary decl. */
2165 sym->backend_decl = var[n];
2167 /* Work out the start, end and stride for the loop. */
2168 gfc_init_se (&se, NULL);
2169 gfc_conv_expr_val (&se, fa->start);
2170 /* Record it in this_forall. */
2171 this_forall->start = se.expr;
2172 gfc_add_block_to_block (&block, &se.pre);
2175 gfc_init_se (&se, NULL);
2176 gfc_conv_expr_val (&se, fa->end);
2177 /* Record it in this_forall. */
2178 this_forall->end = se.expr;
2179 gfc_make_safe_expr (&se);
2180 gfc_add_block_to_block (&block, &se.pre);
2183 gfc_init_se (&se, NULL);
2184 gfc_conv_expr_val (&se, fa->stride);
2185 /* Record it in this_forall. */
2186 this_forall->step = se.expr;
2187 gfc_make_safe_expr (&se);
2188 gfc_add_block_to_block (&block, &se.pre);
2191 /* Set the NEXT field of this_forall to NULL. */
2192 this_forall->next = NULL;
2193 /* Link this_forall to the info construct. */
2194 if (info->this_loop == NULL)
2195 info->this_loop = this_forall;
2198 iter_tmp = info->this_loop;
2199 while (iter_tmp->next != NULL)
2200 iter_tmp = iter_tmp->next;
2201 iter_tmp->next = this_forall;
2208 /* Work out the number of elements in the mask array. */
2211 size = gfc_index_one_node;
2212 sizevar = NULL_TREE;
2214 for (n = 0; n < nvar; n++)
2216 if (lenvar && TREE_TYPE (lenvar) != TREE_TYPE (start[n]))
2219 /* size = (end + step - start) / step. */
2220 tmp = fold (build (MINUS_EXPR, TREE_TYPE (start[n]), step[n], start[n]));
2221 tmp = fold (build (PLUS_EXPR, TREE_TYPE (end[n]), end[n], tmp));
2223 tmp = fold (build (FLOOR_DIV_EXPR, TREE_TYPE (tmp), tmp, step[n]));
2224 tmp = convert (gfc_array_index_type, tmp);
2226 size = fold (build (MULT_EXPR, gfc_array_index_type, size, tmp));
2229 /* Record the nvar and size of current forall level. */
2233 /* Link the current forall level to nested_forall_info. */
2234 forall_tmp = nested_forall_info;
2235 if (forall_tmp == NULL)
2236 nested_forall_info = info;
2239 while (forall_tmp->next_nest != NULL)
2240 forall_tmp = forall_tmp->next_nest;
2241 info->outer = forall_tmp;
2242 forall_tmp->next_nest = info;
2245 /* Copy the mask into a temporary variable if required.
2246 For now we assume a mask temporary is needed. */
2249 /* Allocate the mask temporary. */
2250 bytesize = fold (build (MULT_EXPR, gfc_array_index_type, size,
2251 TYPE_SIZE_UNIT (boolean_type_node)));
2253 mask = gfc_do_allocate (bytesize, size, &pmask, &block, boolean_type_node);
2255 maskindex = gfc_create_var_np (gfc_array_index_type, "mi");
2256 /* Record them in the info structure. */
2257 info->pmask = pmask;
2259 info->maskindex = maskindex;
2261 gfc_add_modify_expr (&block, maskindex, gfc_index_zero_node);
2263 /* Start of mask assignment loop body. */
2264 gfc_start_block (&body);
2266 /* Evaluate the mask expression. */
2267 gfc_init_se (&se, NULL);
2268 gfc_conv_expr_val (&se, code->expr);
2269 gfc_add_block_to_block (&body, &se.pre);
2271 /* Store the mask. */
2272 se.expr = convert (boolean_type_node, se.expr);
2275 tmp = gfc_build_indirect_ref (mask);
2278 tmp = gfc_build_array_ref (tmp, maskindex);
2279 gfc_add_modify_expr (&body, tmp, se.expr);
2281 /* Advance to the next mask element. */
2282 tmp = build (PLUS_EXPR, gfc_array_index_type,
2283 maskindex, gfc_index_one_node);
2284 gfc_add_modify_expr (&body, maskindex, tmp);
2286 /* Generate the loops. */
2287 tmp = gfc_finish_block (&body);
2288 tmp = gfc_trans_nested_forall_loop (info, tmp, 0, 0);
2289 gfc_add_expr_to_block (&block, tmp);
2293 /* No mask was specified. */
2294 maskindex = NULL_TREE;
2295 mask = pmask = NULL_TREE;
2298 c = code->block->next;
2300 /* TODO: loop merging in FORALL statements. */
2301 /* Now that we've got a copy of the mask, generate the assignment loops. */
2307 /* A scalar or array assingment. */
2308 need_temp = gfc_check_dependency (c->expr, c->expr2, varexpr, nvar);
2309 /* Teporaries due to array assignment data dependencies introduce
2310 no end of problems. */
2312 gfc_trans_assign_need_temp (c->expr, c->expr2, NULL,
2313 nested_forall_info, &block);
2316 /* Use the normal assignment copying routines. */
2317 assign = gfc_trans_assignment (c->expr, c->expr2);
2319 /* Reset the mask index. */
2321 gfc_add_modify_expr (&block, maskindex, gfc_index_zero_node);
2323 /* Generate body and loops. */
2324 tmp = gfc_trans_nested_forall_loop (nested_forall_info, assign, 1, 1);
2325 gfc_add_expr_to_block (&block, tmp);
2332 /* Translate WHERE or WHERE construct nested in FORALL. */
2334 gfc_trans_where_2 (c, NULL, NULL, nested_forall_info, &block, &temp);
2341 /* Free the temporary. */
2342 args = gfc_chainon_list (NULL_TREE, temp->temporary);
2343 tmp = gfc_build_function_call (gfor_fndecl_internal_free, args);
2344 gfc_add_expr_to_block (&block, tmp);
2353 /* Pointer assignment inside FORALL. */
2354 case EXEC_POINTER_ASSIGN:
2355 need_temp = gfc_check_dependency (c->expr, c->expr2, varexpr, nvar);
2357 gfc_trans_pointer_assign_need_temp (c->expr, c->expr2,
2358 nested_forall_info, &block);
2361 /* Use the normal assignment copying routines. */
2362 assign = gfc_trans_pointer_assignment (c->expr, c->expr2);
2364 /* Reset the mask index. */
2366 gfc_add_modify_expr (&block, maskindex, gfc_index_zero_node);
2368 /* Generate body and loops. */
2369 tmp = gfc_trans_nested_forall_loop (nested_forall_info, assign,
2371 gfc_add_expr_to_block (&block, tmp);
2376 tmp = gfc_trans_forall_1 (c, nested_forall_info);
2377 gfc_add_expr_to_block (&block, tmp);
2388 /* Restore the original index variables. */
2389 for (fa = code->ext.forall_iterator, n = 0; fa; fa = fa->next, n++)
2390 gfc_restore_sym (fa->var->symtree->n.sym, &saved_vars[n]);
2392 /* Free the space for var, start, end, step, varexpr. */
2398 gfc_free (saved_vars);
2402 /* Free the temporary for the mask. */
2403 tmp = gfc_chainon_list (NULL_TREE, pmask);
2404 tmp = gfc_build_function_call (gfor_fndecl_internal_free, tmp);
2405 gfc_add_expr_to_block (&block, tmp);
2408 pushdecl (maskindex);
2410 return gfc_finish_block (&block);
2414 /* Translate the FORALL statement or construct. */
2416 tree gfc_trans_forall (gfc_code * code)
2418 return gfc_trans_forall_1 (code, NULL);
2422 /* Evaluate the WHERE mask expression, copy its value to a temporary.
2423 If the WHERE construct is nested in FORALL, compute the overall temporary
2424 needed by the WHERE mask expression multiplied by the iterator number of
2426 ME is the WHERE mask expression.
2427 MASK is the temporary which value is mask's value.
2428 NMASK is another temporary which value is !mask.
2429 TEMP records the temporary's address allocated in this function in order to
2430 free them outside this function.
2431 MASK, NMASK and TEMP are all OUT arguments. */
2434 gfc_evaluate_where_mask (gfc_expr * me, forall_info * nested_forall_info,
2435 tree * mask, tree * nmask, temporary_list ** temp,
2436 stmtblock_t * block)
2441 tree ptemp1, ntmp, ptemp2;
2443 stmtblock_t body, body1;
2448 gfc_init_loopinfo (&loop);
2450 /* Calculate the size of temporary needed by the mask-expr. */
2451 inner_size = compute_inner_temp_size (me, me, block, &lss, &rss);
2453 /* Allocate temporary for where mask. */
2454 tmp = allocate_temp_for_forall_nest (nested_forall_info, boolean_type_node,
2455 inner_size, block, &ptemp1);
2456 /* Record the temporary address in order to free it later. */
2459 temporary_list *tempo;
2460 tempo = (temporary_list *) gfc_getmem (sizeof (temporary_list));
2461 tempo->temporary = ptemp1;
2462 tempo->next = *temp;
2466 /* Allocate temporary for !mask. */
2467 ntmp = allocate_temp_for_forall_nest (nested_forall_info, boolean_type_node,
2468 inner_size, block, &ptemp2);
2469 /* Record the temporary in order to free it later. */
2472 temporary_list *tempo;
2473 tempo = (temporary_list *) gfc_getmem (sizeof (temporary_list));
2474 tempo->temporary = ptemp2;
2475 tempo->next = *temp;
2479 /* Variable to index the temporary. */
2480 count = gfc_create_var (gfc_array_index_type, "count");
2481 /* Initilize count. */
2482 gfc_add_modify_expr (block, count, gfc_index_zero_node);
2484 gfc_start_block (&body);
2486 gfc_init_se (&rse, NULL);
2487 gfc_init_se (&lse, NULL);
2489 if (lss == gfc_ss_terminator)
2491 gfc_init_block (&body1);
2495 /* Initiliaze the loop. */
2496 gfc_init_loopinfo (&loop);
2498 /* We may need LSS to determine the shape of the expression. */
2499 gfc_add_ss_to_loop (&loop, lss);
2500 gfc_add_ss_to_loop (&loop, rss);
2502 gfc_conv_ss_startstride (&loop);
2503 gfc_conv_loop_setup (&loop);
2505 gfc_mark_ss_chain_used (rss, 1);
2506 /* Start the loop body. */
2507 gfc_start_scalarized_body (&loop, &body1);
2509 /* Translate the expression. */
2510 gfc_copy_loopinfo_to_se (&rse, &loop);
2512 gfc_conv_expr (&rse, me);
2514 /* Form the expression of the temporary. */
2515 lse.expr = gfc_build_array_ref (tmp, count);
2516 tmpexpr = gfc_build_array_ref (ntmp, count);
2518 /* Use the scalar assignment to fill temporary TMP. */
2519 tmp1 = gfc_trans_scalar_assign (&lse, &rse, me->ts.type);
2520 gfc_add_expr_to_block (&body1, tmp1);
2522 /* Fill temporary NTMP. */
2523 tmp1 = build1 (TRUTH_NOT_EXPR, TREE_TYPE (lse.expr), lse.expr);
2524 gfc_add_modify_expr (&body1, tmpexpr, tmp1);
2526 if (lss == gfc_ss_terminator)
2528 gfc_add_block_to_block (&body, &body1);
2532 /* Increment count. */
2533 tmp1 = fold (build (PLUS_EXPR, gfc_array_index_type, count,
2534 gfc_index_one_node));
2535 gfc_add_modify_expr (&body1, count, tmp1);
2537 /* Generate the copying loops. */
2538 gfc_trans_scalarizing_loops (&loop, &body1);
2540 gfc_add_block_to_block (&body, &loop.pre);
2541 gfc_add_block_to_block (&body, &loop.post);
2543 gfc_cleanup_loop (&loop);
2544 /* TODO: Reuse lss and rss when copying temp->lhs. Need to be careful
2545 as tree nodes in SS may not be valid in different scope. */
2548 tmp1 = gfc_finish_block (&body);
2549 /* If the WHERE construct is inside FORALL, fill the full temporary. */
2550 if (nested_forall_info != NULL)
2551 tmp1 = gfc_trans_nested_forall_loop (nested_forall_info, tmp1, 1, 1);
2554 gfc_add_expr_to_block (block, tmp1);
2563 /* Translate an assignment statement in a WHERE statement or construct
2564 statement. The MASK expression is used to control which elements
2565 of EXPR1 shall be assigned. */
2568 gfc_trans_where_assign (gfc_expr *expr1, gfc_expr *expr2, tree mask,
2569 tree count1, tree count2)
2574 gfc_ss *lss_section;
2581 tree index, maskexpr, tmp1;
2584 /* TODO: handle this special case.
2585 Special case a single function returning an array. */
2586 if (expr2->expr_type == EXPR_FUNCTION && expr2->rank > 0)
2588 tmp = gfc_trans_arrayfunc_assign (expr1, expr2);
2594 /* Assignment of the form lhs = rhs. */
2595 gfc_start_block (&block);
2597 gfc_init_se (&lse, NULL);
2598 gfc_init_se (&rse, NULL);
2601 lss = gfc_walk_expr (expr1);
2604 /* In each where-assign-stmt, the mask-expr and the variable being
2605 defined shall be arrays of the same shape. */
2606 assert (lss != gfc_ss_terminator);
2608 /* The assignment needs scalarization. */
2611 /* Find a non-scalar SS from the lhs. */
2612 while (lss_section != gfc_ss_terminator
2613 && lss_section->type != GFC_SS_SECTION)
2614 lss_section = lss_section->next;
2616 assert (lss_section != gfc_ss_terminator);
2618 /* Initialize the scalarizer. */
2619 gfc_init_loopinfo (&loop);
2622 rss = gfc_walk_expr (expr2);
2623 if (rss == gfc_ss_terminator)
2625 /* The rhs is scalar. Add a ss for the expression. */
2626 rss = gfc_get_ss ();
2627 rss->next = gfc_ss_terminator;
2628 rss->type = GFC_SS_SCALAR;
2632 /* Associate the SS with the loop. */
2633 gfc_add_ss_to_loop (&loop, lss);
2634 gfc_add_ss_to_loop (&loop, rss);
2636 /* Calculate the bounds of the scalarization. */
2637 gfc_conv_ss_startstride (&loop);
2639 /* Resolve any data dependencies in the statement. */
2640 gfc_conv_resolve_dependencies (&loop, lss_section, rss);
2642 /* Setup the scalarizing loops. */
2643 gfc_conv_loop_setup (&loop);
2645 /* Setup the gfc_se structures. */
2646 gfc_copy_loopinfo_to_se (&lse, &loop);
2647 gfc_copy_loopinfo_to_se (&rse, &loop);
2650 gfc_mark_ss_chain_used (rss, 1);
2651 if (loop.temp_ss == NULL)
2654 gfc_mark_ss_chain_used (lss, 1);
2658 lse.ss = loop.temp_ss;
2659 gfc_mark_ss_chain_used (lss, 3);
2660 gfc_mark_ss_chain_used (loop.temp_ss, 3);
2663 /* Start the scalarized loop body. */
2664 gfc_start_scalarized_body (&loop, &body);
2666 /* Translate the expression. */
2667 gfc_conv_expr (&rse, expr2);
2668 if (lss != gfc_ss_terminator && loop.temp_ss != NULL)
2670 gfc_conv_tmp_array_ref (&lse);
2671 gfc_advance_se_ss_chain (&lse);
2674 gfc_conv_expr (&lse, expr1);
2676 /* Form the mask expression according to the mask tree list. */
2680 maskexpr = gfc_build_array_ref (tmp, index);
2684 tmp = TREE_CHAIN (tmp);
2687 tmp1 = gfc_build_array_ref (tmp, index);
2688 maskexpr = build (TRUTH_AND_EXPR, TREE_TYPE (tmp1), maskexpr, tmp1);
2689 tmp = TREE_CHAIN (tmp);
2691 /* Use the scalar assignment as is. */
2692 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts.type);
2693 tmp = build_v (COND_EXPR, maskexpr, tmp, build_empty_stmt ());
2695 gfc_add_expr_to_block (&body, tmp);
2697 if (lss == gfc_ss_terminator)
2699 /* Increment count1. */
2700 tmp = fold (build (PLUS_EXPR, gfc_array_index_type,
2701 count1, gfc_index_one_node));
2702 gfc_add_modify_expr (&body, count1, tmp);
2704 /* Use the scalar assignment as is. */
2705 gfc_add_block_to_block (&block, &body);
2709 if (lse.ss != gfc_ss_terminator)
2711 if (rse.ss != gfc_ss_terminator)
2714 if (loop.temp_ss != NULL)
2716 /* Increment count1 before finish the main body of a scalarized
2718 tmp = fold (build (PLUS_EXPR, gfc_array_index_type,
2719 count1, gfc_index_one_node));
2720 gfc_add_modify_expr (&body, count1, tmp);
2721 gfc_trans_scalarized_loop_boundary (&loop, &body);
2723 /* We need to copy the temporary to the actual lhs. */
2724 gfc_init_se (&lse, NULL);
2725 gfc_init_se (&rse, NULL);
2726 gfc_copy_loopinfo_to_se (&lse, &loop);
2727 gfc_copy_loopinfo_to_se (&rse, &loop);
2729 rse.ss = loop.temp_ss;
2732 gfc_conv_tmp_array_ref (&rse);
2733 gfc_advance_se_ss_chain (&rse);
2734 gfc_conv_expr (&lse, expr1);
2736 if (lse.ss != gfc_ss_terminator)
2739 if (rse.ss != gfc_ss_terminator)
2742 /* Form the mask expression according to the mask tree list. */
2746 maskexpr = gfc_build_array_ref (tmp, index);
2750 tmp = TREE_CHAIN (tmp);
2753 tmp1 = gfc_build_array_ref (tmp, index);
2754 maskexpr = build (TRUTH_AND_EXPR, TREE_TYPE (tmp1), maskexpr,
2756 tmp = TREE_CHAIN (tmp);
2758 /* Use the scalar assignment as is. */
2759 tmp = gfc_trans_scalar_assign (&lse, &rse, expr1->ts.type);
2760 tmp = build_v (COND_EXPR, maskexpr, tmp, build_empty_stmt ());
2761 gfc_add_expr_to_block (&body, tmp);
2763 /* Increment count2. */
2764 tmp = fold (build (PLUS_EXPR, gfc_array_index_type,
2765 count2, gfc_index_one_node));
2766 gfc_add_modify_expr (&body, count2, tmp);
2770 /* Increment count1. */
2771 tmp = fold (build (PLUS_EXPR, gfc_array_index_type,
2772 count1, gfc_index_one_node));
2773 gfc_add_modify_expr (&body, count1, tmp);
2776 /* Generate the copying loops. */
2777 gfc_trans_scalarizing_loops (&loop, &body);
2779 /* Wrap the whole thing up. */
2780 gfc_add_block_to_block (&block, &loop.pre);
2781 gfc_add_block_to_block (&block, &loop.post);
2782 gfc_cleanup_loop (&loop);
2785 return gfc_finish_block (&block);
2789 /* Translate the WHERE construct or statement.
2790 This fuction can be called iteratelly to translate the nested WHERE
2791 construct or statement.
2792 MASK is the control mask, and PMASK is the pending control mask.
2793 TEMP records the temporary address which must be freed later. */
2796 gfc_trans_where_2 (gfc_code * code, tree mask, tree pmask,
2797 forall_info * nested_forall_info, stmtblock_t * block,
2798 temporary_list ** temp)
2804 tree tmp, tmp1, tmp2;
2805 tree count1, count2;
2809 /* the WHERE statement or the WHERE construct statement. */
2810 cblock = code->block;
2813 /* Has mask-expr. */
2816 /* Ensure that the WHERE mask be evaluated only once. */
2817 tmp2 = gfc_evaluate_where_mask (cblock->expr, nested_forall_info,
2818 &tmp, &tmp1, temp, block);
2820 /* Set the control mask and the pending control mask. */
2821 /* It's a where-stmt. */
2827 /* It's a nested where-stmt. */
2828 else if (mask && pmask == NULL)
2831 /* Use the TREE_CHAIN to list the masks. */
2832 tmp2 = copy_list (mask);
2833 pmask = chainon (mask, tmp1);
2834 mask = chainon (tmp2, tmp);
2836 /* It's a masked-elsewhere-stmt. */
2837 else if (mask && cblock->expr)
2840 tmp2 = copy_list (pmask);
2843 tmp2 = chainon (tmp2, tmp);
2844 pmask = chainon (mask, tmp1);
2848 /* It's a elsewhere-stmt. No mask-expr is present. */
2852 /* Get the assignment statement of a WHERE statement, or the first
2853 statement in where-body-construct of a WHERE construct. */
2854 cnext = cblock->next;
2859 /* WHERE assignment statement. */
2861 expr1 = cnext->expr;
2862 expr2 = cnext->expr2;
2863 if (nested_forall_info != NULL)
2868 nvar = nested_forall_info->nvar;
2869 varexpr = (gfc_expr **)
2870 gfc_getmem (nvar * sizeof (gfc_expr *));
2871 need_temp = gfc_check_dependency (expr1, expr2, varexpr,
2874 gfc_trans_assign_need_temp (expr1, expr2, mask,
2875 nested_forall_info, block);
2878 /* Variables to control maskexpr. */
2879 count1 = gfc_create_var (gfc_array_index_type, "count1");
2880 count2 = gfc_create_var (gfc_array_index_type, "count2");
2881 gfc_add_modify_expr (block, count1, gfc_index_zero_node);
2882 gfc_add_modify_expr (block, count2, gfc_index_zero_node);
2884 tmp = gfc_trans_where_assign (expr1, expr2, mask, count1,
2886 tmp = gfc_trans_nested_forall_loop (nested_forall_info,
2888 gfc_add_expr_to_block (block, tmp);
2893 /* Variables to control maskexpr. */
2894 count1 = gfc_create_var (gfc_array_index_type, "count1");
2895 count2 = gfc_create_var (gfc_array_index_type, "count2");
2896 gfc_add_modify_expr (block, count1, gfc_index_zero_node);
2897 gfc_add_modify_expr (block, count2, gfc_index_zero_node);
2899 tmp = gfc_trans_where_assign (expr1, expr2, mask, count1,
2901 gfc_add_expr_to_block (block, tmp);
2906 /* WHERE or WHERE construct is part of a where-body-construct. */
2908 /* Ensure that MASK is not modified by next gfc_trans_where_2. */
2909 mask_copy = copy_list (mask);
2910 gfc_trans_where_2 (cnext, mask_copy, NULL, nested_forall_info,
2918 /* The next statement within the same where-body-construct. */
2919 cnext = cnext->next;
2921 /* The next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt. */
2922 cblock = cblock->block;
2927 /* As the WHERE or WHERE construct statement can be nested, we call
2928 gfc_trans_where_2 to do the translation, and pass the initial
2929 NULL values for both the control mask and the pending control mask. */
2932 gfc_trans_where (gfc_code * code)
2935 temporary_list *temp, *p;
2939 gfc_start_block (&block);
2942 gfc_trans_where_2 (code, NULL, NULL, NULL, &block, &temp);
2944 /* Add calls to free temporaries which were dynamically allocated. */
2947 args = gfc_chainon_list (NULL_TREE, temp->temporary);
2948 tmp = gfc_build_function_call (gfor_fndecl_internal_free, args);
2949 gfc_add_expr_to_block (&block, tmp);
2955 return gfc_finish_block (&block);
2959 /* CYCLE a DO loop. The label decl has already been created by
2960 gfc_trans_do(), it's in TREE_PURPOSE (backend_decl) of the gfc_code
2961 node at the head of the loop. We must mark the label as used. */
2964 gfc_trans_cycle (gfc_code * code)
2968 cycle_label = TREE_PURPOSE (code->ext.whichloop->backend_decl);
2969 TREE_USED (cycle_label) = 1;
2970 return build1_v (GOTO_EXPR, cycle_label);
2974 /* EXIT a DO loop. Similair to CYCLE, but now the label is in
2975 TREE_VALUE (backend_decl) of the gfc_code node at the head of the
2979 gfc_trans_exit (gfc_code * code)
2983 exit_label = TREE_VALUE (code->ext.whichloop->backend_decl);
2984 TREE_USED (exit_label) = 1;
2985 return build1_v (GOTO_EXPR, exit_label);
2989 /* Translate the ALLOCATE statement. */
2992 gfc_trans_allocate (gfc_code * code)
3005 if (!code->ext.alloc_list)
3008 gfc_start_block (&block);
3012 stat = gfc_create_var (gfc_int4_type_node, "stat");
3013 pstat = gfc_build_addr_expr (NULL, stat);
3015 error_label = gfc_build_label_decl (NULL_TREE);
3016 TREE_USED (error_label) = 1;
3020 pstat = integer_zero_node;
3021 stat = error_label = NULL_TREE;
3025 for (al = code->ext.alloc_list; al != NULL; al = al->next)
3029 gfc_init_se (&se, NULL);
3030 gfc_start_block (&se.pre);
3032 se.want_pointer = 1;
3033 se.descriptor_only = 1;
3034 gfc_conv_expr (&se, expr);
3038 /* Find the last reference in the chain. */
3039 while (ref && ref->next != NULL)
3041 assert (ref->type != REF_ARRAY || ref->u.ar.type == AR_ELEMENT);
3045 if (ref != NULL && ref->type == REF_ARRAY)
3048 gfc_array_allocate (&se, ref, pstat);
3052 /* A scalar or derived type. */
3055 val = gfc_create_var (ppvoid_type_node, "ptr");
3056 tmp = gfc_build_addr_expr (ppvoid_type_node, se.expr);
3057 gfc_add_modify_expr (&se.pre, val, tmp);
3059 tmp = TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (se.expr)));
3060 parm = gfc_chainon_list (NULL_TREE, val);
3061 parm = gfc_chainon_list (parm, tmp);
3062 parm = gfc_chainon_list (parm, pstat);
3063 tmp = gfc_build_function_call (gfor_fndecl_allocate, parm);
3064 gfc_add_expr_to_block (&se.pre, tmp);
3068 tmp = build1_v (GOTO_EXPR, error_label);
3070 build (NE_EXPR, boolean_type_node, stat, integer_zero_node);
3071 tmp = build_v (COND_EXPR, parm, tmp, build_empty_stmt ());
3072 gfc_add_expr_to_block (&se.pre, tmp);
3076 tmp = gfc_finish_block (&se.pre);
3077 gfc_add_expr_to_block (&block, tmp);
3080 /* Assign the value to the status variable. */
3083 tmp = build1_v (LABEL_EXPR, error_label);
3084 gfc_add_expr_to_block (&block, tmp);
3086 gfc_init_se (&se, NULL);
3087 gfc_conv_expr_lhs (&se, code->expr);
3088 tmp = convert (TREE_TYPE (se.expr), stat);
3089 gfc_add_modify_expr (&block, se.expr, tmp);
3092 return gfc_finish_block (&block);
3097 gfc_trans_deallocate (gfc_code * code)
3107 gfc_start_block (&block);
3109 for (al = code->ext.alloc_list; al != NULL; al = al->next)
3112 assert (expr->expr_type == EXPR_VARIABLE);
3114 gfc_init_se (&se, NULL);
3115 gfc_start_block (&se.pre);
3117 se.want_pointer = 1;
3118 se.descriptor_only = 1;
3119 gfc_conv_expr (&se, expr);
3121 if (expr->symtree->n.sym->attr.dimension)
3123 tmp = gfc_array_deallocate (se.expr);
3124 gfc_add_expr_to_block (&se.pre, tmp);
3128 type = build_pointer_type (TREE_TYPE (se.expr));
3129 var = gfc_create_var (type, "ptr");
3130 tmp = gfc_build_addr_expr (type, se.expr);
3131 gfc_add_modify_expr (&se.pre, var, tmp);
3133 tmp = gfc_chainon_list (NULL_TREE, var);
3134 tmp = gfc_chainon_list (tmp, integer_zero_node);
3135 tmp = gfc_build_function_call (gfor_fndecl_deallocate, tmp);
3136 gfc_add_expr_to_block (&se.pre, tmp);
3138 tmp = gfc_finish_block (&se.pre);
3139 gfc_add_expr_to_block (&block, tmp);
3142 return gfc_finish_block (&block);