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
);
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
= build2 (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
= build2 (EQ_EXPR
, boolean_type_node
, tmp
, assigned_goto
);
172 tmp
= build3_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 an ENTRY statement. Just adds a label for this entry point. */
184 gfc_trans_entry (gfc_code
* code
)
186 return build1_v (LABEL_EXPR
, code
->ext
.entry
->label
);
190 /* Translate the CALL statement. Builds a call to an F95 subroutine. */
193 gfc_trans_call (gfc_code
* code
)
197 /* A CALL starts a new block because the actual arguments may have to
198 be evaluated first. */
199 gfc_init_se (&se
, NULL
);
200 gfc_start_block (&se
.pre
);
202 assert (code
->resolved_sym
);
203 has_alternate_specifier
= 0;
205 /* Translate the call. */
206 gfc_conv_function_call (&se
, code
->resolved_sym
, code
->ext
.actual
);
208 /* A subroutine without side-effect, by definition, does nothing! */
209 TREE_SIDE_EFFECTS (se
.expr
) = 1;
211 /* Chain the pieces together and return the block. */
212 if (has_alternate_specifier
)
214 gfc_code
*select_code
;
216 select_code
= code
->next
;
217 assert(select_code
->op
== EXEC_SELECT
);
218 sym
= select_code
->expr
->symtree
->n
.sym
;
219 se
.expr
= convert (gfc_typenode_for_spec (&sym
->ts
), se
.expr
);
220 gfc_add_modify_expr (&se
.pre
, sym
->backend_decl
, se
.expr
);
223 gfc_add_expr_to_block (&se
.pre
, se
.expr
);
225 gfc_add_block_to_block (&se
.pre
, &se
.post
);
226 return gfc_finish_block (&se
.pre
);
230 /* Translate the RETURN statement. */
233 gfc_trans_return (gfc_code
* code ATTRIBUTE_UNUSED
)
241 /* if code->expr is not NULL, this return statement must appear
242 in a subroutine and current_fake_result_decl has already
245 result
= gfc_get_fake_result_decl (NULL
);
248 gfc_warning ("An alternate return at %L without a * dummy argument",
250 return build1_v (GOTO_EXPR
, gfc_get_return_label ());
253 /* Start a new block for this statement. */
254 gfc_init_se (&se
, NULL
);
255 gfc_start_block (&se
.pre
);
257 gfc_conv_expr (&se
, code
->expr
);
259 tmp
= build2 (MODIFY_EXPR
, TREE_TYPE (result
), result
, se
.expr
);
260 gfc_add_expr_to_block (&se
.pre
, tmp
);
262 tmp
= build1_v (GOTO_EXPR
, gfc_get_return_label ());
263 gfc_add_expr_to_block (&se
.pre
, tmp
);
264 gfc_add_block_to_block (&se
.pre
, &se
.post
);
265 return gfc_finish_block (&se
.pre
);
268 return build1_v (GOTO_EXPR
, gfc_get_return_label ());
272 /* Translate the PAUSE statement. We have to translate this statement
273 to a runtime library call. */
276 gfc_trans_pause (gfc_code
* code
)
283 /* Start a new block for this statement. */
284 gfc_init_se (&se
, NULL
);
285 gfc_start_block (&se
.pre
);
288 if (code
->expr
== NULL
)
290 tmp
= build_int_cst (gfc_int4_type_node
, code
->ext
.stop_code
);
291 args
= gfc_chainon_list (NULL_TREE
, tmp
);
292 fndecl
= gfor_fndecl_pause_numeric
;
296 gfc_conv_expr_reference (&se
, code
->expr
);
297 args
= gfc_chainon_list (NULL_TREE
, se
.expr
);
298 args
= gfc_chainon_list (args
, se
.string_length
);
299 fndecl
= gfor_fndecl_pause_string
;
302 tmp
= gfc_build_function_call (fndecl
, args
);
303 gfc_add_expr_to_block (&se
.pre
, tmp
);
305 gfc_add_block_to_block (&se
.pre
, &se
.post
);
307 return gfc_finish_block (&se
.pre
);
311 /* Translate the STOP statement. We have to translate this statement
312 to a runtime library call. */
315 gfc_trans_stop (gfc_code
* code
)
322 /* Start a new block for this statement. */
323 gfc_init_se (&se
, NULL
);
324 gfc_start_block (&se
.pre
);
327 if (code
->expr
== NULL
)
329 tmp
= build_int_cst (gfc_int4_type_node
, code
->ext
.stop_code
);
330 args
= gfc_chainon_list (NULL_TREE
, tmp
);
331 fndecl
= gfor_fndecl_stop_numeric
;
335 gfc_conv_expr_reference (&se
, code
->expr
);
336 args
= gfc_chainon_list (NULL_TREE
, se
.expr
);
337 args
= gfc_chainon_list (args
, se
.string_length
);
338 fndecl
= gfor_fndecl_stop_string
;
341 tmp
= gfc_build_function_call (fndecl
, args
);
342 gfc_add_expr_to_block (&se
.pre
, tmp
);
344 gfc_add_block_to_block (&se
.pre
, &se
.post
);
346 return gfc_finish_block (&se
.pre
);
350 /* Generate GENERIC for the IF construct. This function also deals with
351 the simple IF statement, because the front end translates the IF
352 statement into an IF construct.
384 where COND_S is the simplified version of the predicate. PRE_COND_S
385 are the pre side-effects produced by the translation of the
387 We need to build the chain recursively otherwise we run into
388 problems with folding incomplete statements. */
391 gfc_trans_if_1 (gfc_code
* code
)
396 /* Check for an unconditional ELSE clause. */
398 return gfc_trans_code (code
->next
);
400 /* Initialize a statement builder for each block. Puts in NULL_TREEs. */
401 gfc_init_se (&if_se
, NULL
);
402 gfc_start_block (&if_se
.pre
);
404 /* Calculate the IF condition expression. */
405 gfc_conv_expr_val (&if_se
, code
->expr
);
407 /* Translate the THEN clause. */
408 stmt
= gfc_trans_code (code
->next
);
410 /* Translate the ELSE clause. */
412 elsestmt
= gfc_trans_if_1 (code
->block
);
414 elsestmt
= build_empty_stmt ();
416 /* Build the condition expression and add it to the condition block. */
417 stmt
= build3_v (COND_EXPR
, if_se
.expr
, stmt
, elsestmt
);
419 gfc_add_expr_to_block (&if_se
.pre
, stmt
);
421 /* Finish off this statement. */
422 return gfc_finish_block (&if_se
.pre
);
426 gfc_trans_if (gfc_code
* code
)
428 /* Ignore the top EXEC_IF, it only announces an IF construct. The
429 actual code we must translate is in code->block. */
431 return gfc_trans_if_1 (code
->block
);
435 /* Translage an arithmetic IF expression.
437 IF (cond) label1, label2, label3 translates to
451 gfc_trans_arithmetic_if (gfc_code
* code
)
459 /* Start a new block. */
460 gfc_init_se (&se
, NULL
);
461 gfc_start_block (&se
.pre
);
463 /* Pre-evaluate COND. */
464 gfc_conv_expr_val (&se
, code
->expr
);
466 /* Build something to compare with. */
467 zero
= gfc_build_const (TREE_TYPE (se
.expr
), integer_zero_node
);
469 /* If (cond < 0) take branch1 else take branch2.
470 First build jumps to the COND .LT. 0 and the COND .EQ. 0 cases. */
471 branch1
= build1_v (GOTO_EXPR
, gfc_get_label_decl (code
->label
));
472 branch2
= build1_v (GOTO_EXPR
, gfc_get_label_decl (code
->label2
));
474 tmp
= build2 (LT_EXPR
, boolean_type_node
, se
.expr
, zero
);
475 branch1
= build3_v (COND_EXPR
, tmp
, branch1
, branch2
);
477 /* if (cond <= 0) take branch1 else take branch2. */
478 branch2
= build1_v (GOTO_EXPR
, gfc_get_label_decl (code
->label3
));
479 tmp
= build2 (LE_EXPR
, boolean_type_node
, se
.expr
, zero
);
480 branch1
= build3_v (COND_EXPR
, tmp
, branch1
, branch2
);
482 /* Append the COND_EXPR to the evaluation of COND, and return. */
483 gfc_add_expr_to_block (&se
.pre
, branch1
);
484 return gfc_finish_block (&se
.pre
);
488 /* Translate the DO construct. This obviously is one of the most
489 important ones to get right with any compiler, but especially
492 Currently we calculate the loop count before entering the loop, but
493 it may be possible to optimize if step is a constant. The main
494 advantage is that the loop test is a single GENERIC node
496 We translate a do loop from:
498 DO dovar = from, to, step
508 temp1=to_expr-from_expr;
510 range_temp=step_tmp/range_temp;
511 for ( ; range_temp > 0 ; range_temp = range_temp - 1)
516 dovar=dovar_temp + step_temp;
520 Some optimization is done for empty do loops. We can't just let
521 dovar=to because it's possible for from+range*loopcount!=to. Anyone
522 who writes empty DO deserves sub-optimal (but correct) code anyway.
524 TODO: Large loop counts
525 Does not work loop counts which do not fit into a signed integer kind,
526 ie. Does not work for loop counts > 2^31 for integer(kind=4) variables
527 We must support the full range. */
530 gfc_trans_do (gfc_code
* code
)
546 gfc_start_block (&block
);
548 /* Create GIMPLE versions of all expressions in the iterator. */
550 gfc_init_se (&se
, NULL
);
551 gfc_conv_expr_lhs (&se
, code
->ext
.iterator
->var
);
552 gfc_add_block_to_block (&block
, &se
.pre
);
554 type
= TREE_TYPE (dovar
);
556 gfc_init_se (&se
, NULL
);
557 gfc_conv_expr_type (&se
, code
->ext
.iterator
->start
, type
);
558 gfc_add_block_to_block (&block
, &se
.pre
);
561 gfc_init_se (&se
, NULL
);
562 gfc_conv_expr_type (&se
, code
->ext
.iterator
->end
, type
);
563 gfc_add_block_to_block (&block
, &se
.pre
);
566 gfc_init_se (&se
, NULL
);
567 gfc_conv_expr_type (&se
, code
->ext
.iterator
->step
, type
);
569 /* We don't want this changing part way through. */
570 gfc_make_safe_expr (&se
);
571 gfc_add_block_to_block (&block
, &se
.pre
);
574 /* Initialise loop count. This code is executed before we enter the
575 loop body. We generate: count = (to + step - from) / step. */
577 tmp
= fold (build2 (MINUS_EXPR
, type
, step
, from
));
578 tmp
= fold (build2 (PLUS_EXPR
, type
, to
, tmp
));
579 tmp
= fold (build2 (TRUNC_DIV_EXPR
, type
, tmp
, step
));
581 count
= gfc_create_var (type
, "count");
582 gfc_add_modify_expr (&block
, count
, tmp
);
584 /* Initialise the DO variable: dovar = from. */
585 gfc_add_modify_expr (&block
, dovar
, from
);
588 gfc_start_block (&body
);
590 /* Cycle and exit statements are implemented with gotos. */
591 cycle_label
= gfc_build_label_decl (NULL_TREE
);
592 exit_label
= gfc_build_label_decl (NULL_TREE
);
594 /* Start with the loop condition. Loop until count <= 0. */
595 cond
= build2 (LE_EXPR
, boolean_type_node
, count
, integer_zero_node
);
596 tmp
= build1_v (GOTO_EXPR
, exit_label
);
597 TREE_USED (exit_label
) = 1;
598 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt ());
599 gfc_add_expr_to_block (&body
, tmp
);
601 /* Put these labels where they can be found later. We put the
602 labels in a TREE_LIST node (because TREE_CHAIN is already
603 used). cycle_label goes in TREE_PURPOSE (backend_decl), exit
604 label in TREE_VALUE (backend_decl). */
606 code
->block
->backend_decl
= tree_cons (cycle_label
, exit_label
, NULL
);
608 /* Main loop body. */
609 tmp
= gfc_trans_code (code
->block
->next
);
610 gfc_add_expr_to_block (&body
, tmp
);
612 /* Label for cycle statements (if needed). */
613 if (TREE_USED (cycle_label
))
615 tmp
= build1_v (LABEL_EXPR
, cycle_label
);
616 gfc_add_expr_to_block (&body
, tmp
);
619 /* Increment the loop variable. */
620 tmp
= build2 (PLUS_EXPR
, type
, dovar
, step
);
621 gfc_add_modify_expr (&body
, dovar
, tmp
);
623 /* Decrement the loop count. */
624 tmp
= build2 (MINUS_EXPR
, type
, count
, gfc_index_one_node
);
625 gfc_add_modify_expr (&body
, count
, tmp
);
627 /* End of loop body. */
628 tmp
= gfc_finish_block (&body
);
630 /* The for loop itself. */
631 tmp
= build1_v (LOOP_EXPR
, tmp
);
632 gfc_add_expr_to_block (&block
, tmp
);
634 /* Add the exit label. */
635 tmp
= build1_v (LABEL_EXPR
, exit_label
);
636 gfc_add_expr_to_block (&block
, tmp
);
638 return gfc_finish_block (&block
);
642 /* Translate the DO WHILE construct.
655 if (! cond) goto exit_label;
661 Because the evaluation of the exit condition `cond' may have side
662 effects, we can't do much for empty loop bodies. The backend optimizers
663 should be smart enough to eliminate any dead loops. */
666 gfc_trans_do_while (gfc_code
* code
)
674 /* Everything we build here is part of the loop body. */
675 gfc_start_block (&block
);
677 /* Cycle and exit statements are implemented with gotos. */
678 cycle_label
= gfc_build_label_decl (NULL_TREE
);
679 exit_label
= gfc_build_label_decl (NULL_TREE
);
681 /* Put the labels where they can be found later. See gfc_trans_do(). */
682 code
->block
->backend_decl
= tree_cons (cycle_label
, exit_label
, NULL
);
684 /* Create a GIMPLE version of the exit condition. */
685 gfc_init_se (&cond
, NULL
);
686 gfc_conv_expr_val (&cond
, code
->expr
);
687 gfc_add_block_to_block (&block
, &cond
.pre
);
688 cond
.expr
= fold (build1 (TRUTH_NOT_EXPR
, boolean_type_node
, cond
.expr
));
690 /* Build "IF (! cond) GOTO exit_label". */
691 tmp
= build1_v (GOTO_EXPR
, exit_label
);
692 TREE_USED (exit_label
) = 1;
693 tmp
= build3_v (COND_EXPR
, cond
.expr
, tmp
, build_empty_stmt ());
694 gfc_add_expr_to_block (&block
, tmp
);
696 /* The main body of the loop. */
697 tmp
= gfc_trans_code (code
->block
->next
);
698 gfc_add_expr_to_block (&block
, tmp
);
700 /* Label for cycle statements (if needed). */
701 if (TREE_USED (cycle_label
))
703 tmp
= build1_v (LABEL_EXPR
, cycle_label
);
704 gfc_add_expr_to_block (&block
, tmp
);
707 /* End of loop body. */
708 tmp
= gfc_finish_block (&block
);
710 gfc_init_block (&block
);
711 /* Build the loop. */
712 tmp
= build1_v (LOOP_EXPR
, tmp
);
713 gfc_add_expr_to_block (&block
, tmp
);
715 /* Add the exit label. */
716 tmp
= build1_v (LABEL_EXPR
, exit_label
);
717 gfc_add_expr_to_block (&block
, tmp
);
719 return gfc_finish_block (&block
);
723 /* Translate the SELECT CASE construct for INTEGER case expressions,
724 without killing all potential optimizations. The problem is that
725 Fortran allows unbounded cases, but the back-end does not, so we
726 need to intercept those before we enter the equivalent SWITCH_EXPR
729 For example, we translate this,
732 CASE (:100,101,105:115)
742 to the GENERIC equivalent,
746 case (minimum value for typeof(expr) ... 100:
752 case 200 ... (maximum value for typeof(expr):
769 gfc_trans_integer_select (gfc_code
* code
)
779 gfc_start_block (&block
);
781 /* Calculate the switch expression. */
782 gfc_init_se (&se
, NULL
);
783 gfc_conv_expr_val (&se
, code
->expr
);
784 gfc_add_block_to_block (&block
, &se
.pre
);
786 end_label
= gfc_build_label_decl (NULL_TREE
);
788 gfc_init_block (&body
);
790 for (c
= code
->block
; c
; c
= c
->block
)
792 for (cp
= c
->ext
.case_list
; cp
; cp
= cp
->next
)
797 /* Assume it's the default case. */
798 low
= high
= NULL_TREE
;
802 low
= gfc_conv_constant_to_tree (cp
->low
);
804 /* If there's only a lower bound, set the high bound to the
805 maximum value of the case expression. */
807 high
= TYPE_MAX_VALUE (TREE_TYPE (se
.expr
));
812 /* Three cases are possible here:
814 1) There is no lower bound, e.g. CASE (:N).
815 2) There is a lower bound .NE. high bound, that is
816 a case range, e.g. CASE (N:M) where M>N (we make
817 sure that M>N during type resolution).
818 3) There is a lower bound, and it has the same value
819 as the high bound, e.g. CASE (N:N). This is our
820 internal representation of CASE(N).
822 In the first and second case, we need to set a value for
823 high. In the thirth case, we don't because the GCC middle
824 end represents a single case value by just letting high be
825 a NULL_TREE. We can't do that because we need to be able
826 to represent unbounded cases. */
830 && mpz_cmp (cp
->low
->value
.integer
,
831 cp
->high
->value
.integer
) != 0))
832 high
= gfc_conv_constant_to_tree (cp
->high
);
834 /* Unbounded case. */
836 low
= TYPE_MIN_VALUE (TREE_TYPE (se
.expr
));
840 label
= build_decl (LABEL_DECL
, NULL_TREE
, NULL_TREE
);
841 DECL_CONTEXT (label
) = current_function_decl
;
843 /* Add this case label.
844 Add parameter 'label', make it match GCC backend. */
845 tmp
= build3 (CASE_LABEL_EXPR
, void_type_node
, low
, high
, label
);
846 gfc_add_expr_to_block (&body
, tmp
);
849 /* Add the statements for this case. */
850 tmp
= gfc_trans_code (c
->next
);
851 gfc_add_expr_to_block (&body
, tmp
);
853 /* Break to the end of the construct. */
854 tmp
= build1_v (GOTO_EXPR
, end_label
);
855 gfc_add_expr_to_block (&body
, tmp
);
858 tmp
= gfc_finish_block (&body
);
859 tmp
= build3_v (SWITCH_EXPR
, se
.expr
, tmp
, NULL_TREE
);
860 gfc_add_expr_to_block (&block
, tmp
);
862 tmp
= build1_v (LABEL_EXPR
, end_label
);
863 gfc_add_expr_to_block (&block
, tmp
);
865 return gfc_finish_block (&block
);
869 /* Translate the SELECT CASE construct for LOGICAL case expressions.
871 There are only two cases possible here, even though the standard
872 does allow three cases in a LOGICAL SELECT CASE construct: .TRUE.,
873 .FALSE., and DEFAULT.
875 We never generate more than two blocks here. Instead, we always
876 try to eliminate the DEFAULT case. This way, we can translate this
877 kind of SELECT construct to a simple
881 expression in GENERIC. */
884 gfc_trans_logical_select (gfc_code
* code
)
892 /* Assume we don't have any cases at all. */
895 /* Now see which ones we actually do have. We can have at most two
896 cases in a single case list: one for .TRUE. and one for .FALSE.
897 The default case is always separate. If the cases for .TRUE. and
898 .FALSE. are in the same case list, the block for that case list
899 always executed, and we don't generate code a COND_EXPR. */
900 for (c
= code
->block
; c
; c
= c
->block
)
902 for (cp
= c
->ext
.case_list
; cp
; cp
= cp
->next
)
906 if (cp
->low
->value
.logical
== 0) /* .FALSE. */
908 else /* if (cp->value.logical != 0), thus .TRUE. */
916 /* Start a new block. */
917 gfc_start_block (&block
);
919 /* Calculate the switch expression. We always need to do this
920 because it may have side effects. */
921 gfc_init_se (&se
, NULL
);
922 gfc_conv_expr_val (&se
, code
->expr
);
923 gfc_add_block_to_block (&block
, &se
.pre
);
925 if (t
== f
&& t
!= NULL
)
927 /* Cases for .TRUE. and .FALSE. are in the same block. Just
928 translate the code for these cases, append it to the current
930 gfc_add_expr_to_block (&block
, gfc_trans_code (t
->next
));
934 tree true_tree
, false_tree
;
936 true_tree
= build_empty_stmt ();
937 false_tree
= build_empty_stmt ();
939 /* If we have a case for .TRUE. and for .FALSE., discard the default case.
940 Otherwise, if .TRUE. or .FALSE. is missing and there is a default case,
941 make the missing case the default case. */
942 if (t
!= NULL
&& f
!= NULL
)
952 /* Translate the code for each of these blocks, and append it to
953 the current block. */
955 true_tree
= gfc_trans_code (t
->next
);
958 false_tree
= gfc_trans_code (f
->next
);
960 gfc_add_expr_to_block (&block
, build3_v (COND_EXPR
, se
.expr
,
961 true_tree
, false_tree
));
964 return gfc_finish_block (&block
);
968 /* Translate the SELECT CASE construct for CHARACTER case expressions.
969 Instead of generating compares and jumps, it is far simpler to
970 generate a data structure describing the cases in order and call a
971 library subroutine that locates the right case.
972 This is particularly true because this is the only case where we
973 might have to dispose of a temporary.
974 The library subroutine returns a pointer to jump to or NULL if no
975 branches are to be taken. */
978 gfc_trans_character_select (gfc_code
*code
)
980 tree init
, node
, end_label
, tmp
, type
, args
, *labels
;
981 stmtblock_t block
, body
;
987 static tree select_struct
;
988 static tree ss_string1
, ss_string1_len
;
989 static tree ss_string2
, ss_string2_len
;
990 static tree ss_target
;
992 if (select_struct
== NULL
)
994 select_struct
= make_node (RECORD_TYPE
);
995 TYPE_NAME (select_struct
) = get_identifier ("_jump_struct");
998 #define ADD_FIELD(NAME, TYPE) \
999 ss_##NAME = gfc_add_field_to_struct \
1000 (&(TYPE_FIELDS (select_struct)), select_struct, \
1001 get_identifier (stringize(NAME)), TYPE)
1003 ADD_FIELD (string1
, pchar_type_node
);
1004 ADD_FIELD (string1_len
, gfc_int4_type_node
);
1006 ADD_FIELD (string2
, pchar_type_node
);
1007 ADD_FIELD (string2_len
, gfc_int4_type_node
);
1009 ADD_FIELD (target
, pvoid_type_node
);
1012 gfc_finish_type (select_struct
);
1015 cp
= code
->block
->ext
.case_list
;
1016 while (cp
->left
!= NULL
)
1020 for (d
= cp
; d
; d
= d
->right
)
1024 labels
= gfc_getmem (n
* sizeof (tree
));
1028 for(i
= 0; i
< n
; i
++)
1030 labels
[i
] = gfc_build_label_decl (NULL_TREE
);
1031 TREE_USED (labels
[i
]) = 1;
1032 /* TODO: The gimplifier should do this for us, but it has
1033 inadequacies when dealing with static initializers. */
1034 FORCED_LABEL (labels
[i
]) = 1;
1037 end_label
= gfc_build_label_decl (NULL_TREE
);
1039 /* Generate the body */
1040 gfc_start_block (&block
);
1041 gfc_init_block (&body
);
1043 for (c
= code
->block
; c
; c
= c
->block
)
1045 for (d
= c
->ext
.case_list
; d
; d
= d
->next
)
1047 tmp
= build1_v (LABEL_EXPR
, labels
[d
->n
]);
1048 gfc_add_expr_to_block (&body
, tmp
);
1051 tmp
= gfc_trans_code (c
->next
);
1052 gfc_add_expr_to_block (&body
, tmp
);
1054 tmp
= build1_v (GOTO_EXPR
, end_label
);
1055 gfc_add_expr_to_block (&body
, tmp
);
1058 /* Generate the structure describing the branches */
1062 for(d
= cp
; d
; d
= d
->right
, i
++)
1066 gfc_init_se (&se
, NULL
);
1070 node
= tree_cons (ss_string1
, null_pointer_node
, node
);
1071 node
= tree_cons (ss_string1_len
, integer_zero_node
, node
);
1075 gfc_conv_expr_reference (&se
, d
->low
);
1077 node
= tree_cons (ss_string1
, se
.expr
, node
);
1078 node
= tree_cons (ss_string1_len
, se
.string_length
, node
);
1081 if (d
->high
== NULL
)
1083 node
= tree_cons (ss_string2
, null_pointer_node
, node
);
1084 node
= tree_cons (ss_string2_len
, integer_zero_node
, node
);
1088 gfc_init_se (&se
, NULL
);
1089 gfc_conv_expr_reference (&se
, d
->high
);
1091 node
= tree_cons (ss_string2
, se
.expr
, node
);
1092 node
= tree_cons (ss_string2_len
, se
.string_length
, node
);
1095 tmp
= gfc_build_addr_expr (pvoid_type_node
, labels
[i
]);
1096 node
= tree_cons (ss_target
, tmp
, node
);
1098 tmp
= build1 (CONSTRUCTOR
, select_struct
, nreverse (node
));
1099 init
= tree_cons (NULL_TREE
, tmp
, init
);
1102 type
= build_array_type (select_struct
, build_index_type
1103 (build_int_cst (NULL_TREE
, n
- 1)));
1105 init
= build1 (CONSTRUCTOR
, type
, nreverse(init
));
1106 TREE_CONSTANT (init
) = 1;
1107 TREE_INVARIANT (init
) = 1;
1108 TREE_STATIC (init
) = 1;
1109 /* Create a static variable to hold the jump table. */
1110 tmp
= gfc_create_var (type
, "jumptable");
1111 TREE_CONSTANT (tmp
) = 1;
1112 TREE_INVARIANT (tmp
) = 1;
1113 TREE_STATIC (tmp
) = 1;
1114 DECL_INITIAL (tmp
) = init
;
1117 /* Build an argument list for the library call */
1118 init
= gfc_build_addr_expr (pvoid_type_node
, init
);
1119 args
= gfc_chainon_list (NULL_TREE
, init
);
1121 tmp
= build_int_cst (NULL_TREE
, n
);
1122 args
= gfc_chainon_list (args
, tmp
);
1124 tmp
= gfc_build_addr_expr (pvoid_type_node
, end_label
);
1125 args
= gfc_chainon_list (args
, tmp
);
1127 gfc_init_se (&se
, NULL
);
1128 gfc_conv_expr_reference (&se
, code
->expr
);
1130 args
= gfc_chainon_list (args
, se
.expr
);
1131 args
= gfc_chainon_list (args
, se
.string_length
);
1133 gfc_add_block_to_block (&block
, &se
.pre
);
1135 tmp
= gfc_build_function_call (gfor_fndecl_select_string
, args
);
1136 tmp
= build1 (GOTO_EXPR
, void_type_node
, tmp
);
1137 gfc_add_expr_to_block (&block
, tmp
);
1139 tmp
= gfc_finish_block (&body
);
1140 gfc_add_expr_to_block (&block
, tmp
);
1141 tmp
= build1_v (LABEL_EXPR
, end_label
);
1142 gfc_add_expr_to_block (&block
, tmp
);
1147 return gfc_finish_block (&block
);
1151 /* Translate the three variants of the SELECT CASE construct.
1153 SELECT CASEs with INTEGER case expressions can be translated to an
1154 equivalent GENERIC switch statement, and for LOGICAL case
1155 expressions we build one or two if-else compares.
1157 SELECT CASEs with CHARACTER case expressions are a whole different
1158 story, because they don't exist in GENERIC. So we sort them and
1159 do a binary search at runtime.
1161 Fortran has no BREAK statement, and it does not allow jumps from
1162 one case block to another. That makes things a lot easier for
1166 gfc_trans_select (gfc_code
* code
)
1168 assert (code
&& code
->expr
);
1170 /* Empty SELECT constructs are legal. */
1171 if (code
->block
== NULL
)
1172 return build_empty_stmt ();
1174 /* Select the correct translation function. */
1175 switch (code
->expr
->ts
.type
)
1177 case BT_LOGICAL
: return gfc_trans_logical_select (code
);
1178 case BT_INTEGER
: return gfc_trans_integer_select (code
);
1179 case BT_CHARACTER
: return gfc_trans_character_select (code
);
1181 gfc_internal_error ("gfc_trans_select(): Bad type for case expr.");
1187 /* Generate the loops for a FORALL block. The normal loop format:
1188 count = (end - start + step) / step
1201 gfc_trans_forall_loop (forall_info
*forall_tmp
, int nvar
, tree body
, int mask_flag
)
1209 tree var
, start
, end
, step
, mask
, maskindex
;
1212 iter
= forall_tmp
->this_loop
;
1213 for (n
= 0; n
< nvar
; n
++)
1216 start
= iter
->start
;
1220 exit_label
= gfc_build_label_decl (NULL_TREE
);
1221 TREE_USED (exit_label
) = 1;
1223 /* The loop counter. */
1224 count
= gfc_create_var (TREE_TYPE (var
), "count");
1226 /* The body of the loop. */
1227 gfc_init_block (&block
);
1229 /* The exit condition. */
1230 cond
= build2 (LE_EXPR
, boolean_type_node
, count
, integer_zero_node
);
1231 tmp
= build1_v (GOTO_EXPR
, exit_label
);
1232 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt ());
1233 gfc_add_expr_to_block (&block
, tmp
);
1235 /* The main loop body. */
1236 gfc_add_expr_to_block (&block
, body
);
1238 /* Increment the loop variable. */
1239 tmp
= build2 (PLUS_EXPR
, TREE_TYPE (var
), var
, step
);
1240 gfc_add_modify_expr (&block
, var
, tmp
);
1242 /* Advance to the next mask element. */
1245 mask
= forall_tmp
->mask
;
1246 maskindex
= forall_tmp
->maskindex
;
1249 tmp
= build2 (PLUS_EXPR
, gfc_array_index_type
,
1250 maskindex
, gfc_index_one_node
);
1251 gfc_add_modify_expr (&block
, maskindex
, tmp
);
1254 /* Decrement the loop counter. */
1255 tmp
= build2 (MINUS_EXPR
, TREE_TYPE (var
), count
, gfc_index_one_node
);
1256 gfc_add_modify_expr (&block
, count
, tmp
);
1258 body
= gfc_finish_block (&block
);
1260 /* Loop var initialization. */
1261 gfc_init_block (&block
);
1262 gfc_add_modify_expr (&block
, var
, start
);
1264 /* Initialize the loop counter. */
1265 tmp
= fold (build2 (MINUS_EXPR
, TREE_TYPE (var
), step
, start
));
1266 tmp
= fold (build2 (PLUS_EXPR
, TREE_TYPE (var
), end
, tmp
));
1267 tmp
= fold (build2 (TRUNC_DIV_EXPR
, TREE_TYPE (var
), tmp
, step
));
1268 gfc_add_modify_expr (&block
, count
, tmp
);
1270 /* The loop expression. */
1271 tmp
= build1_v (LOOP_EXPR
, body
);
1272 gfc_add_expr_to_block (&block
, tmp
);
1274 /* The exit label. */
1275 tmp
= build1_v (LABEL_EXPR
, exit_label
);
1276 gfc_add_expr_to_block (&block
, tmp
);
1278 body
= gfc_finish_block (&block
);
1285 /* Generate the body and loops according to MASK_FLAG and NEST_FLAG.
1286 if MASK_FLAG is non-zero, the body is controlled by maskes in forall
1287 nest, otherwise, the body is not controlled by maskes.
1288 if NEST_FLAG is non-zero, generate loops for nested forall, otherwise,
1289 only generate loops for the current forall level. */
1292 gfc_trans_nested_forall_loop (forall_info
* nested_forall_info
, tree body
,
1293 int mask_flag
, int nest_flag
)
1297 forall_info
*forall_tmp
;
1298 tree pmask
, mask
, maskindex
;
1300 forall_tmp
= nested_forall_info
;
1301 /* Generate loops for nested forall. */
1304 while (forall_tmp
->next_nest
!= NULL
)
1305 forall_tmp
= forall_tmp
->next_nest
;
1306 while (forall_tmp
!= NULL
)
1308 /* Generate body with masks' control. */
1311 pmask
= forall_tmp
->pmask
;
1312 mask
= forall_tmp
->mask
;
1313 maskindex
= forall_tmp
->maskindex
;
1317 /* If a mask was specified make the assignment contitional. */
1319 tmp
= gfc_build_indirect_ref (mask
);
1322 tmp
= gfc_build_array_ref (tmp
, maskindex
);
1324 body
= build3_v (COND_EXPR
, tmp
, body
, build_empty_stmt ());
1327 nvar
= forall_tmp
->nvar
;
1328 body
= gfc_trans_forall_loop (forall_tmp
, nvar
, body
, mask_flag
);
1329 forall_tmp
= forall_tmp
->outer
;
1334 nvar
= forall_tmp
->nvar
;
1335 body
= gfc_trans_forall_loop (forall_tmp
, nvar
, body
, mask_flag
);
1342 /* Allocate data for holding a temporary array. Returns either a local
1343 temporary array or a pointer variable. */
1346 gfc_do_allocate (tree bytesize
, tree size
, tree
* pdata
, stmtblock_t
* pblock
,
1354 if (INTEGER_CST_P (size
))
1356 tmp
= fold (build2 (MINUS_EXPR
, gfc_array_index_type
, size
,
1357 gfc_index_one_node
));
1362 type
= build_range_type (gfc_array_index_type
, gfc_index_zero_node
, tmp
);
1363 type
= build_array_type (elem_type
, type
);
1364 if (gfc_can_put_var_on_stack (bytesize
))
1366 assert (INTEGER_CST_P (size
));
1367 tmpvar
= gfc_create_var (type
, "temp");
1372 tmpvar
= gfc_create_var (build_pointer_type (type
), "temp");
1373 *pdata
= convert (pvoid_type_node
, tmpvar
);
1375 args
= gfc_chainon_list (NULL_TREE
, bytesize
);
1376 if (gfc_index_integer_kind
== 4)
1377 tmp
= gfor_fndecl_internal_malloc
;
1378 else if (gfc_index_integer_kind
== 8)
1379 tmp
= gfor_fndecl_internal_malloc64
;
1382 tmp
= gfc_build_function_call (tmp
, args
);
1383 tmp
= convert (TREE_TYPE (tmpvar
), tmp
);
1384 gfc_add_modify_expr (pblock
, tmpvar
, tmp
);
1390 /* Generate codes to copy the temporary to the actual lhs. */
1393 generate_loop_for_temp_to_lhs (gfc_expr
*expr
, tree tmp1
, tree size
,
1394 tree count3
, tree count1
, tree count2
, tree wheremask
)
1398 stmtblock_t block
, body
;
1405 lss
= gfc_walk_expr (expr
);
1407 if (lss
== gfc_ss_terminator
)
1409 gfc_start_block (&block
);
1411 gfc_init_se (&lse
, NULL
);
1413 /* Translate the expression. */
1414 gfc_conv_expr (&lse
, expr
);
1416 /* Form the expression for the temporary. */
1417 tmp
= gfc_build_array_ref (tmp1
, count1
);
1419 /* Use the scalar assignment as is. */
1420 gfc_add_block_to_block (&block
, &lse
.pre
);
1421 gfc_add_modify_expr (&block
, lse
.expr
, tmp
);
1422 gfc_add_block_to_block (&block
, &lse
.post
);
1424 /* Increment the count1. */
1425 tmp
= fold (build2 (PLUS_EXPR
, TREE_TYPE (count1
), count1
, size
));
1426 gfc_add_modify_expr (&block
, count1
, tmp
);
1427 tmp
= gfc_finish_block (&block
);
1431 gfc_start_block (&block
);
1433 gfc_init_loopinfo (&loop1
);
1434 gfc_init_se (&rse
, NULL
);
1435 gfc_init_se (&lse
, NULL
);
1437 /* Associate the lss with the loop. */
1438 gfc_add_ss_to_loop (&loop1
, lss
);
1440 /* Calculate the bounds of the scalarization. */
1441 gfc_conv_ss_startstride (&loop1
);
1442 /* Setup the scalarizing loops. */
1443 gfc_conv_loop_setup (&loop1
);
1445 gfc_mark_ss_chain_used (lss
, 1);
1446 /* Initialize count2. */
1447 gfc_add_modify_expr (&block
, count2
, gfc_index_zero_node
);
1449 /* Start the scalarized loop body. */
1450 gfc_start_scalarized_body (&loop1
, &body
);
1452 /* Setup the gfc_se structures. */
1453 gfc_copy_loopinfo_to_se (&lse
, &loop1
);
1456 /* Form the expression of the temporary. */
1457 if (lss
!= gfc_ss_terminator
)
1459 index
= fold (build2 (PLUS_EXPR
, gfc_array_index_type
,
1461 rse
.expr
= gfc_build_array_ref (tmp1
, index
);
1463 /* Translate expr. */
1464 gfc_conv_expr (&lse
, expr
);
1466 /* Use the scalar assignment. */
1467 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
.type
);
1469 /* Form the mask expression according to the mask tree list. */
1474 wheremaskexpr
= gfc_build_array_ref (tmp2
, count3
);
1475 tmp2
= TREE_CHAIN (tmp2
);
1478 tmp1
= gfc_build_array_ref (tmp2
, count3
);
1479 wheremaskexpr
= build2 (TRUTH_AND_EXPR
, TREE_TYPE (tmp1
),
1480 wheremaskexpr
, tmp1
);
1481 tmp2
= TREE_CHAIN (tmp2
);
1483 tmp
= build3_v (COND_EXPR
, wheremaskexpr
, tmp
, build_empty_stmt ());
1486 gfc_add_expr_to_block (&body
, tmp
);
1488 /* Increment count2. */
1489 tmp
= fold (build2 (PLUS_EXPR
, gfc_array_index_type
,
1490 count2
, gfc_index_one_node
));
1491 gfc_add_modify_expr (&body
, count2
, tmp
);
1493 /* Increment count3. */
1496 tmp
= fold (build2 (PLUS_EXPR
, gfc_array_index_type
,
1497 count3
, gfc_index_one_node
));
1498 gfc_add_modify_expr (&body
, count3
, tmp
);
1501 /* Generate the copying loops. */
1502 gfc_trans_scalarizing_loops (&loop1
, &body
);
1503 gfc_add_block_to_block (&block
, &loop1
.pre
);
1504 gfc_add_block_to_block (&block
, &loop1
.post
);
1505 gfc_cleanup_loop (&loop1
);
1507 /* Increment count1. */
1508 tmp
= fold (build2 (PLUS_EXPR
, TREE_TYPE (count1
), count1
, size
));
1509 gfc_add_modify_expr (&block
, count1
, tmp
);
1510 tmp
= gfc_finish_block (&block
);
1516 /* Generate codes to copy rhs to the temporary. TMP1 is the address of temporary
1517 LSS and RSS are formed in function compute_inner_temp_size(), and should
1521 generate_loop_for_rhs_to_temp (gfc_expr
*expr2
, tree tmp1
, tree size
,
1522 tree count3
, tree count1
, tree count2
,
1523 gfc_ss
*lss
, gfc_ss
*rss
, tree wheremask
)
1525 stmtblock_t block
, body1
;
1529 tree tmp
, tmp2
, index
;
1532 gfc_start_block (&block
);
1534 gfc_init_se (&rse
, NULL
);
1535 gfc_init_se (&lse
, NULL
);
1537 if (lss
== gfc_ss_terminator
)
1539 gfc_init_block (&body1
);
1540 gfc_conv_expr (&rse
, expr2
);
1541 lse
.expr
= gfc_build_array_ref (tmp1
, count1
);
1545 /* Initilize count2. */
1546 gfc_add_modify_expr (&block
, count2
, gfc_index_zero_node
);
1548 /* Initiliaze the loop. */
1549 gfc_init_loopinfo (&loop
);
1551 /* We may need LSS to determine the shape of the expression. */
1552 gfc_add_ss_to_loop (&loop
, lss
);
1553 gfc_add_ss_to_loop (&loop
, rss
);
1555 gfc_conv_ss_startstride (&loop
);
1556 gfc_conv_loop_setup (&loop
);
1558 gfc_mark_ss_chain_used (rss
, 1);
1559 /* Start the loop body. */
1560 gfc_start_scalarized_body (&loop
, &body1
);
1562 /* Translate the expression. */
1563 gfc_copy_loopinfo_to_se (&rse
, &loop
);
1565 gfc_conv_expr (&rse
, expr2
);
1567 /* Form the expression of the temporary. */
1568 index
= fold (build2 (PLUS_EXPR
, gfc_array_index_type
, count1
, count2
));
1569 lse
.expr
= gfc_build_array_ref (tmp1
, index
);
1572 /* Use the scalar assignment. */
1573 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr2
->ts
.type
);
1575 /* Form the mask expression according to the mask tree list. */
1580 wheremaskexpr
= gfc_build_array_ref (tmp2
, count3
);
1581 tmp2
= TREE_CHAIN (tmp2
);
1584 tmp1
= gfc_build_array_ref (tmp2
, count3
);
1585 wheremaskexpr
= build2 (TRUTH_AND_EXPR
, TREE_TYPE (tmp1
),
1586 wheremaskexpr
, tmp1
);
1587 tmp2
= TREE_CHAIN (tmp2
);
1589 tmp
= build3_v (COND_EXPR
, wheremaskexpr
, tmp
, build_empty_stmt ());
1592 gfc_add_expr_to_block (&body1
, tmp
);
1594 if (lss
== gfc_ss_terminator
)
1596 gfc_add_block_to_block (&block
, &body1
);
1600 /* Increment count2. */
1601 tmp
= fold (build2 (PLUS_EXPR
, gfc_array_index_type
,
1602 count2
, gfc_index_one_node
));
1603 gfc_add_modify_expr (&body1
, count2
, tmp
);
1605 /* Increment count3. */
1608 tmp
= fold (build2 (PLUS_EXPR
, gfc_array_index_type
,
1609 count3
, gfc_index_one_node
));
1610 gfc_add_modify_expr (&body1
, count3
, tmp
);
1613 /* Generate the copying loops. */
1614 gfc_trans_scalarizing_loops (&loop
, &body1
);
1616 gfc_add_block_to_block (&block
, &loop
.pre
);
1617 gfc_add_block_to_block (&block
, &loop
.post
);
1619 gfc_cleanup_loop (&loop
);
1620 /* TODO: Reuse lss and rss when copying temp->lhs. Need to be careful
1621 as tree nodes in SS may not be valid in different scope. */
1623 /* Increment count1. */
1624 tmp
= fold (build2 (PLUS_EXPR
, TREE_TYPE (count1
), count1
, size
));
1625 gfc_add_modify_expr (&block
, count1
, tmp
);
1627 tmp
= gfc_finish_block (&block
);
1632 /* Calculate the size of temporary needed in the assignment inside forall.
1633 LSS and RSS are filled in this function. */
1636 compute_inner_temp_size (gfc_expr
*expr1
, gfc_expr
*expr2
,
1637 stmtblock_t
* pblock
,
1638 gfc_ss
**lss
, gfc_ss
**rss
)
1645 *lss
= gfc_walk_expr (expr1
);
1648 size
= gfc_index_one_node
;
1649 if (*lss
!= gfc_ss_terminator
)
1651 gfc_init_loopinfo (&loop
);
1653 /* Walk the RHS of the expression. */
1654 *rss
= gfc_walk_expr (expr2
);
1655 if (*rss
== gfc_ss_terminator
)
1657 /* The rhs is scalar. Add a ss for the expression. */
1658 *rss
= gfc_get_ss ();
1659 (*rss
)->next
= gfc_ss_terminator
;
1660 (*rss
)->type
= GFC_SS_SCALAR
;
1661 (*rss
)->expr
= expr2
;
1664 /* Associate the SS with the loop. */
1665 gfc_add_ss_to_loop (&loop
, *lss
);
1666 /* We don't actually need to add the rhs at this point, but it might
1667 make guessing the loop bounds a bit easier. */
1668 gfc_add_ss_to_loop (&loop
, *rss
);
1670 /* We only want the shape of the expression, not rest of the junk
1671 generated by the scalarizer. */
1672 loop
.array_parameter
= 1;
1674 /* Calculate the bounds of the scalarization. */
1675 gfc_conv_ss_startstride (&loop
);
1676 gfc_conv_loop_setup (&loop
);
1678 /* Figure out how many elements we need. */
1679 for (i
= 0; i
< loop
.dimen
; i
++)
1681 tmp
= fold (build2 (MINUS_EXPR
, gfc_array_index_type
,
1682 gfc_index_one_node
, loop
.from
[i
]));
1683 tmp
= fold (build2 (PLUS_EXPR
, gfc_array_index_type
,
1685 size
= fold (build2 (MULT_EXPR
, gfc_array_index_type
, size
, tmp
));
1687 gfc_add_block_to_block (pblock
, &loop
.pre
);
1688 size
= gfc_evaluate_now (size
, pblock
);
1689 gfc_add_block_to_block (pblock
, &loop
.post
);
1691 /* TODO: write a function that cleans up a loopinfo without freeing
1692 the SS chains. Currently a NOP. */
1699 /* Calculate the overall iterator number of the nested forall construct. */
1702 compute_overall_iter_number (forall_info
*nested_forall_info
, tree inner_size
,
1708 /* TODO: optimizing the computing process. */
1709 number
= gfc_create_var (gfc_array_index_type
, "num");
1710 gfc_add_modify_expr (block
, number
, gfc_index_zero_node
);
1712 gfc_start_block (&body
);
1713 if (nested_forall_info
)
1714 tmp
= build2 (PLUS_EXPR
, gfc_array_index_type
, number
,
1718 gfc_add_modify_expr (&body
, number
, tmp
);
1719 tmp
= gfc_finish_block (&body
);
1721 /* Generate loops. */
1722 if (nested_forall_info
!= NULL
)
1723 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, tmp
, 0, 1);
1725 gfc_add_expr_to_block (block
, tmp
);
1731 /* Allocate temporary for forall construct according to the information in
1732 nested_forall_info. INNER_SIZE is the size of temporary needed in the
1733 assignment inside forall. PTEMP1 is returned for space free. */
1736 allocate_temp_for_forall_nest (forall_info
* nested_forall_info
, tree type
,
1737 tree inner_size
, stmtblock_t
* block
,
1743 tree bytesize
, size
;
1745 /* Calculate the total size of temporary needed in forall construct. */
1746 size
= compute_overall_iter_number (nested_forall_info
, inner_size
, block
);
1748 unit
= TYPE_SIZE_UNIT (type
);
1749 bytesize
= fold (build2 (MULT_EXPR
, gfc_array_index_type
, size
, unit
));
1752 temp1
= gfc_do_allocate (bytesize
, size
, ptemp1
, block
, type
);
1755 tmp
= gfc_build_indirect_ref (temp1
);
1763 /* Handle assignments inside forall which need temporary. */
1765 gfc_trans_assign_need_temp (gfc_expr
* expr1
, gfc_expr
* expr2
, tree wheremask
,
1766 forall_info
* nested_forall_info
,
1767 stmtblock_t
* block
)
1772 tree count
, count1
, count2
;
1775 tree mask
, maskindex
;
1776 forall_info
*forall_tmp
;
1778 /* Create vars. count1 is the current iterator number of the nested forall.
1779 count2 is the current iterator number of the inner loops needed in the
1781 count1
= gfc_create_var (gfc_array_index_type
, "count1");
1782 count2
= gfc_create_var (gfc_array_index_type
, "count2");
1784 /* Count is the wheremask index. */
1787 count
= gfc_create_var (gfc_array_index_type
, "count");
1788 gfc_add_modify_expr (block
, count
, gfc_index_zero_node
);
1793 /* Initialize count1. */
1794 gfc_add_modify_expr (block
, count1
, gfc_index_zero_node
);
1796 /* Calculate the size of temporary needed in the assignment. Return loop, lss
1797 and rss which are used in function generate_loop_for_rhs_to_temp(). */
1798 inner_size
= compute_inner_temp_size (expr1
, expr2
, block
, &lss
, &rss
);
1800 /* The type of LHS. Used in function allocate_temp_for_forall_nest */
1801 type
= gfc_typenode_for_spec (&expr1
->ts
);
1803 /* Allocate temporary for nested forall construct according to the
1804 information in nested_forall_info and inner_size. */
1805 tmp1
= allocate_temp_for_forall_nest (nested_forall_info
, type
,
1806 inner_size
, block
, &ptemp1
);
1808 /* Initialize the maskindexes. */
1809 forall_tmp
= nested_forall_info
;
1810 while (forall_tmp
!= NULL
)
1812 mask
= forall_tmp
->mask
;
1813 maskindex
= forall_tmp
->maskindex
;
1815 gfc_add_modify_expr (block
, maskindex
, gfc_index_zero_node
);
1816 forall_tmp
= forall_tmp
->next_nest
;
1819 /* Generate codes to copy rhs to the temporary . */
1820 tmp
= generate_loop_for_rhs_to_temp (expr2
, tmp1
, inner_size
, count
,
1821 count1
, count2
, lss
, rss
, wheremask
);
1823 /* Generate body and loops according to the inforamtion in
1824 nested_forall_info. */
1825 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, tmp
, 1, 1);
1826 gfc_add_expr_to_block (block
, tmp
);
1829 gfc_add_modify_expr (block
, count1
, gfc_index_zero_node
);
1831 /* Reset maskindexed. */
1832 forall_tmp
= nested_forall_info
;
1833 while (forall_tmp
!= NULL
)
1835 mask
= forall_tmp
->mask
;
1836 maskindex
= forall_tmp
->maskindex
;
1838 gfc_add_modify_expr (block
, maskindex
, gfc_index_zero_node
);
1839 forall_tmp
= forall_tmp
->next_nest
;
1844 gfc_add_modify_expr (block
, count
, gfc_index_zero_node
);
1846 /* Generate codes to copy the temporary to lhs. */
1847 tmp
= generate_loop_for_temp_to_lhs (expr1
, tmp1
, inner_size
, count
,
1848 count1
, count2
, wheremask
);
1850 /* Generate body and loops according to the inforamtion in
1851 nested_forall_info. */
1852 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, tmp
, 1, 1);
1853 gfc_add_expr_to_block (block
, tmp
);
1857 /* Free the temporary. */
1858 tmp
= gfc_chainon_list (NULL_TREE
, ptemp1
);
1859 tmp
= gfc_build_function_call (gfor_fndecl_internal_free
, tmp
);
1860 gfc_add_expr_to_block (block
, tmp
);
1865 /* Translate pointer assignment inside FORALL which need temporary. */
1868 gfc_trans_pointer_assign_need_temp (gfc_expr
* expr1
, gfc_expr
* expr2
,
1869 forall_info
* nested_forall_info
,
1870 stmtblock_t
* block
)
1884 tree tmp
, tmp1
, ptemp1
;
1885 tree mask
, maskindex
;
1886 forall_info
*forall_tmp
;
1888 count
= gfc_create_var (gfc_array_index_type
, "count");
1889 gfc_add_modify_expr (block
, count
, gfc_index_zero_node
);
1891 inner_size
= integer_one_node
;
1892 lss
= gfc_walk_expr (expr1
);
1893 rss
= gfc_walk_expr (expr2
);
1894 if (lss
== gfc_ss_terminator
)
1896 type
= gfc_typenode_for_spec (&expr1
->ts
);
1897 type
= build_pointer_type (type
);
1899 /* Allocate temporary for nested forall construct according to the
1900 information in nested_forall_info and inner_size. */
1901 tmp1
= allocate_temp_for_forall_nest (nested_forall_info
,
1902 type
, inner_size
, block
, &ptemp1
);
1903 gfc_start_block (&body
);
1904 gfc_init_se (&lse
, NULL
);
1905 lse
.expr
= gfc_build_array_ref (tmp1
, count
);
1906 gfc_init_se (&rse
, NULL
);
1907 rse
.want_pointer
= 1;
1908 gfc_conv_expr (&rse
, expr2
);
1909 gfc_add_block_to_block (&body
, &rse
.pre
);
1910 gfc_add_modify_expr (&body
, lse
.expr
, rse
.expr
);
1911 gfc_add_block_to_block (&body
, &rse
.post
);
1913 /* Increment count. */
1914 tmp
= fold (build2 (PLUS_EXPR
, gfc_array_index_type
,
1915 count
, gfc_index_one_node
));
1916 gfc_add_modify_expr (&body
, count
, tmp
);
1918 tmp
= gfc_finish_block (&body
);
1920 /* Initialize the maskindexes. */
1921 forall_tmp
= nested_forall_info
;
1922 while (forall_tmp
!= NULL
)
1924 mask
= forall_tmp
->mask
;
1925 maskindex
= forall_tmp
->maskindex
;
1927 gfc_add_modify_expr (block
, maskindex
, gfc_index_zero_node
);
1928 forall_tmp
= forall_tmp
->next_nest
;
1931 /* Generate body and loops according to the inforamtion in
1932 nested_forall_info. */
1933 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, tmp
, 1, 1);
1934 gfc_add_expr_to_block (block
, tmp
);
1937 gfc_add_modify_expr (block
, count
, gfc_index_zero_node
);
1939 /* Reset maskindexes. */
1940 forall_tmp
= nested_forall_info
;
1941 while (forall_tmp
!= NULL
)
1943 mask
= forall_tmp
->mask
;
1944 maskindex
= forall_tmp
->maskindex
;
1946 gfc_add_modify_expr (block
, maskindex
, gfc_index_zero_node
);
1947 forall_tmp
= forall_tmp
->next_nest
;
1949 gfc_start_block (&body
);
1950 gfc_init_se (&lse
, NULL
);
1951 gfc_init_se (&rse
, NULL
);
1952 rse
.expr
= gfc_build_array_ref (tmp1
, count
);
1953 lse
.want_pointer
= 1;
1954 gfc_conv_expr (&lse
, expr1
);
1955 gfc_add_block_to_block (&body
, &lse
.pre
);
1956 gfc_add_modify_expr (&body
, lse
.expr
, rse
.expr
);
1957 gfc_add_block_to_block (&body
, &lse
.post
);
1958 /* Increment count. */
1959 tmp
= fold (build2 (PLUS_EXPR
, gfc_array_index_type
,
1960 count
, gfc_index_one_node
));
1961 gfc_add_modify_expr (&body
, count
, tmp
);
1962 tmp
= gfc_finish_block (&body
);
1964 /* Generate body and loops according to the inforamtion in
1965 nested_forall_info. */
1966 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, tmp
, 1, 1);
1967 gfc_add_expr_to_block (block
, tmp
);
1971 gfc_init_loopinfo (&loop
);
1973 /* Associate the SS with the loop. */
1974 gfc_add_ss_to_loop (&loop
, rss
);
1976 /* Setup the scalarizing loops and bounds. */
1977 gfc_conv_ss_startstride (&loop
);
1979 gfc_conv_loop_setup (&loop
);
1981 info
= &rss
->data
.info
;
1982 desc
= info
->descriptor
;
1984 /* Make a new descriptor. */
1985 parmtype
= gfc_get_element_type (TREE_TYPE (desc
));
1986 parmtype
= gfc_get_array_type_bounds (parmtype
, loop
.dimen
,
1987 loop
.from
, loop
.to
, 1);
1989 /* Allocate temporary for nested forall construct. */
1990 tmp1
= allocate_temp_for_forall_nest (nested_forall_info
, parmtype
,
1991 inner_size
, block
, &ptemp1
);
1992 gfc_start_block (&body
);
1993 gfc_init_se (&lse
, NULL
);
1994 lse
.expr
= gfc_build_array_ref (tmp1
, count
);
1995 lse
.direct_byref
= 1;
1996 rss
= gfc_walk_expr (expr2
);
1997 gfc_conv_expr_descriptor (&lse
, expr2
, rss
);
1999 gfc_add_block_to_block (&body
, &lse
.pre
);
2000 gfc_add_block_to_block (&body
, &lse
.post
);
2002 /* Increment count. */
2003 tmp
= fold (build2 (PLUS_EXPR
, gfc_array_index_type
,
2004 count
, gfc_index_one_node
));
2005 gfc_add_modify_expr (&body
, count
, tmp
);
2007 tmp
= gfc_finish_block (&body
);
2009 /* Initialize the maskindexes. */
2010 forall_tmp
= nested_forall_info
;
2011 while (forall_tmp
!= NULL
)
2013 mask
= forall_tmp
->mask
;
2014 maskindex
= forall_tmp
->maskindex
;
2016 gfc_add_modify_expr (block
, maskindex
, gfc_index_zero_node
);
2017 forall_tmp
= forall_tmp
->next_nest
;
2020 /* Generate body and loops according to the inforamtion in
2021 nested_forall_info. */
2022 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, tmp
, 1, 1);
2023 gfc_add_expr_to_block (block
, tmp
);
2026 gfc_add_modify_expr (block
, count
, gfc_index_zero_node
);
2028 /* Reset maskindexes. */
2029 forall_tmp
= nested_forall_info
;
2030 while (forall_tmp
!= NULL
)
2032 mask
= forall_tmp
->mask
;
2033 maskindex
= forall_tmp
->maskindex
;
2035 gfc_add_modify_expr (block
, maskindex
, gfc_index_zero_node
);
2036 forall_tmp
= forall_tmp
->next_nest
;
2038 parm
= gfc_build_array_ref (tmp1
, count
);
2039 lss
= gfc_walk_expr (expr1
);
2040 gfc_init_se (&lse
, NULL
);
2041 gfc_conv_expr_descriptor (&lse
, expr1
, lss
);
2042 gfc_add_modify_expr (&lse
.pre
, lse
.expr
, parm
);
2043 gfc_start_block (&body
);
2044 gfc_add_block_to_block (&body
, &lse
.pre
);
2045 gfc_add_block_to_block (&body
, &lse
.post
);
2047 /* Increment count. */
2048 tmp
= fold (build2 (PLUS_EXPR
, gfc_array_index_type
,
2049 count
, gfc_index_one_node
));
2050 gfc_add_modify_expr (&body
, count
, tmp
);
2052 tmp
= gfc_finish_block (&body
);
2054 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, tmp
, 1, 1);
2055 gfc_add_expr_to_block (block
, tmp
);
2057 /* Free the temporary. */
2060 tmp
= gfc_chainon_list (NULL_TREE
, ptemp1
);
2061 tmp
= gfc_build_function_call (gfor_fndecl_internal_free
, tmp
);
2062 gfc_add_expr_to_block (block
, tmp
);
2067 /* FORALL and WHERE statements are really nasty, especially when you nest
2068 them. All the rhs of a forall assignment must be evaluated before the
2069 actual assignments are performed. Presumably this also applies to all the
2070 assignments in an inner where statement. */
2072 /* Generate code for a FORALL statement. Any temporaries are allocated as a
2073 linear array, relying on the fact that we process in the same order in all
2076 forall (i=start:end:stride; maskexpr)
2080 (where e,f,g,h<i> are arbitary expressions possibly involving i)
2082 count = ((end + 1 - start) / staride)
2083 masktmp(:) = maskexpr(:)
2086 for (i = start; i <= end; i += stride)
2088 if (masktmp[maskindex++])
2092 for (i = start; i <= end; i += stride)
2094 if (masktmp[maskindex++])
2098 Note that this code only works when there are no dependencies.
2099 Forall loop with array assignments and data dependencies are a real pain,
2100 because the size of the temporary cannot always be determined before the
2101 loop is executed. This problem is compouded by the presence of nested
2106 gfc_trans_forall_1 (gfc_code
* code
, forall_info
* nested_forall_info
)
2128 gfc_forall_iterator
*fa
;
2131 gfc_saved_var
*saved_vars
;
2132 iter_info
*this_forall
, *iter_tmp
;
2133 forall_info
*info
, *forall_tmp
;
2134 temporary_list
*temp
;
2136 gfc_start_block (&block
);
2139 /* Count the FORALL index number. */
2140 for (fa
= code
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
2144 /* Allocate the space for var, start, end, step, varexpr. */
2145 var
= (tree
*) gfc_getmem (nvar
* sizeof (tree
));
2146 start
= (tree
*) gfc_getmem (nvar
* sizeof (tree
));
2147 end
= (tree
*) gfc_getmem (nvar
* sizeof (tree
));
2148 step
= (tree
*) gfc_getmem (nvar
* sizeof (tree
));
2149 varexpr
= (gfc_expr
**) gfc_getmem (nvar
* sizeof (gfc_expr
*));
2150 saved_vars
= (gfc_saved_var
*) gfc_getmem (nvar
* sizeof (gfc_saved_var
));
2152 /* Allocate the space for info. */
2153 info
= (forall_info
*) gfc_getmem (sizeof (forall_info
));
2155 for (fa
= code
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
2157 gfc_symbol
*sym
= fa
->var
->symtree
->n
.sym
;
2159 /* allocate space for this_forall. */
2160 this_forall
= (iter_info
*) gfc_getmem (sizeof (iter_info
));
2162 /* Create a temporary variable for the FORALL index. */
2163 tmp
= gfc_typenode_for_spec (&sym
->ts
);
2164 var
[n
] = gfc_create_var (tmp
, sym
->name
);
2165 gfc_shadow_sym (sym
, var
[n
], &saved_vars
[n
]);
2167 /* Record it in this_forall. */
2168 this_forall
->var
= var
[n
];
2170 /* Replace the index symbol's backend_decl with the temporary decl. */
2171 sym
->backend_decl
= var
[n
];
2173 /* Work out the start, end and stride for the loop. */
2174 gfc_init_se (&se
, NULL
);
2175 gfc_conv_expr_val (&se
, fa
->start
);
2176 /* Record it in this_forall. */
2177 this_forall
->start
= se
.expr
;
2178 gfc_add_block_to_block (&block
, &se
.pre
);
2181 gfc_init_se (&se
, NULL
);
2182 gfc_conv_expr_val (&se
, fa
->end
);
2183 /* Record it in this_forall. */
2184 this_forall
->end
= se
.expr
;
2185 gfc_make_safe_expr (&se
);
2186 gfc_add_block_to_block (&block
, &se
.pre
);
2189 gfc_init_se (&se
, NULL
);
2190 gfc_conv_expr_val (&se
, fa
->stride
);
2191 /* Record it in this_forall. */
2192 this_forall
->step
= se
.expr
;
2193 gfc_make_safe_expr (&se
);
2194 gfc_add_block_to_block (&block
, &se
.pre
);
2197 /* Set the NEXT field of this_forall to NULL. */
2198 this_forall
->next
= NULL
;
2199 /* Link this_forall to the info construct. */
2200 if (info
->this_loop
== NULL
)
2201 info
->this_loop
= this_forall
;
2204 iter_tmp
= info
->this_loop
;
2205 while (iter_tmp
->next
!= NULL
)
2206 iter_tmp
= iter_tmp
->next
;
2207 iter_tmp
->next
= this_forall
;
2214 /* Work out the number of elements in the mask array. */
2217 size
= gfc_index_one_node
;
2218 sizevar
= NULL_TREE
;
2220 for (n
= 0; n
< nvar
; n
++)
2222 if (lenvar
&& TREE_TYPE (lenvar
) != TREE_TYPE (start
[n
]))
2225 /* size = (end + step - start) / step. */
2226 tmp
= fold (build2 (MINUS_EXPR
, TREE_TYPE (start
[n
]),
2227 step
[n
], start
[n
]));
2228 tmp
= fold (build2 (PLUS_EXPR
, TREE_TYPE (end
[n
]), end
[n
], tmp
));
2230 tmp
= fold (build2 (FLOOR_DIV_EXPR
, TREE_TYPE (tmp
), tmp
, step
[n
]));
2231 tmp
= convert (gfc_array_index_type
, tmp
);
2233 size
= fold (build2 (MULT_EXPR
, gfc_array_index_type
, size
, tmp
));
2236 /* Record the nvar and size of current forall level. */
2240 /* Link the current forall level to nested_forall_info. */
2241 forall_tmp
= nested_forall_info
;
2242 if (forall_tmp
== NULL
)
2243 nested_forall_info
= info
;
2246 while (forall_tmp
->next_nest
!= NULL
)
2247 forall_tmp
= forall_tmp
->next_nest
;
2248 info
->outer
= forall_tmp
;
2249 forall_tmp
->next_nest
= info
;
2252 /* Copy the mask into a temporary variable if required.
2253 For now we assume a mask temporary is needed. */
2256 /* Allocate the mask temporary. */
2257 bytesize
= fold (build2 (MULT_EXPR
, gfc_array_index_type
, size
,
2258 TYPE_SIZE_UNIT (boolean_type_node
)));
2260 mask
= gfc_do_allocate (bytesize
, size
, &pmask
, &block
, boolean_type_node
);
2262 maskindex
= gfc_create_var_np (gfc_array_index_type
, "mi");
2263 /* Record them in the info structure. */
2264 info
->pmask
= pmask
;
2266 info
->maskindex
= maskindex
;
2268 gfc_add_modify_expr (&block
, maskindex
, gfc_index_zero_node
);
2270 /* Start of mask assignment loop body. */
2271 gfc_start_block (&body
);
2273 /* Evaluate the mask expression. */
2274 gfc_init_se (&se
, NULL
);
2275 gfc_conv_expr_val (&se
, code
->expr
);
2276 gfc_add_block_to_block (&body
, &se
.pre
);
2278 /* Store the mask. */
2279 se
.expr
= convert (boolean_type_node
, se
.expr
);
2282 tmp
= gfc_build_indirect_ref (mask
);
2285 tmp
= gfc_build_array_ref (tmp
, maskindex
);
2286 gfc_add_modify_expr (&body
, tmp
, se
.expr
);
2288 /* Advance to the next mask element. */
2289 tmp
= build2 (PLUS_EXPR
, gfc_array_index_type
,
2290 maskindex
, gfc_index_one_node
);
2291 gfc_add_modify_expr (&body
, maskindex
, tmp
);
2293 /* Generate the loops. */
2294 tmp
= gfc_finish_block (&body
);
2295 tmp
= gfc_trans_nested_forall_loop (info
, tmp
, 0, 0);
2296 gfc_add_expr_to_block (&block
, tmp
);
2300 /* No mask was specified. */
2301 maskindex
= NULL_TREE
;
2302 mask
= pmask
= NULL_TREE
;
2305 c
= code
->block
->next
;
2307 /* TODO: loop merging in FORALL statements. */
2308 /* Now that we've got a copy of the mask, generate the assignment loops. */
2314 /* A scalar or array assingment. */
2315 need_temp
= gfc_check_dependency (c
->expr
, c
->expr2
, varexpr
, nvar
);
2316 /* Teporaries due to array assignment data dependencies introduce
2317 no end of problems. */
2319 gfc_trans_assign_need_temp (c
->expr
, c
->expr2
, NULL
,
2320 nested_forall_info
, &block
);
2323 /* Use the normal assignment copying routines. */
2324 assign
= gfc_trans_assignment (c
->expr
, c
->expr2
);
2326 /* Reset the mask index. */
2328 gfc_add_modify_expr (&block
, maskindex
, gfc_index_zero_node
);
2330 /* Generate body and loops. */
2331 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, assign
, 1, 1);
2332 gfc_add_expr_to_block (&block
, tmp
);
2339 /* Translate WHERE or WHERE construct nested in FORALL. */
2341 gfc_trans_where_2 (c
, NULL
, NULL
, nested_forall_info
, &block
, &temp
);
2348 /* Free the temporary. */
2349 args
= gfc_chainon_list (NULL_TREE
, temp
->temporary
);
2350 tmp
= gfc_build_function_call (gfor_fndecl_internal_free
, args
);
2351 gfc_add_expr_to_block (&block
, tmp
);
2360 /* Pointer assignment inside FORALL. */
2361 case EXEC_POINTER_ASSIGN
:
2362 need_temp
= gfc_check_dependency (c
->expr
, c
->expr2
, varexpr
, nvar
);
2364 gfc_trans_pointer_assign_need_temp (c
->expr
, c
->expr2
,
2365 nested_forall_info
, &block
);
2368 /* Use the normal assignment copying routines. */
2369 assign
= gfc_trans_pointer_assignment (c
->expr
, c
->expr2
);
2371 /* Reset the mask index. */
2373 gfc_add_modify_expr (&block
, maskindex
, gfc_index_zero_node
);
2375 /* Generate body and loops. */
2376 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, assign
,
2378 gfc_add_expr_to_block (&block
, tmp
);
2383 tmp
= gfc_trans_forall_1 (c
, nested_forall_info
);
2384 gfc_add_expr_to_block (&block
, tmp
);
2395 /* Restore the original index variables. */
2396 for (fa
= code
->ext
.forall_iterator
, n
= 0; fa
; fa
= fa
->next
, n
++)
2397 gfc_restore_sym (fa
->var
->symtree
->n
.sym
, &saved_vars
[n
]);
2399 /* Free the space for var, start, end, step, varexpr. */
2405 gfc_free (saved_vars
);
2409 /* Free the temporary for the mask. */
2410 tmp
= gfc_chainon_list (NULL_TREE
, pmask
);
2411 tmp
= gfc_build_function_call (gfor_fndecl_internal_free
, tmp
);
2412 gfc_add_expr_to_block (&block
, tmp
);
2415 pushdecl (maskindex
);
2417 return gfc_finish_block (&block
);
2421 /* Translate the FORALL statement or construct. */
2423 tree
gfc_trans_forall (gfc_code
* code
)
2425 return gfc_trans_forall_1 (code
, NULL
);
2429 /* Evaluate the WHERE mask expression, copy its value to a temporary.
2430 If the WHERE construct is nested in FORALL, compute the overall temporary
2431 needed by the WHERE mask expression multiplied by the iterator number of
2433 ME is the WHERE mask expression.
2434 MASK is the temporary which value is mask's value.
2435 NMASK is another temporary which value is !mask.
2436 TEMP records the temporary's address allocated in this function in order to
2437 free them outside this function.
2438 MASK, NMASK and TEMP are all OUT arguments. */
2441 gfc_evaluate_where_mask (gfc_expr
* me
, forall_info
* nested_forall_info
,
2442 tree
* mask
, tree
* nmask
, temporary_list
** temp
,
2443 stmtblock_t
* block
)
2448 tree ptemp1
, ntmp
, ptemp2
;
2450 stmtblock_t body
, body1
;
2455 gfc_init_loopinfo (&loop
);
2457 /* Calculate the size of temporary needed by the mask-expr. */
2458 inner_size
= compute_inner_temp_size (me
, me
, block
, &lss
, &rss
);
2460 /* Allocate temporary for where mask. */
2461 tmp
= allocate_temp_for_forall_nest (nested_forall_info
, boolean_type_node
,
2462 inner_size
, block
, &ptemp1
);
2463 /* Record the temporary address in order to free it later. */
2466 temporary_list
*tempo
;
2467 tempo
= (temporary_list
*) gfc_getmem (sizeof (temporary_list
));
2468 tempo
->temporary
= ptemp1
;
2469 tempo
->next
= *temp
;
2473 /* Allocate temporary for !mask. */
2474 ntmp
= allocate_temp_for_forall_nest (nested_forall_info
, boolean_type_node
,
2475 inner_size
, block
, &ptemp2
);
2476 /* Record the temporary in order to free it later. */
2479 temporary_list
*tempo
;
2480 tempo
= (temporary_list
*) gfc_getmem (sizeof (temporary_list
));
2481 tempo
->temporary
= ptemp2
;
2482 tempo
->next
= *temp
;
2486 /* Variable to index the temporary. */
2487 count
= gfc_create_var (gfc_array_index_type
, "count");
2488 /* Initilize count. */
2489 gfc_add_modify_expr (block
, count
, gfc_index_zero_node
);
2491 gfc_start_block (&body
);
2493 gfc_init_se (&rse
, NULL
);
2494 gfc_init_se (&lse
, NULL
);
2496 if (lss
== gfc_ss_terminator
)
2498 gfc_init_block (&body1
);
2502 /* Initiliaze the loop. */
2503 gfc_init_loopinfo (&loop
);
2505 /* We may need LSS to determine the shape of the expression. */
2506 gfc_add_ss_to_loop (&loop
, lss
);
2507 gfc_add_ss_to_loop (&loop
, rss
);
2509 gfc_conv_ss_startstride (&loop
);
2510 gfc_conv_loop_setup (&loop
);
2512 gfc_mark_ss_chain_used (rss
, 1);
2513 /* Start the loop body. */
2514 gfc_start_scalarized_body (&loop
, &body1
);
2516 /* Translate the expression. */
2517 gfc_copy_loopinfo_to_se (&rse
, &loop
);
2519 gfc_conv_expr (&rse
, me
);
2521 /* Form the expression of the temporary. */
2522 lse
.expr
= gfc_build_array_ref (tmp
, count
);
2523 tmpexpr
= gfc_build_array_ref (ntmp
, count
);
2525 /* Use the scalar assignment to fill temporary TMP. */
2526 tmp1
= gfc_trans_scalar_assign (&lse
, &rse
, me
->ts
.type
);
2527 gfc_add_expr_to_block (&body1
, tmp1
);
2529 /* Fill temporary NTMP. */
2530 tmp1
= build1 (TRUTH_NOT_EXPR
, TREE_TYPE (lse
.expr
), lse
.expr
);
2531 gfc_add_modify_expr (&body1
, tmpexpr
, tmp1
);
2533 if (lss
== gfc_ss_terminator
)
2535 gfc_add_block_to_block (&body
, &body1
);
2539 /* Increment count. */
2540 tmp1
= fold (build2 (PLUS_EXPR
, gfc_array_index_type
, count
,
2541 gfc_index_one_node
));
2542 gfc_add_modify_expr (&body1
, count
, tmp1
);
2544 /* Generate the copying loops. */
2545 gfc_trans_scalarizing_loops (&loop
, &body1
);
2547 gfc_add_block_to_block (&body
, &loop
.pre
);
2548 gfc_add_block_to_block (&body
, &loop
.post
);
2550 gfc_cleanup_loop (&loop
);
2551 /* TODO: Reuse lss and rss when copying temp->lhs. Need to be careful
2552 as tree nodes in SS may not be valid in different scope. */
2555 tmp1
= gfc_finish_block (&body
);
2556 /* If the WHERE construct is inside FORALL, fill the full temporary. */
2557 if (nested_forall_info
!= NULL
)
2558 tmp1
= gfc_trans_nested_forall_loop (nested_forall_info
, tmp1
, 1, 1);
2561 gfc_add_expr_to_block (block
, tmp1
);
2570 /* Translate an assignment statement in a WHERE statement or construct
2571 statement. The MASK expression is used to control which elements
2572 of EXPR1 shall be assigned. */
2575 gfc_trans_where_assign (gfc_expr
*expr1
, gfc_expr
*expr2
, tree mask
,
2576 tree count1
, tree count2
)
2581 gfc_ss
*lss_section
;
2588 tree index
, maskexpr
, tmp1
;
2591 /* TODO: handle this special case.
2592 Special case a single function returning an array. */
2593 if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->rank
> 0)
2595 tmp
= gfc_trans_arrayfunc_assign (expr1
, expr2
);
2601 /* Assignment of the form lhs = rhs. */
2602 gfc_start_block (&block
);
2604 gfc_init_se (&lse
, NULL
);
2605 gfc_init_se (&rse
, NULL
);
2608 lss
= gfc_walk_expr (expr1
);
2611 /* In each where-assign-stmt, the mask-expr and the variable being
2612 defined shall be arrays of the same shape. */
2613 assert (lss
!= gfc_ss_terminator
);
2615 /* The assignment needs scalarization. */
2618 /* Find a non-scalar SS from the lhs. */
2619 while (lss_section
!= gfc_ss_terminator
2620 && lss_section
->type
!= GFC_SS_SECTION
)
2621 lss_section
= lss_section
->next
;
2623 assert (lss_section
!= gfc_ss_terminator
);
2625 /* Initialize the scalarizer. */
2626 gfc_init_loopinfo (&loop
);
2629 rss
= gfc_walk_expr (expr2
);
2630 if (rss
== gfc_ss_terminator
)
2632 /* The rhs is scalar. Add a ss for the expression. */
2633 rss
= gfc_get_ss ();
2634 rss
->next
= gfc_ss_terminator
;
2635 rss
->type
= GFC_SS_SCALAR
;
2639 /* Associate the SS with the loop. */
2640 gfc_add_ss_to_loop (&loop
, lss
);
2641 gfc_add_ss_to_loop (&loop
, rss
);
2643 /* Calculate the bounds of the scalarization. */
2644 gfc_conv_ss_startstride (&loop
);
2646 /* Resolve any data dependencies in the statement. */
2647 gfc_conv_resolve_dependencies (&loop
, lss_section
, rss
);
2649 /* Setup the scalarizing loops. */
2650 gfc_conv_loop_setup (&loop
);
2652 /* Setup the gfc_se structures. */
2653 gfc_copy_loopinfo_to_se (&lse
, &loop
);
2654 gfc_copy_loopinfo_to_se (&rse
, &loop
);
2657 gfc_mark_ss_chain_used (rss
, 1);
2658 if (loop
.temp_ss
== NULL
)
2661 gfc_mark_ss_chain_used (lss
, 1);
2665 lse
.ss
= loop
.temp_ss
;
2666 gfc_mark_ss_chain_used (lss
, 3);
2667 gfc_mark_ss_chain_used (loop
.temp_ss
, 3);
2670 /* Start the scalarized loop body. */
2671 gfc_start_scalarized_body (&loop
, &body
);
2673 /* Translate the expression. */
2674 gfc_conv_expr (&rse
, expr2
);
2675 if (lss
!= gfc_ss_terminator
&& loop
.temp_ss
!= NULL
)
2677 gfc_conv_tmp_array_ref (&lse
);
2678 gfc_advance_se_ss_chain (&lse
);
2681 gfc_conv_expr (&lse
, expr1
);
2683 /* Form the mask expression according to the mask tree list. */
2687 maskexpr
= gfc_build_array_ref (tmp
, index
);
2691 tmp
= TREE_CHAIN (tmp
);
2694 tmp1
= gfc_build_array_ref (tmp
, index
);
2695 maskexpr
= build2 (TRUTH_AND_EXPR
, TREE_TYPE (tmp1
), maskexpr
, tmp1
);
2696 tmp
= TREE_CHAIN (tmp
);
2698 /* Use the scalar assignment as is. */
2699 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
.type
);
2700 tmp
= build3_v (COND_EXPR
, maskexpr
, tmp
, build_empty_stmt ());
2702 gfc_add_expr_to_block (&body
, tmp
);
2704 if (lss
== gfc_ss_terminator
)
2706 /* Increment count1. */
2707 tmp
= fold (build2 (PLUS_EXPR
, gfc_array_index_type
,
2708 count1
, gfc_index_one_node
));
2709 gfc_add_modify_expr (&body
, count1
, tmp
);
2711 /* Use the scalar assignment as is. */
2712 gfc_add_block_to_block (&block
, &body
);
2716 if (lse
.ss
!= gfc_ss_terminator
)
2718 if (rse
.ss
!= gfc_ss_terminator
)
2721 if (loop
.temp_ss
!= NULL
)
2723 /* Increment count1 before finish the main body of a scalarized
2725 tmp
= fold (build2 (PLUS_EXPR
, gfc_array_index_type
,
2726 count1
, gfc_index_one_node
));
2727 gfc_add_modify_expr (&body
, count1
, tmp
);
2728 gfc_trans_scalarized_loop_boundary (&loop
, &body
);
2730 /* We need to copy the temporary to the actual lhs. */
2731 gfc_init_se (&lse
, NULL
);
2732 gfc_init_se (&rse
, NULL
);
2733 gfc_copy_loopinfo_to_se (&lse
, &loop
);
2734 gfc_copy_loopinfo_to_se (&rse
, &loop
);
2736 rse
.ss
= loop
.temp_ss
;
2739 gfc_conv_tmp_array_ref (&rse
);
2740 gfc_advance_se_ss_chain (&rse
);
2741 gfc_conv_expr (&lse
, expr1
);
2743 if (lse
.ss
!= gfc_ss_terminator
)
2746 if (rse
.ss
!= gfc_ss_terminator
)
2749 /* Form the mask expression according to the mask tree list. */
2753 maskexpr
= gfc_build_array_ref (tmp
, index
);
2757 tmp
= TREE_CHAIN (tmp
);
2760 tmp1
= gfc_build_array_ref (tmp
, index
);
2761 maskexpr
= build2 (TRUTH_AND_EXPR
, TREE_TYPE (tmp1
),
2763 tmp
= TREE_CHAIN (tmp
);
2765 /* Use the scalar assignment as is. */
2766 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
.type
);
2767 tmp
= build3_v (COND_EXPR
, maskexpr
, tmp
, build_empty_stmt ());
2768 gfc_add_expr_to_block (&body
, tmp
);
2770 /* Increment count2. */
2771 tmp
= fold (build2 (PLUS_EXPR
, gfc_array_index_type
,
2772 count2
, gfc_index_one_node
));
2773 gfc_add_modify_expr (&body
, count2
, tmp
);
2777 /* Increment count1. */
2778 tmp
= fold (build2 (PLUS_EXPR
, gfc_array_index_type
,
2779 count1
, gfc_index_one_node
));
2780 gfc_add_modify_expr (&body
, count1
, tmp
);
2783 /* Generate the copying loops. */
2784 gfc_trans_scalarizing_loops (&loop
, &body
);
2786 /* Wrap the whole thing up. */
2787 gfc_add_block_to_block (&block
, &loop
.pre
);
2788 gfc_add_block_to_block (&block
, &loop
.post
);
2789 gfc_cleanup_loop (&loop
);
2792 return gfc_finish_block (&block
);
2796 /* Translate the WHERE construct or statement.
2797 This fuction can be called iteratelly to translate the nested WHERE
2798 construct or statement.
2799 MASK is the control mask, and PMASK is the pending control mask.
2800 TEMP records the temporary address which must be freed later. */
2803 gfc_trans_where_2 (gfc_code
* code
, tree mask
, tree pmask
,
2804 forall_info
* nested_forall_info
, stmtblock_t
* block
,
2805 temporary_list
** temp
)
2811 tree tmp
, tmp1
, tmp2
;
2812 tree count1
, count2
;
2816 /* the WHERE statement or the WHERE construct statement. */
2817 cblock
= code
->block
;
2820 /* Has mask-expr. */
2823 /* Ensure that the WHERE mask be evaluated only once. */
2824 tmp2
= gfc_evaluate_where_mask (cblock
->expr
, nested_forall_info
,
2825 &tmp
, &tmp1
, temp
, block
);
2827 /* Set the control mask and the pending control mask. */
2828 /* It's a where-stmt. */
2834 /* It's a nested where-stmt. */
2835 else if (mask
&& pmask
== NULL
)
2838 /* Use the TREE_CHAIN to list the masks. */
2839 tmp2
= copy_list (mask
);
2840 pmask
= chainon (mask
, tmp1
);
2841 mask
= chainon (tmp2
, tmp
);
2843 /* It's a masked-elsewhere-stmt. */
2844 else if (mask
&& cblock
->expr
)
2847 tmp2
= copy_list (pmask
);
2850 tmp2
= chainon (tmp2
, tmp
);
2851 pmask
= chainon (mask
, tmp1
);
2855 /* It's a elsewhere-stmt. No mask-expr is present. */
2859 /* Get the assignment statement of a WHERE statement, or the first
2860 statement in where-body-construct of a WHERE construct. */
2861 cnext
= cblock
->next
;
2866 /* WHERE assignment statement. */
2868 expr1
= cnext
->expr
;
2869 expr2
= cnext
->expr2
;
2870 if (nested_forall_info
!= NULL
)
2875 nvar
= nested_forall_info
->nvar
;
2876 varexpr
= (gfc_expr
**)
2877 gfc_getmem (nvar
* sizeof (gfc_expr
*));
2878 need_temp
= gfc_check_dependency (expr1
, expr2
, varexpr
,
2881 gfc_trans_assign_need_temp (expr1
, expr2
, mask
,
2882 nested_forall_info
, block
);
2885 /* Variables to control maskexpr. */
2886 count1
= gfc_create_var (gfc_array_index_type
, "count1");
2887 count2
= gfc_create_var (gfc_array_index_type
, "count2");
2888 gfc_add_modify_expr (block
, count1
, gfc_index_zero_node
);
2889 gfc_add_modify_expr (block
, count2
, gfc_index_zero_node
);
2891 tmp
= gfc_trans_where_assign (expr1
, expr2
, mask
, count1
,
2893 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
,
2895 gfc_add_expr_to_block (block
, tmp
);
2900 /* Variables to control maskexpr. */
2901 count1
= gfc_create_var (gfc_array_index_type
, "count1");
2902 count2
= gfc_create_var (gfc_array_index_type
, "count2");
2903 gfc_add_modify_expr (block
, count1
, gfc_index_zero_node
);
2904 gfc_add_modify_expr (block
, count2
, gfc_index_zero_node
);
2906 tmp
= gfc_trans_where_assign (expr1
, expr2
, mask
, count1
,
2908 gfc_add_expr_to_block (block
, tmp
);
2913 /* WHERE or WHERE construct is part of a where-body-construct. */
2915 /* Ensure that MASK is not modified by next gfc_trans_where_2. */
2916 mask_copy
= copy_list (mask
);
2917 gfc_trans_where_2 (cnext
, mask_copy
, NULL
, nested_forall_info
,
2925 /* The next statement within the same where-body-construct. */
2926 cnext
= cnext
->next
;
2928 /* The next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt. */
2929 cblock
= cblock
->block
;
2934 /* As the WHERE or WHERE construct statement can be nested, we call
2935 gfc_trans_where_2 to do the translation, and pass the initial
2936 NULL values for both the control mask and the pending control mask. */
2939 gfc_trans_where (gfc_code
* code
)
2942 temporary_list
*temp
, *p
;
2946 gfc_start_block (&block
);
2949 gfc_trans_where_2 (code
, NULL
, NULL
, NULL
, &block
, &temp
);
2951 /* Add calls to free temporaries which were dynamically allocated. */
2954 args
= gfc_chainon_list (NULL_TREE
, temp
->temporary
);
2955 tmp
= gfc_build_function_call (gfor_fndecl_internal_free
, args
);
2956 gfc_add_expr_to_block (&block
, tmp
);
2962 return gfc_finish_block (&block
);
2966 /* CYCLE a DO loop. The label decl has already been created by
2967 gfc_trans_do(), it's in TREE_PURPOSE (backend_decl) of the gfc_code
2968 node at the head of the loop. We must mark the label as used. */
2971 gfc_trans_cycle (gfc_code
* code
)
2975 cycle_label
= TREE_PURPOSE (code
->ext
.whichloop
->backend_decl
);
2976 TREE_USED (cycle_label
) = 1;
2977 return build1_v (GOTO_EXPR
, cycle_label
);
2981 /* EXIT a DO loop. Similair to CYCLE, but now the label is in
2982 TREE_VALUE (backend_decl) of the gfc_code node at the head of the
2986 gfc_trans_exit (gfc_code
* code
)
2990 exit_label
= TREE_VALUE (code
->ext
.whichloop
->backend_decl
);
2991 TREE_USED (exit_label
) = 1;
2992 return build1_v (GOTO_EXPR
, exit_label
);
2996 /* Translate the ALLOCATE statement. */
2999 gfc_trans_allocate (gfc_code
* code
)
3012 if (!code
->ext
.alloc_list
)
3015 gfc_start_block (&block
);
3019 stat
= gfc_create_var (gfc_int4_type_node
, "stat");
3020 pstat
= gfc_build_addr_expr (NULL
, stat
);
3022 error_label
= gfc_build_label_decl (NULL_TREE
);
3023 TREE_USED (error_label
) = 1;
3027 pstat
= integer_zero_node
;
3028 stat
= error_label
= NULL_TREE
;
3032 for (al
= code
->ext
.alloc_list
; al
!= NULL
; al
= al
->next
)
3036 gfc_init_se (&se
, NULL
);
3037 gfc_start_block (&se
.pre
);
3039 se
.want_pointer
= 1;
3040 se
.descriptor_only
= 1;
3041 gfc_conv_expr (&se
, expr
);
3045 /* Find the last reference in the chain. */
3046 while (ref
&& ref
->next
!= NULL
)
3048 assert (ref
->type
!= REF_ARRAY
|| ref
->u
.ar
.type
== AR_ELEMENT
);
3052 if (ref
!= NULL
&& ref
->type
== REF_ARRAY
)
3055 gfc_array_allocate (&se
, ref
, pstat
);
3059 /* A scalar or derived type. */
3062 val
= gfc_create_var (ppvoid_type_node
, "ptr");
3063 tmp
= gfc_build_addr_expr (ppvoid_type_node
, se
.expr
);
3064 gfc_add_modify_expr (&se
.pre
, val
, tmp
);
3066 tmp
= TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (se
.expr
)));
3067 parm
= gfc_chainon_list (NULL_TREE
, val
);
3068 parm
= gfc_chainon_list (parm
, tmp
);
3069 parm
= gfc_chainon_list (parm
, pstat
);
3070 tmp
= gfc_build_function_call (gfor_fndecl_allocate
, parm
);
3071 gfc_add_expr_to_block (&se
.pre
, tmp
);
3075 tmp
= build1_v (GOTO_EXPR
, error_label
);
3077 build2 (NE_EXPR
, boolean_type_node
, stat
, integer_zero_node
);
3078 tmp
= build3_v (COND_EXPR
, parm
, tmp
, build_empty_stmt ());
3079 gfc_add_expr_to_block (&se
.pre
, tmp
);
3083 tmp
= gfc_finish_block (&se
.pre
);
3084 gfc_add_expr_to_block (&block
, tmp
);
3087 /* Assign the value to the status variable. */
3090 tmp
= build1_v (LABEL_EXPR
, error_label
);
3091 gfc_add_expr_to_block (&block
, tmp
);
3093 gfc_init_se (&se
, NULL
);
3094 gfc_conv_expr_lhs (&se
, code
->expr
);
3095 tmp
= convert (TREE_TYPE (se
.expr
), stat
);
3096 gfc_add_modify_expr (&block
, se
.expr
, tmp
);
3099 return gfc_finish_block (&block
);
3104 gfc_trans_deallocate (gfc_code
* code
)
3114 gfc_start_block (&block
);
3116 for (al
= code
->ext
.alloc_list
; al
!= NULL
; al
= al
->next
)
3119 assert (expr
->expr_type
== EXPR_VARIABLE
);
3121 gfc_init_se (&se
, NULL
);
3122 gfc_start_block (&se
.pre
);
3124 se
.want_pointer
= 1;
3125 se
.descriptor_only
= 1;
3126 gfc_conv_expr (&se
, expr
);
3128 if (expr
->symtree
->n
.sym
->attr
.dimension
)
3130 tmp
= gfc_array_deallocate (se
.expr
);
3131 gfc_add_expr_to_block (&se
.pre
, tmp
);
3135 type
= build_pointer_type (TREE_TYPE (se
.expr
));
3136 var
= gfc_create_var (type
, "ptr");
3137 tmp
= gfc_build_addr_expr (type
, se
.expr
);
3138 gfc_add_modify_expr (&se
.pre
, var
, tmp
);
3140 tmp
= gfc_chainon_list (NULL_TREE
, var
);
3141 tmp
= gfc_chainon_list (tmp
, integer_zero_node
);
3142 tmp
= gfc_build_function_call (gfor_fndecl_deallocate
, tmp
);
3143 gfc_add_expr_to_block (&se
.pre
, tmp
);
3145 tmp
= gfc_finish_block (&se
.pre
);
3146 gfc_add_expr_to_block (&block
, tmp
);
3149 return gfc_finish_block (&block
);