1 /* Statement translation -- generate GCC trees from gfc_code.
2 Copyright (C) 2002, 2003, 2004, 2005, 2006 Free Software Foundation,
4 Contributed by Paul Brook <paul@nowt.org>
5 and Steven Bosscher <s.bosscher@student.tudelft.nl>
7 This file is part of GCC.
9 GCC is free software; you can redistribute it and/or modify it under
10 the terms of the GNU General Public License as published by the Free
11 Software Foundation; either version 2, or (at your option) any later
14 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
15 WARRANTY; without even the implied warranty of MERCHANTABILITY or
16 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
19 You should have received a copy of the GNU General Public License
20 along with GCC; see the file COPYING. If not, write to the Free
21 Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
27 #include "coretypes.h"
29 #include "tree-gimple.h"
35 #include "trans-stmt.h"
36 #include "trans-types.h"
37 #include "trans-array.h"
38 #include "trans-const.h"
41 typedef struct iter_info
47 struct iter_info
*next
;
51 typedef struct temporary_list
54 struct temporary_list
*next
;
58 typedef struct forall_info
66 struct forall_info
*outer
;
67 struct forall_info
*next_nest
;
71 static void gfc_trans_where_2 (gfc_code
*, tree
, tree
, forall_info
*,
72 stmtblock_t
*, temporary_list
**temp
);
74 /* Translate a F95 label number to a LABEL_EXPR. */
77 gfc_trans_label_here (gfc_code
* code
)
79 return build1_v (LABEL_EXPR
, gfc_get_label_decl (code
->here
));
83 /* Given a variable expression which has been ASSIGNed to, find the decl
84 containing the auxiliary variables. For variables in common blocks this
88 gfc_conv_label_variable (gfc_se
* se
, gfc_expr
* expr
)
90 gcc_assert (expr
->symtree
->n
.sym
->attr
.assign
== 1);
91 gfc_conv_expr (se
, expr
);
92 /* Deals with variable in common block. Get the field declaration. */
93 if (TREE_CODE (se
->expr
) == COMPONENT_REF
)
94 se
->expr
= TREE_OPERAND (se
->expr
, 1);
95 /* Deals with dummy argument. Get the parameter declaration. */
96 else if (TREE_CODE (se
->expr
) == INDIRECT_REF
)
97 se
->expr
= TREE_OPERAND (se
->expr
, 0);
100 /* Translate a label assignment statement. */
103 gfc_trans_label_assign (gfc_code
* code
)
113 /* Start a new block. */
114 gfc_init_se (&se
, NULL
);
115 gfc_start_block (&se
.pre
);
116 gfc_conv_label_variable (&se
, code
->expr
);
118 len
= GFC_DECL_STRING_LEN (se
.expr
);
119 addr
= GFC_DECL_ASSIGN_ADDR (se
.expr
);
121 label_tree
= gfc_get_label_decl (code
->label
);
123 if (code
->label
->defined
== ST_LABEL_TARGET
)
125 label_tree
= gfc_build_addr_expr (pvoid_type_node
, label_tree
);
126 len_tree
= integer_minus_one_node
;
130 label_str
= code
->label
->format
->value
.character
.string
;
131 label_len
= code
->label
->format
->value
.character
.length
;
132 len_tree
= build_int_cst (NULL_TREE
, label_len
);
133 label_tree
= gfc_build_string_const (label_len
+ 1, label_str
);
134 label_tree
= gfc_build_addr_expr (pvoid_type_node
, label_tree
);
137 gfc_add_modify_expr (&se
.pre
, len
, len_tree
);
138 gfc_add_modify_expr (&se
.pre
, addr
, label_tree
);
140 return gfc_finish_block (&se
.pre
);
143 /* Translate a GOTO statement. */
146 gfc_trans_goto (gfc_code
* code
)
156 if (code
->label
!= NULL
)
157 return build1_v (GOTO_EXPR
, gfc_get_label_decl (code
->label
));
160 gfc_init_se (&se
, NULL
);
161 gfc_start_block (&se
.pre
);
162 gfc_conv_label_variable (&se
, code
->expr
);
164 gfc_build_cstring_const ("Assigned label is not a target label");
165 tmp
= GFC_DECL_STRING_LEN (se
.expr
);
166 tmp
= fold_build2 (NE_EXPR
, boolean_type_node
, tmp
,
167 build_int_cst (TREE_TYPE (tmp
), -1));
168 gfc_trans_runtime_check (tmp
, assign_error
, &se
.pre
);
170 assigned_goto
= GFC_DECL_ASSIGN_ADDR (se
.expr
);
175 target
= build1 (GOTO_EXPR
, void_type_node
, assigned_goto
);
176 gfc_add_expr_to_block (&se
.pre
, target
);
177 return gfc_finish_block (&se
.pre
);
180 /* Check the label list. */
181 range_error
= gfc_build_cstring_const ("Assigned label is not in the list");
185 target
= gfc_get_label_decl (code
->label
);
186 tmp
= gfc_build_addr_expr (pvoid_type_node
, target
);
187 tmp
= build2 (EQ_EXPR
, boolean_type_node
, tmp
, assigned_goto
);
188 tmp
= build3_v (COND_EXPR
, tmp
,
189 build1 (GOTO_EXPR
, void_type_node
, target
),
190 build_empty_stmt ());
191 gfc_add_expr_to_block (&se
.pre
, tmp
);
194 while (code
!= NULL
);
195 gfc_trans_runtime_check (boolean_true_node
, range_error
, &se
.pre
);
196 return gfc_finish_block (&se
.pre
);
200 /* Translate an ENTRY statement. Just adds a label for this entry point. */
202 gfc_trans_entry (gfc_code
* code
)
204 return build1_v (LABEL_EXPR
, code
->ext
.entry
->label
);
208 /* Translate the CALL statement. Builds a call to an F95 subroutine. */
211 gfc_trans_call (gfc_code
* code
)
215 int has_alternate_specifier
;
217 /* A CALL starts a new block because the actual arguments may have to
218 be evaluated first. */
219 gfc_init_se (&se
, NULL
);
220 gfc_start_block (&se
.pre
);
222 gcc_assert (code
->resolved_sym
);
224 ss
= gfc_ss_terminator
;
225 if (code
->resolved_sym
->attr
.elemental
)
226 ss
= gfc_walk_elemental_function_args (ss
, code
->ext
.actual
, GFC_SS_REFERENCE
);
228 /* Is not an elemental subroutine call with array valued arguments. */
229 if (ss
== gfc_ss_terminator
)
232 /* Translate the call. */
233 has_alternate_specifier
234 = gfc_conv_function_call (&se
, code
->resolved_sym
, code
->ext
.actual
);
236 /* A subroutine without side-effect, by definition, does nothing! */
237 TREE_SIDE_EFFECTS (se
.expr
) = 1;
239 /* Chain the pieces together and return the block. */
240 if (has_alternate_specifier
)
242 gfc_code
*select_code
;
244 select_code
= code
->next
;
245 gcc_assert(select_code
->op
== EXEC_SELECT
);
246 sym
= select_code
->expr
->symtree
->n
.sym
;
247 se
.expr
= convert (gfc_typenode_for_spec (&sym
->ts
), se
.expr
);
248 gfc_add_modify_expr (&se
.pre
, sym
->backend_decl
, se
.expr
);
251 gfc_add_expr_to_block (&se
.pre
, se
.expr
);
253 gfc_add_block_to_block (&se
.pre
, &se
.post
);
258 /* An elemental subroutine call with array valued arguments has
265 /* gfc_walk_elemental_function_args renders the ss chain in the
266 reverse order to the actual argument order. */
267 ss
= gfc_reverse_ss (ss
);
269 /* Initialize the loop. */
270 gfc_init_se (&loopse
, NULL
);
271 gfc_init_loopinfo (&loop
);
272 gfc_add_ss_to_loop (&loop
, ss
);
274 gfc_conv_ss_startstride (&loop
);
275 gfc_conv_loop_setup (&loop
);
276 gfc_mark_ss_chain_used (ss
, 1);
278 /* Generate the loop body. */
279 gfc_start_scalarized_body (&loop
, &body
);
280 gfc_init_block (&block
);
281 gfc_copy_loopinfo_to_se (&loopse
, &loop
);
284 /* Add the subroutine call to the block. */
285 gfc_conv_function_call (&loopse
, code
->resolved_sym
, code
->ext
.actual
);
286 gfc_add_expr_to_block (&loopse
.pre
, loopse
.expr
);
288 gfc_add_block_to_block (&block
, &loopse
.pre
);
289 gfc_add_block_to_block (&block
, &loopse
.post
);
291 /* Finish up the loop block and the loop. */
292 gfc_add_expr_to_block (&body
, gfc_finish_block (&block
));
293 gfc_trans_scalarizing_loops (&loop
, &body
);
294 gfc_add_block_to_block (&se
.pre
, &loop
.pre
);
295 gfc_add_block_to_block (&se
.pre
, &loop
.post
);
296 gfc_cleanup_loop (&loop
);
299 return gfc_finish_block (&se
.pre
);
303 /* Translate the RETURN statement. */
306 gfc_trans_return (gfc_code
* code ATTRIBUTE_UNUSED
)
314 /* if code->expr is not NULL, this return statement must appear
315 in a subroutine and current_fake_result_decl has already
318 result
= gfc_get_fake_result_decl (NULL
);
321 gfc_warning ("An alternate return at %L without a * dummy argument",
323 return build1_v (GOTO_EXPR
, gfc_get_return_label ());
326 /* Start a new block for this statement. */
327 gfc_init_se (&se
, NULL
);
328 gfc_start_block (&se
.pre
);
330 gfc_conv_expr (&se
, code
->expr
);
332 tmp
= build2 (MODIFY_EXPR
, TREE_TYPE (result
), result
, se
.expr
);
333 gfc_add_expr_to_block (&se
.pre
, tmp
);
335 tmp
= build1_v (GOTO_EXPR
, gfc_get_return_label ());
336 gfc_add_expr_to_block (&se
.pre
, tmp
);
337 gfc_add_block_to_block (&se
.pre
, &se
.post
);
338 return gfc_finish_block (&se
.pre
);
341 return build1_v (GOTO_EXPR
, gfc_get_return_label ());
345 /* Translate the PAUSE statement. We have to translate this statement
346 to a runtime library call. */
349 gfc_trans_pause (gfc_code
* code
)
351 tree gfc_int4_type_node
= gfc_get_int_type (4);
357 /* Start a new block for this statement. */
358 gfc_init_se (&se
, NULL
);
359 gfc_start_block (&se
.pre
);
362 if (code
->expr
== NULL
)
364 tmp
= build_int_cst (gfc_int4_type_node
, code
->ext
.stop_code
);
365 args
= gfc_chainon_list (NULL_TREE
, tmp
);
366 fndecl
= gfor_fndecl_pause_numeric
;
370 gfc_conv_expr_reference (&se
, code
->expr
);
371 args
= gfc_chainon_list (NULL_TREE
, se
.expr
);
372 args
= gfc_chainon_list (args
, se
.string_length
);
373 fndecl
= gfor_fndecl_pause_string
;
376 tmp
= build_function_call_expr (fndecl
, args
);
377 gfc_add_expr_to_block (&se
.pre
, tmp
);
379 gfc_add_block_to_block (&se
.pre
, &se
.post
);
381 return gfc_finish_block (&se
.pre
);
385 /* Translate the STOP statement. We have to translate this statement
386 to a runtime library call. */
389 gfc_trans_stop (gfc_code
* code
)
391 tree gfc_int4_type_node
= gfc_get_int_type (4);
397 /* Start a new block for this statement. */
398 gfc_init_se (&se
, NULL
);
399 gfc_start_block (&se
.pre
);
402 if (code
->expr
== NULL
)
404 tmp
= build_int_cst (gfc_int4_type_node
, code
->ext
.stop_code
);
405 args
= gfc_chainon_list (NULL_TREE
, tmp
);
406 fndecl
= gfor_fndecl_stop_numeric
;
410 gfc_conv_expr_reference (&se
, code
->expr
);
411 args
= gfc_chainon_list (NULL_TREE
, se
.expr
);
412 args
= gfc_chainon_list (args
, se
.string_length
);
413 fndecl
= gfor_fndecl_stop_string
;
416 tmp
= build_function_call_expr (fndecl
, args
);
417 gfc_add_expr_to_block (&se
.pre
, tmp
);
419 gfc_add_block_to_block (&se
.pre
, &se
.post
);
421 return gfc_finish_block (&se
.pre
);
425 /* Generate GENERIC for the IF construct. This function also deals with
426 the simple IF statement, because the front end translates the IF
427 statement into an IF construct.
459 where COND_S is the simplified version of the predicate. PRE_COND_S
460 are the pre side-effects produced by the translation of the
462 We need to build the chain recursively otherwise we run into
463 problems with folding incomplete statements. */
466 gfc_trans_if_1 (gfc_code
* code
)
471 /* Check for an unconditional ELSE clause. */
473 return gfc_trans_code (code
->next
);
475 /* Initialize a statement builder for each block. Puts in NULL_TREEs. */
476 gfc_init_se (&if_se
, NULL
);
477 gfc_start_block (&if_se
.pre
);
479 /* Calculate the IF condition expression. */
480 gfc_conv_expr_val (&if_se
, code
->expr
);
482 /* Translate the THEN clause. */
483 stmt
= gfc_trans_code (code
->next
);
485 /* Translate the ELSE clause. */
487 elsestmt
= gfc_trans_if_1 (code
->block
);
489 elsestmt
= build_empty_stmt ();
491 /* Build the condition expression and add it to the condition block. */
492 stmt
= fold_build3 (COND_EXPR
, void_type_node
, if_se
.expr
, stmt
, elsestmt
);
494 gfc_add_expr_to_block (&if_se
.pre
, stmt
);
496 /* Finish off this statement. */
497 return gfc_finish_block (&if_se
.pre
);
501 gfc_trans_if (gfc_code
* code
)
503 /* Ignore the top EXEC_IF, it only announces an IF construct. The
504 actual code we must translate is in code->block. */
506 return gfc_trans_if_1 (code
->block
);
510 /* Translage an arithmetic IF expression.
512 IF (cond) label1, label2, label3 translates to
524 An optimized version can be generated in case of equal labels.
525 E.g., if label1 is equal to label2, we can translate it to
534 gfc_trans_arithmetic_if (gfc_code
* code
)
542 /* Start a new block. */
543 gfc_init_se (&se
, NULL
);
544 gfc_start_block (&se
.pre
);
546 /* Pre-evaluate COND. */
547 gfc_conv_expr_val (&se
, code
->expr
);
549 /* Build something to compare with. */
550 zero
= gfc_build_const (TREE_TYPE (se
.expr
), integer_zero_node
);
552 if (code
->label
->value
!= code
->label2
->value
)
554 /* If (cond < 0) take branch1 else take branch2.
555 First build jumps to the COND .LT. 0 and the COND .EQ. 0 cases. */
556 branch1
= build1_v (GOTO_EXPR
, gfc_get_label_decl (code
->label
));
557 branch2
= build1_v (GOTO_EXPR
, gfc_get_label_decl (code
->label2
));
559 if (code
->label
->value
!= code
->label3
->value
)
560 tmp
= fold_build2 (LT_EXPR
, boolean_type_node
, se
.expr
, zero
);
562 tmp
= fold_build2 (NE_EXPR
, boolean_type_node
, se
.expr
, zero
);
564 branch1
= fold_build3 (COND_EXPR
, void_type_node
, tmp
, branch1
, branch2
);
567 branch1
= build1_v (GOTO_EXPR
, gfc_get_label_decl (code
->label
));
569 if (code
->label
->value
!= code
->label3
->value
570 && code
->label2
->value
!= code
->label3
->value
)
572 /* if (cond <= 0) take branch1 else take branch2. */
573 branch2
= build1_v (GOTO_EXPR
, gfc_get_label_decl (code
->label3
));
574 tmp
= fold_build2 (LE_EXPR
, boolean_type_node
, se
.expr
, zero
);
575 branch1
= fold_build3 (COND_EXPR
, void_type_node
, tmp
, branch1
, branch2
);
578 /* Append the COND_EXPR to the evaluation of COND, and return. */
579 gfc_add_expr_to_block (&se
.pre
, branch1
);
580 return gfc_finish_block (&se
.pre
);
584 /* Translate the simple DO construct. This is where the loop variable has
585 integer type and step +-1. We can't use this in the general case
586 because integer overflow and floating point errors could give incorrect
588 We translate a do loop from:
590 DO dovar = from, to, step
596 [Evaluate loop bounds and step]
598 if ((step > 0) ? (dovar <= to) : (dovar => to))
604 cond = (dovar == to);
606 if (cond) goto end_label;
611 This helps the optimizers by avoiding the extra induction variable
612 used in the general case. */
615 gfc_trans_simple_do (gfc_code
* code
, stmtblock_t
*pblock
, tree dovar
,
616 tree from
, tree to
, tree step
)
625 type
= TREE_TYPE (dovar
);
627 /* Initialize the DO variable: dovar = from. */
628 gfc_add_modify_expr (pblock
, dovar
, from
);
630 /* Cycle and exit statements are implemented with gotos. */
631 cycle_label
= gfc_build_label_decl (NULL_TREE
);
632 exit_label
= gfc_build_label_decl (NULL_TREE
);
634 /* Put the labels where they can be found later. See gfc_trans_do(). */
635 code
->block
->backend_decl
= tree_cons (cycle_label
, exit_label
, NULL
);
638 gfc_start_block (&body
);
640 /* Main loop body. */
641 tmp
= gfc_trans_code (code
->block
->next
);
642 gfc_add_expr_to_block (&body
, tmp
);
644 /* Label for cycle statements (if needed). */
645 if (TREE_USED (cycle_label
))
647 tmp
= build1_v (LABEL_EXPR
, cycle_label
);
648 gfc_add_expr_to_block (&body
, tmp
);
651 /* Evaluate the loop condition. */
652 cond
= fold_build2 (EQ_EXPR
, boolean_type_node
, dovar
, to
);
653 cond
= gfc_evaluate_now (cond
, &body
);
655 /* Increment the loop variable. */
656 tmp
= fold_build2 (PLUS_EXPR
, type
, dovar
, step
);
657 gfc_add_modify_expr (&body
, dovar
, tmp
);
660 tmp
= build1_v (GOTO_EXPR
, exit_label
);
661 TREE_USED (exit_label
) = 1;
662 tmp
= fold_build3 (COND_EXPR
, void_type_node
,
663 cond
, tmp
, build_empty_stmt ());
664 gfc_add_expr_to_block (&body
, tmp
);
666 /* Finish the loop body. */
667 tmp
= gfc_finish_block (&body
);
668 tmp
= build1_v (LOOP_EXPR
, tmp
);
670 /* Only execute the loop if the number of iterations is positive. */
671 if (tree_int_cst_sgn (step
) > 0)
672 cond
= fold_build2 (LE_EXPR
, boolean_type_node
, dovar
, to
);
674 cond
= fold_build2 (GE_EXPR
, boolean_type_node
, dovar
, to
);
675 tmp
= fold_build3 (COND_EXPR
, void_type_node
,
676 cond
, tmp
, build_empty_stmt ());
677 gfc_add_expr_to_block (pblock
, tmp
);
679 /* Add the exit label. */
680 tmp
= build1_v (LABEL_EXPR
, exit_label
);
681 gfc_add_expr_to_block (pblock
, tmp
);
683 return gfc_finish_block (pblock
);
686 /* Translate the DO construct. This obviously is one of the most
687 important ones to get right with any compiler, but especially
690 We special case some loop forms as described in gfc_trans_simple_do.
691 For other cases we implement them with a separate loop count,
692 as described in the standard.
694 We translate a do loop from:
696 DO dovar = from, to, step
702 [evaluate loop bounds and step]
703 count = to + step - from;
711 if (count <=0) goto exit_label;
715 TODO: Large loop counts
716 The code above assumes the loop count fits into a signed integer kind,
717 i.e. Does not work for loop counts > 2^31 for integer(kind=4) variables
718 We must support the full range. */
721 gfc_trans_do (gfc_code
* code
)
738 gfc_start_block (&block
);
740 /* Evaluate all the expressions in the iterator. */
741 gfc_init_se (&se
, NULL
);
742 gfc_conv_expr_lhs (&se
, code
->ext
.iterator
->var
);
743 gfc_add_block_to_block (&block
, &se
.pre
);
745 type
= TREE_TYPE (dovar
);
747 gfc_init_se (&se
, NULL
);
748 gfc_conv_expr_val (&se
, code
->ext
.iterator
->start
);
749 gfc_add_block_to_block (&block
, &se
.pre
);
750 from
= gfc_evaluate_now (se
.expr
, &block
);
752 gfc_init_se (&se
, NULL
);
753 gfc_conv_expr_val (&se
, code
->ext
.iterator
->end
);
754 gfc_add_block_to_block (&block
, &se
.pre
);
755 to
= gfc_evaluate_now (se
.expr
, &block
);
757 gfc_init_se (&se
, NULL
);
758 gfc_conv_expr_val (&se
, code
->ext
.iterator
->step
);
759 gfc_add_block_to_block (&block
, &se
.pre
);
760 step
= gfc_evaluate_now (se
.expr
, &block
);
762 /* Special case simple loops. */
763 if (TREE_CODE (type
) == INTEGER_TYPE
764 && (integer_onep (step
)
765 || tree_int_cst_equal (step
, integer_minus_one_node
)))
766 return gfc_trans_simple_do (code
, &block
, dovar
, from
, to
, step
);
768 /* Initialize loop count. This code is executed before we enter the
769 loop body. We generate: count = (to + step - from) / step. */
771 tmp
= fold_build2 (MINUS_EXPR
, type
, step
, from
);
772 tmp
= fold_build2 (PLUS_EXPR
, type
, to
, tmp
);
773 if (TREE_CODE (type
) == INTEGER_TYPE
)
775 tmp
= fold_build2 (TRUNC_DIV_EXPR
, type
, tmp
, step
);
776 count
= gfc_create_var (type
, "count");
780 /* TODO: We could use the same width as the real type.
781 This would probably cause more problems that it solves
782 when we implement "long double" types. */
783 tmp
= fold_build2 (RDIV_EXPR
, type
, tmp
, step
);
784 tmp
= fold_build1 (FIX_TRUNC_EXPR
, gfc_array_index_type
, tmp
);
785 count
= gfc_create_var (gfc_array_index_type
, "count");
787 gfc_add_modify_expr (&block
, count
, tmp
);
789 count_one
= convert (TREE_TYPE (count
), integer_one_node
);
791 /* Initialize the DO variable: dovar = from. */
792 gfc_add_modify_expr (&block
, dovar
, from
);
795 gfc_start_block (&body
);
797 /* Cycle and exit statements are implemented with gotos. */
798 cycle_label
= gfc_build_label_decl (NULL_TREE
);
799 exit_label
= gfc_build_label_decl (NULL_TREE
);
801 /* Start with the loop condition. Loop until count <= 0. */
802 cond
= fold_build2 (LE_EXPR
, boolean_type_node
, count
,
803 build_int_cst (TREE_TYPE (count
), 0));
804 tmp
= build1_v (GOTO_EXPR
, exit_label
);
805 TREE_USED (exit_label
) = 1;
806 tmp
= fold_build3 (COND_EXPR
, void_type_node
,
807 cond
, tmp
, build_empty_stmt ());
808 gfc_add_expr_to_block (&body
, tmp
);
810 /* Put these labels where they can be found later. We put the
811 labels in a TREE_LIST node (because TREE_CHAIN is already
812 used). cycle_label goes in TREE_PURPOSE (backend_decl), exit
813 label in TREE_VALUE (backend_decl). */
815 code
->block
->backend_decl
= tree_cons (cycle_label
, exit_label
, NULL
);
817 /* Main loop body. */
818 tmp
= gfc_trans_code (code
->block
->next
);
819 gfc_add_expr_to_block (&body
, tmp
);
821 /* Label for cycle statements (if needed). */
822 if (TREE_USED (cycle_label
))
824 tmp
= build1_v (LABEL_EXPR
, cycle_label
);
825 gfc_add_expr_to_block (&body
, tmp
);
828 /* Increment the loop variable. */
829 tmp
= build2 (PLUS_EXPR
, type
, dovar
, step
);
830 gfc_add_modify_expr (&body
, dovar
, tmp
);
832 /* Decrement the loop count. */
833 tmp
= build2 (MINUS_EXPR
, TREE_TYPE (count
), count
, count_one
);
834 gfc_add_modify_expr (&body
, count
, tmp
);
836 /* End of loop body. */
837 tmp
= gfc_finish_block (&body
);
839 /* The for loop itself. */
840 tmp
= build1_v (LOOP_EXPR
, tmp
);
841 gfc_add_expr_to_block (&block
, tmp
);
843 /* Add the exit label. */
844 tmp
= build1_v (LABEL_EXPR
, exit_label
);
845 gfc_add_expr_to_block (&block
, tmp
);
847 return gfc_finish_block (&block
);
851 /* Translate the DO WHILE construct.
864 if (! cond) goto exit_label;
870 Because the evaluation of the exit condition `cond' may have side
871 effects, we can't do much for empty loop bodies. The backend optimizers
872 should be smart enough to eliminate any dead loops. */
875 gfc_trans_do_while (gfc_code
* code
)
883 /* Everything we build here is part of the loop body. */
884 gfc_start_block (&block
);
886 /* Cycle and exit statements are implemented with gotos. */
887 cycle_label
= gfc_build_label_decl (NULL_TREE
);
888 exit_label
= gfc_build_label_decl (NULL_TREE
);
890 /* Put the labels where they can be found later. See gfc_trans_do(). */
891 code
->block
->backend_decl
= tree_cons (cycle_label
, exit_label
, NULL
);
893 /* Create a GIMPLE version of the exit condition. */
894 gfc_init_se (&cond
, NULL
);
895 gfc_conv_expr_val (&cond
, code
->expr
);
896 gfc_add_block_to_block (&block
, &cond
.pre
);
897 cond
.expr
= fold_build1 (TRUTH_NOT_EXPR
, boolean_type_node
, cond
.expr
);
899 /* Build "IF (! cond) GOTO exit_label". */
900 tmp
= build1_v (GOTO_EXPR
, exit_label
);
901 TREE_USED (exit_label
) = 1;
902 tmp
= fold_build3 (COND_EXPR
, void_type_node
,
903 cond
.expr
, tmp
, build_empty_stmt ());
904 gfc_add_expr_to_block (&block
, tmp
);
906 /* The main body of the loop. */
907 tmp
= gfc_trans_code (code
->block
->next
);
908 gfc_add_expr_to_block (&block
, tmp
);
910 /* Label for cycle statements (if needed). */
911 if (TREE_USED (cycle_label
))
913 tmp
= build1_v (LABEL_EXPR
, cycle_label
);
914 gfc_add_expr_to_block (&block
, tmp
);
917 /* End of loop body. */
918 tmp
= gfc_finish_block (&block
);
920 gfc_init_block (&block
);
921 /* Build the loop. */
922 tmp
= build1_v (LOOP_EXPR
, tmp
);
923 gfc_add_expr_to_block (&block
, tmp
);
925 /* Add the exit label. */
926 tmp
= build1_v (LABEL_EXPR
, exit_label
);
927 gfc_add_expr_to_block (&block
, tmp
);
929 return gfc_finish_block (&block
);
933 /* Translate the SELECT CASE construct for INTEGER case expressions,
934 without killing all potential optimizations. The problem is that
935 Fortran allows unbounded cases, but the back-end does not, so we
936 need to intercept those before we enter the equivalent SWITCH_EXPR
939 For example, we translate this,
942 CASE (:100,101,105:115)
952 to the GENERIC equivalent,
956 case (minimum value for typeof(expr) ... 100:
962 case 200 ... (maximum value for typeof(expr):
979 gfc_trans_integer_select (gfc_code
* code
)
989 gfc_start_block (&block
);
991 /* Calculate the switch expression. */
992 gfc_init_se (&se
, NULL
);
993 gfc_conv_expr_val (&se
, code
->expr
);
994 gfc_add_block_to_block (&block
, &se
.pre
);
996 end_label
= gfc_build_label_decl (NULL_TREE
);
998 gfc_init_block (&body
);
1000 for (c
= code
->block
; c
; c
= c
->block
)
1002 for (cp
= c
->ext
.case_list
; cp
; cp
= cp
->next
)
1007 /* Assume it's the default case. */
1008 low
= high
= NULL_TREE
;
1012 low
= gfc_conv_constant_to_tree (cp
->low
);
1014 /* If there's only a lower bound, set the high bound to the
1015 maximum value of the case expression. */
1017 high
= TYPE_MAX_VALUE (TREE_TYPE (se
.expr
));
1022 /* Three cases are possible here:
1024 1) There is no lower bound, e.g. CASE (:N).
1025 2) There is a lower bound .NE. high bound, that is
1026 a case range, e.g. CASE (N:M) where M>N (we make
1027 sure that M>N during type resolution).
1028 3) There is a lower bound, and it has the same value
1029 as the high bound, e.g. CASE (N:N). This is our
1030 internal representation of CASE(N).
1032 In the first and second case, we need to set a value for
1033 high. In the thirth case, we don't because the GCC middle
1034 end represents a single case value by just letting high be
1035 a NULL_TREE. We can't do that because we need to be able
1036 to represent unbounded cases. */
1040 && mpz_cmp (cp
->low
->value
.integer
,
1041 cp
->high
->value
.integer
) != 0))
1042 high
= gfc_conv_constant_to_tree (cp
->high
);
1044 /* Unbounded case. */
1046 low
= TYPE_MIN_VALUE (TREE_TYPE (se
.expr
));
1049 /* Build a label. */
1050 label
= gfc_build_label_decl (NULL_TREE
);
1052 /* Add this case label.
1053 Add parameter 'label', make it match GCC backend. */
1054 tmp
= build3 (CASE_LABEL_EXPR
, void_type_node
, low
, high
, label
);
1055 gfc_add_expr_to_block (&body
, tmp
);
1058 /* Add the statements for this case. */
1059 tmp
= gfc_trans_code (c
->next
);
1060 gfc_add_expr_to_block (&body
, tmp
);
1062 /* Break to the end of the construct. */
1063 tmp
= build1_v (GOTO_EXPR
, end_label
);
1064 gfc_add_expr_to_block (&body
, tmp
);
1067 tmp
= gfc_finish_block (&body
);
1068 tmp
= build3_v (SWITCH_EXPR
, se
.expr
, tmp
, NULL_TREE
);
1069 gfc_add_expr_to_block (&block
, tmp
);
1071 tmp
= build1_v (LABEL_EXPR
, end_label
);
1072 gfc_add_expr_to_block (&block
, tmp
);
1074 return gfc_finish_block (&block
);
1078 /* Translate the SELECT CASE construct for LOGICAL case expressions.
1080 There are only two cases possible here, even though the standard
1081 does allow three cases in a LOGICAL SELECT CASE construct: .TRUE.,
1082 .FALSE., and DEFAULT.
1084 We never generate more than two blocks here. Instead, we always
1085 try to eliminate the DEFAULT case. This way, we can translate this
1086 kind of SELECT construct to a simple
1090 expression in GENERIC. */
1093 gfc_trans_logical_select (gfc_code
* code
)
1096 gfc_code
*t
, *f
, *d
;
1101 /* Assume we don't have any cases at all. */
1104 /* Now see which ones we actually do have. We can have at most two
1105 cases in a single case list: one for .TRUE. and one for .FALSE.
1106 The default case is always separate. If the cases for .TRUE. and
1107 .FALSE. are in the same case list, the block for that case list
1108 always executed, and we don't generate code a COND_EXPR. */
1109 for (c
= code
->block
; c
; c
= c
->block
)
1111 for (cp
= c
->ext
.case_list
; cp
; cp
= cp
->next
)
1115 if (cp
->low
->value
.logical
== 0) /* .FALSE. */
1117 else /* if (cp->value.logical != 0), thus .TRUE. */
1125 /* Start a new block. */
1126 gfc_start_block (&block
);
1128 /* Calculate the switch expression. We always need to do this
1129 because it may have side effects. */
1130 gfc_init_se (&se
, NULL
);
1131 gfc_conv_expr_val (&se
, code
->expr
);
1132 gfc_add_block_to_block (&block
, &se
.pre
);
1134 if (t
== f
&& t
!= NULL
)
1136 /* Cases for .TRUE. and .FALSE. are in the same block. Just
1137 translate the code for these cases, append it to the current
1139 gfc_add_expr_to_block (&block
, gfc_trans_code (t
->next
));
1143 tree true_tree
, false_tree
, stmt
;
1145 true_tree
= build_empty_stmt ();
1146 false_tree
= build_empty_stmt ();
1148 /* If we have a case for .TRUE. and for .FALSE., discard the default case.
1149 Otherwise, if .TRUE. or .FALSE. is missing and there is a default case,
1150 make the missing case the default case. */
1151 if (t
!= NULL
&& f
!= NULL
)
1161 /* Translate the code for each of these blocks, and append it to
1162 the current block. */
1164 true_tree
= gfc_trans_code (t
->next
);
1167 false_tree
= gfc_trans_code (f
->next
);
1169 stmt
= fold_build3 (COND_EXPR
, void_type_node
, se
.expr
,
1170 true_tree
, false_tree
);
1171 gfc_add_expr_to_block (&block
, stmt
);
1174 return gfc_finish_block (&block
);
1178 /* Translate the SELECT CASE construct for CHARACTER case expressions.
1179 Instead of generating compares and jumps, it is far simpler to
1180 generate a data structure describing the cases in order and call a
1181 library subroutine that locates the right case.
1182 This is particularly true because this is the only case where we
1183 might have to dispose of a temporary.
1184 The library subroutine returns a pointer to jump to or NULL if no
1185 branches are to be taken. */
1188 gfc_trans_character_select (gfc_code
*code
)
1190 tree init
, node
, end_label
, tmp
, type
, args
, *labels
;
1191 stmtblock_t block
, body
;
1197 static tree select_struct
;
1198 static tree ss_string1
, ss_string1_len
;
1199 static tree ss_string2
, ss_string2_len
;
1200 static tree ss_target
;
1202 if (select_struct
== NULL
)
1204 tree gfc_int4_type_node
= gfc_get_int_type (4);
1206 select_struct
= make_node (RECORD_TYPE
);
1207 TYPE_NAME (select_struct
) = get_identifier ("_jump_struct");
1210 #define ADD_FIELD(NAME, TYPE) \
1211 ss_##NAME = gfc_add_field_to_struct \
1212 (&(TYPE_FIELDS (select_struct)), select_struct, \
1213 get_identifier (stringize(NAME)), TYPE)
1215 ADD_FIELD (string1
, pchar_type_node
);
1216 ADD_FIELD (string1_len
, gfc_int4_type_node
);
1218 ADD_FIELD (string2
, pchar_type_node
);
1219 ADD_FIELD (string2_len
, gfc_int4_type_node
);
1221 ADD_FIELD (target
, pvoid_type_node
);
1224 gfc_finish_type (select_struct
);
1227 cp
= code
->block
->ext
.case_list
;
1228 while (cp
->left
!= NULL
)
1232 for (d
= cp
; d
; d
= d
->right
)
1236 labels
= gfc_getmem (n
* sizeof (tree
));
1240 for(i
= 0; i
< n
; i
++)
1242 labels
[i
] = gfc_build_label_decl (NULL_TREE
);
1243 TREE_USED (labels
[i
]) = 1;
1244 /* TODO: The gimplifier should do this for us, but it has
1245 inadequacies when dealing with static initializers. */
1246 FORCED_LABEL (labels
[i
]) = 1;
1249 end_label
= gfc_build_label_decl (NULL_TREE
);
1251 /* Generate the body */
1252 gfc_start_block (&block
);
1253 gfc_init_block (&body
);
1255 for (c
= code
->block
; c
; c
= c
->block
)
1257 for (d
= c
->ext
.case_list
; d
; d
= d
->next
)
1259 tmp
= build1_v (LABEL_EXPR
, labels
[d
->n
]);
1260 gfc_add_expr_to_block (&body
, tmp
);
1263 tmp
= gfc_trans_code (c
->next
);
1264 gfc_add_expr_to_block (&body
, tmp
);
1266 tmp
= build1_v (GOTO_EXPR
, end_label
);
1267 gfc_add_expr_to_block (&body
, tmp
);
1270 /* Generate the structure describing the branches */
1274 for(d
= cp
; d
; d
= d
->right
, i
++)
1278 gfc_init_se (&se
, NULL
);
1282 node
= tree_cons (ss_string1
, null_pointer_node
, node
);
1283 node
= tree_cons (ss_string1_len
, integer_zero_node
, node
);
1287 gfc_conv_expr_reference (&se
, d
->low
);
1289 node
= tree_cons (ss_string1
, se
.expr
, node
);
1290 node
= tree_cons (ss_string1_len
, se
.string_length
, node
);
1293 if (d
->high
== NULL
)
1295 node
= tree_cons (ss_string2
, null_pointer_node
, node
);
1296 node
= tree_cons (ss_string2_len
, integer_zero_node
, node
);
1300 gfc_init_se (&se
, NULL
);
1301 gfc_conv_expr_reference (&se
, d
->high
);
1303 node
= tree_cons (ss_string2
, se
.expr
, node
);
1304 node
= tree_cons (ss_string2_len
, se
.string_length
, node
);
1307 tmp
= gfc_build_addr_expr (pvoid_type_node
, labels
[i
]);
1308 node
= tree_cons (ss_target
, tmp
, node
);
1310 tmp
= build_constructor_from_list (select_struct
, nreverse (node
));
1311 init
= tree_cons (NULL_TREE
, tmp
, init
);
1314 type
= build_array_type (select_struct
, build_index_type
1315 (build_int_cst (NULL_TREE
, n
- 1)));
1317 init
= build_constructor_from_list (type
, nreverse(init
));
1318 TREE_CONSTANT (init
) = 1;
1319 TREE_INVARIANT (init
) = 1;
1320 TREE_STATIC (init
) = 1;
1321 /* Create a static variable to hold the jump table. */
1322 tmp
= gfc_create_var (type
, "jumptable");
1323 TREE_CONSTANT (tmp
) = 1;
1324 TREE_INVARIANT (tmp
) = 1;
1325 TREE_STATIC (tmp
) = 1;
1326 DECL_INITIAL (tmp
) = init
;
1329 /* Build an argument list for the library call */
1330 init
= gfc_build_addr_expr (pvoid_type_node
, init
);
1331 args
= gfc_chainon_list (NULL_TREE
, init
);
1333 tmp
= build_int_cst (NULL_TREE
, n
);
1334 args
= gfc_chainon_list (args
, tmp
);
1336 tmp
= gfc_build_addr_expr (pvoid_type_node
, end_label
);
1337 args
= gfc_chainon_list (args
, tmp
);
1339 gfc_init_se (&se
, NULL
);
1340 gfc_conv_expr_reference (&se
, code
->expr
);
1342 args
= gfc_chainon_list (args
, se
.expr
);
1343 args
= gfc_chainon_list (args
, se
.string_length
);
1345 gfc_add_block_to_block (&block
, &se
.pre
);
1347 tmp
= build_function_call_expr (gfor_fndecl_select_string
, args
);
1348 tmp
= build1 (GOTO_EXPR
, void_type_node
, tmp
);
1349 gfc_add_expr_to_block (&block
, tmp
);
1351 tmp
= gfc_finish_block (&body
);
1352 gfc_add_expr_to_block (&block
, tmp
);
1353 tmp
= build1_v (LABEL_EXPR
, end_label
);
1354 gfc_add_expr_to_block (&block
, tmp
);
1359 return gfc_finish_block (&block
);
1363 /* Translate the three variants of the SELECT CASE construct.
1365 SELECT CASEs with INTEGER case expressions can be translated to an
1366 equivalent GENERIC switch statement, and for LOGICAL case
1367 expressions we build one or two if-else compares.
1369 SELECT CASEs with CHARACTER case expressions are a whole different
1370 story, because they don't exist in GENERIC. So we sort them and
1371 do a binary search at runtime.
1373 Fortran has no BREAK statement, and it does not allow jumps from
1374 one case block to another. That makes things a lot easier for
1378 gfc_trans_select (gfc_code
* code
)
1380 gcc_assert (code
&& code
->expr
);
1382 /* Empty SELECT constructs are legal. */
1383 if (code
->block
== NULL
)
1384 return build_empty_stmt ();
1386 /* Select the correct translation function. */
1387 switch (code
->expr
->ts
.type
)
1389 case BT_LOGICAL
: return gfc_trans_logical_select (code
);
1390 case BT_INTEGER
: return gfc_trans_integer_select (code
);
1391 case BT_CHARACTER
: return gfc_trans_character_select (code
);
1393 gfc_internal_error ("gfc_trans_select(): Bad type for case expr.");
1399 /* Generate the loops for a FORALL block. The normal loop format:
1400 count = (end - start + step) / step
1413 gfc_trans_forall_loop (forall_info
*forall_tmp
, int nvar
, tree body
, int mask_flag
)
1421 tree var
, start
, end
, step
;
1424 iter
= forall_tmp
->this_loop
;
1425 for (n
= 0; n
< nvar
; n
++)
1428 start
= iter
->start
;
1432 exit_label
= gfc_build_label_decl (NULL_TREE
);
1433 TREE_USED (exit_label
) = 1;
1435 /* The loop counter. */
1436 count
= gfc_create_var (TREE_TYPE (var
), "count");
1438 /* The body of the loop. */
1439 gfc_init_block (&block
);
1441 /* The exit condition. */
1442 cond
= fold_build2 (LE_EXPR
, boolean_type_node
,
1443 count
, build_int_cst (TREE_TYPE (count
), 0));
1444 tmp
= build1_v (GOTO_EXPR
, exit_label
);
1445 tmp
= fold_build3 (COND_EXPR
, void_type_node
,
1446 cond
, tmp
, build_empty_stmt ());
1447 gfc_add_expr_to_block (&block
, tmp
);
1449 /* The main loop body. */
1450 gfc_add_expr_to_block (&block
, body
);
1452 /* Increment the loop variable. */
1453 tmp
= build2 (PLUS_EXPR
, TREE_TYPE (var
), var
, step
);
1454 gfc_add_modify_expr (&block
, var
, tmp
);
1456 /* Advance to the next mask element. Only do this for the
1458 if (n
== 0 && mask_flag
&& forall_tmp
->mask
)
1460 tree maskindex
= forall_tmp
->maskindex
;
1461 tmp
= build2 (PLUS_EXPR
, gfc_array_index_type
,
1462 maskindex
, gfc_index_one_node
);
1463 gfc_add_modify_expr (&block
, maskindex
, tmp
);
1466 /* Decrement the loop counter. */
1467 tmp
= build2 (MINUS_EXPR
, TREE_TYPE (var
), count
, gfc_index_one_node
);
1468 gfc_add_modify_expr (&block
, count
, tmp
);
1470 body
= gfc_finish_block (&block
);
1472 /* Loop var initialization. */
1473 gfc_init_block (&block
);
1474 gfc_add_modify_expr (&block
, var
, start
);
1476 /* Initialize maskindex counter. Only do this before the
1478 if (n
== nvar
- 1 && mask_flag
&& forall_tmp
->mask
)
1479 gfc_add_modify_expr (&block
, forall_tmp
->maskindex
,
1480 gfc_index_zero_node
);
1482 /* Initialize the loop counter. */
1483 tmp
= fold_build2 (MINUS_EXPR
, TREE_TYPE (var
), step
, start
);
1484 tmp
= fold_build2 (PLUS_EXPR
, TREE_TYPE (var
), end
, tmp
);
1485 tmp
= fold_build2 (TRUNC_DIV_EXPR
, TREE_TYPE (var
), tmp
, step
);
1486 gfc_add_modify_expr (&block
, count
, tmp
);
1488 /* The loop expression. */
1489 tmp
= build1_v (LOOP_EXPR
, body
);
1490 gfc_add_expr_to_block (&block
, tmp
);
1492 /* The exit label. */
1493 tmp
= build1_v (LABEL_EXPR
, exit_label
);
1494 gfc_add_expr_to_block (&block
, tmp
);
1496 body
= gfc_finish_block (&block
);
1503 /* Generate the body and loops according to MASK_FLAG and NEST_FLAG.
1504 if MASK_FLAG is nonzero, the body is controlled by maskes in forall
1505 nest, otherwise, the body is not controlled by maskes.
1506 if NEST_FLAG is nonzero, generate loops for nested forall, otherwise,
1507 only generate loops for the current forall level. */
1510 gfc_trans_nested_forall_loop (forall_info
* nested_forall_info
, tree body
,
1511 int mask_flag
, int nest_flag
)
1515 forall_info
*forall_tmp
;
1516 tree pmask
, mask
, maskindex
;
1518 forall_tmp
= nested_forall_info
;
1519 /* Generate loops for nested forall. */
1522 while (forall_tmp
->next_nest
!= NULL
)
1523 forall_tmp
= forall_tmp
->next_nest
;
1524 while (forall_tmp
!= NULL
)
1526 /* Generate body with masks' control. */
1529 pmask
= forall_tmp
->pmask
;
1530 mask
= forall_tmp
->mask
;
1531 maskindex
= forall_tmp
->maskindex
;
1535 /* If a mask was specified make the assignment conditional. */
1537 tmp
= build_fold_indirect_ref (mask
);
1540 tmp
= gfc_build_array_ref (tmp
, maskindex
);
1542 body
= build3_v (COND_EXPR
, tmp
, body
, build_empty_stmt ());
1545 nvar
= forall_tmp
->nvar
;
1546 body
= gfc_trans_forall_loop (forall_tmp
, nvar
, body
, mask_flag
);
1547 forall_tmp
= forall_tmp
->outer
;
1552 nvar
= forall_tmp
->nvar
;
1553 body
= gfc_trans_forall_loop (forall_tmp
, nvar
, body
, mask_flag
);
1560 /* Allocate data for holding a temporary array. Returns either a local
1561 temporary array or a pointer variable. */
1564 gfc_do_allocate (tree bytesize
, tree size
, tree
* pdata
, stmtblock_t
* pblock
,
1572 if (INTEGER_CST_P (size
))
1574 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, size
,
1575 gfc_index_one_node
);
1580 type
= build_range_type (gfc_array_index_type
, gfc_index_zero_node
, tmp
);
1581 type
= build_array_type (elem_type
, type
);
1582 if (gfc_can_put_var_on_stack (bytesize
))
1584 gcc_assert (INTEGER_CST_P (size
));
1585 tmpvar
= gfc_create_var (type
, "temp");
1590 tmpvar
= gfc_create_var (build_pointer_type (type
), "temp");
1591 *pdata
= convert (pvoid_type_node
, tmpvar
);
1593 args
= gfc_chainon_list (NULL_TREE
, bytesize
);
1594 if (gfc_index_integer_kind
== 4)
1595 tmp
= gfor_fndecl_internal_malloc
;
1596 else if (gfc_index_integer_kind
== 8)
1597 tmp
= gfor_fndecl_internal_malloc64
;
1600 tmp
= build_function_call_expr (tmp
, args
);
1601 tmp
= convert (TREE_TYPE (tmpvar
), tmp
);
1602 gfc_add_modify_expr (pblock
, tmpvar
, tmp
);
1608 /* Generate codes to copy the temporary to the actual lhs. */
1611 generate_loop_for_temp_to_lhs (gfc_expr
*expr
, tree tmp1
, tree count3
,
1612 tree count1
, tree wheremask
)
1616 stmtblock_t block
, body
;
1622 lss
= gfc_walk_expr (expr
);
1624 if (lss
== gfc_ss_terminator
)
1626 gfc_start_block (&block
);
1628 gfc_init_se (&lse
, NULL
);
1630 /* Translate the expression. */
1631 gfc_conv_expr (&lse
, expr
);
1633 /* Form the expression for the temporary. */
1634 tmp
= gfc_build_array_ref (tmp1
, count1
);
1636 /* Use the scalar assignment as is. */
1637 gfc_add_block_to_block (&block
, &lse
.pre
);
1638 gfc_add_modify_expr (&block
, lse
.expr
, tmp
);
1639 gfc_add_block_to_block (&block
, &lse
.post
);
1641 /* Increment the count1. */
1642 tmp
= fold_build2 (PLUS_EXPR
, TREE_TYPE (count1
), count1
,
1643 gfc_index_one_node
);
1644 gfc_add_modify_expr (&block
, count1
, tmp
);
1646 tmp
= gfc_finish_block (&block
);
1650 gfc_start_block (&block
);
1652 gfc_init_loopinfo (&loop1
);
1653 gfc_init_se (&rse
, NULL
);
1654 gfc_init_se (&lse
, NULL
);
1656 /* Associate the lss with the loop. */
1657 gfc_add_ss_to_loop (&loop1
, lss
);
1659 /* Calculate the bounds of the scalarization. */
1660 gfc_conv_ss_startstride (&loop1
);
1661 /* Setup the scalarizing loops. */
1662 gfc_conv_loop_setup (&loop1
);
1664 gfc_mark_ss_chain_used (lss
, 1);
1666 /* Start the scalarized loop body. */
1667 gfc_start_scalarized_body (&loop1
, &body
);
1669 /* Setup the gfc_se structures. */
1670 gfc_copy_loopinfo_to_se (&lse
, &loop1
);
1673 /* Form the expression of the temporary. */
1674 if (lss
!= gfc_ss_terminator
)
1675 rse
.expr
= gfc_build_array_ref (tmp1
, count1
);
1676 /* Translate expr. */
1677 gfc_conv_expr (&lse
, expr
);
1679 /* Use the scalar assignment. */
1680 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
.type
);
1682 /* Form the mask expression according to the mask tree list. */
1685 wheremaskexpr
= gfc_build_array_ref (wheremask
, count3
);
1686 tmp2
= TREE_CHAIN (wheremask
);
1689 tmp1
= gfc_build_array_ref (tmp2
, count3
);
1690 wheremaskexpr
= fold_build2 (TRUTH_AND_EXPR
, TREE_TYPE (tmp1
),
1691 wheremaskexpr
, tmp1
);
1692 tmp2
= TREE_CHAIN (tmp2
);
1694 tmp
= fold_build3 (COND_EXPR
, void_type_node
,
1695 wheremaskexpr
, tmp
, build_empty_stmt ());
1698 gfc_add_expr_to_block (&body
, tmp
);
1700 /* Increment count1. */
1701 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
1702 count1
, gfc_index_one_node
);
1703 gfc_add_modify_expr (&body
, count1
, tmp
);
1705 /* Increment count3. */
1708 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
1709 count3
, gfc_index_one_node
);
1710 gfc_add_modify_expr (&body
, count3
, tmp
);
1713 /* Generate the copying loops. */
1714 gfc_trans_scalarizing_loops (&loop1
, &body
);
1715 gfc_add_block_to_block (&block
, &loop1
.pre
);
1716 gfc_add_block_to_block (&block
, &loop1
.post
);
1717 gfc_cleanup_loop (&loop1
);
1719 tmp
= gfc_finish_block (&block
);
1725 /* Generate codes to copy rhs to the temporary. TMP1 is the address of temporary
1726 LSS and RSS are formed in function compute_inner_temp_size(), and should
1730 generate_loop_for_rhs_to_temp (gfc_expr
*expr2
, tree tmp1
, tree count3
,
1731 tree count1
, gfc_ss
*lss
, gfc_ss
*rss
,
1734 stmtblock_t block
, body1
;
1741 gfc_start_block (&block
);
1743 gfc_init_se (&rse
, NULL
);
1744 gfc_init_se (&lse
, NULL
);
1746 if (lss
== gfc_ss_terminator
)
1748 gfc_init_block (&body1
);
1749 gfc_conv_expr (&rse
, expr2
);
1750 lse
.expr
= gfc_build_array_ref (tmp1
, count1
);
1754 /* Initialize the loop. */
1755 gfc_init_loopinfo (&loop
);
1757 /* We may need LSS to determine the shape of the expression. */
1758 gfc_add_ss_to_loop (&loop
, lss
);
1759 gfc_add_ss_to_loop (&loop
, rss
);
1761 gfc_conv_ss_startstride (&loop
);
1762 gfc_conv_loop_setup (&loop
);
1764 gfc_mark_ss_chain_used (rss
, 1);
1765 /* Start the loop body. */
1766 gfc_start_scalarized_body (&loop
, &body1
);
1768 /* Translate the expression. */
1769 gfc_copy_loopinfo_to_se (&rse
, &loop
);
1771 gfc_conv_expr (&rse
, expr2
);
1773 /* Form the expression of the temporary. */
1774 lse
.expr
= gfc_build_array_ref (tmp1
, count1
);
1777 /* Use the scalar assignment. */
1778 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr2
->ts
.type
);
1780 /* Form the mask expression according to the mask tree list. */
1783 wheremaskexpr
= gfc_build_array_ref (wheremask
, count3
);
1784 tmp2
= TREE_CHAIN (wheremask
);
1787 tmp1
= gfc_build_array_ref (tmp2
, count3
);
1788 wheremaskexpr
= fold_build2 (TRUTH_AND_EXPR
, TREE_TYPE (tmp1
),
1789 wheremaskexpr
, tmp1
);
1790 tmp2
= TREE_CHAIN (tmp2
);
1792 tmp
= fold_build3 (COND_EXPR
, void_type_node
,
1793 wheremaskexpr
, tmp
, build_empty_stmt ());
1796 gfc_add_expr_to_block (&body1
, tmp
);
1798 if (lss
== gfc_ss_terminator
)
1800 gfc_add_block_to_block (&block
, &body1
);
1802 /* Increment count1. */
1803 tmp
= fold_build2 (PLUS_EXPR
, TREE_TYPE (count1
), count1
,
1804 gfc_index_one_node
);
1805 gfc_add_modify_expr (&block
, count1
, tmp
);
1809 /* Increment count1. */
1810 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
1811 count1
, gfc_index_one_node
);
1812 gfc_add_modify_expr (&body1
, count1
, tmp
);
1814 /* Increment count3. */
1817 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
1818 count3
, gfc_index_one_node
);
1819 gfc_add_modify_expr (&body1
, count3
, tmp
);
1822 /* Generate the copying loops. */
1823 gfc_trans_scalarizing_loops (&loop
, &body1
);
1825 gfc_add_block_to_block (&block
, &loop
.pre
);
1826 gfc_add_block_to_block (&block
, &loop
.post
);
1828 gfc_cleanup_loop (&loop
);
1829 /* TODO: Reuse lss and rss when copying temp->lhs. Need to be careful
1830 as tree nodes in SS may not be valid in different scope. */
1833 tmp
= gfc_finish_block (&block
);
1838 /* Calculate the size of temporary needed in the assignment inside forall.
1839 LSS and RSS are filled in this function. */
1842 compute_inner_temp_size (gfc_expr
*expr1
, gfc_expr
*expr2
,
1843 stmtblock_t
* pblock
,
1844 gfc_ss
**lss
, gfc_ss
**rss
)
1851 *lss
= gfc_walk_expr (expr1
);
1854 size
= gfc_index_one_node
;
1855 if (*lss
!= gfc_ss_terminator
)
1857 gfc_init_loopinfo (&loop
);
1859 /* Walk the RHS of the expression. */
1860 *rss
= gfc_walk_expr (expr2
);
1861 if (*rss
== gfc_ss_terminator
)
1863 /* The rhs is scalar. Add a ss for the expression. */
1864 *rss
= gfc_get_ss ();
1865 (*rss
)->next
= gfc_ss_terminator
;
1866 (*rss
)->type
= GFC_SS_SCALAR
;
1867 (*rss
)->expr
= expr2
;
1870 /* Associate the SS with the loop. */
1871 gfc_add_ss_to_loop (&loop
, *lss
);
1872 /* We don't actually need to add the rhs at this point, but it might
1873 make guessing the loop bounds a bit easier. */
1874 gfc_add_ss_to_loop (&loop
, *rss
);
1876 /* We only want the shape of the expression, not rest of the junk
1877 generated by the scalarizer. */
1878 loop
.array_parameter
= 1;
1880 /* Calculate the bounds of the scalarization. */
1881 gfc_conv_ss_startstride (&loop
);
1882 gfc_conv_loop_setup (&loop
);
1884 /* Figure out how many elements we need. */
1885 for (i
= 0; i
< loop
.dimen
; i
++)
1887 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
1888 gfc_index_one_node
, loop
.from
[i
]);
1889 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
1891 size
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, size
, tmp
);
1893 gfc_add_block_to_block (pblock
, &loop
.pre
);
1894 size
= gfc_evaluate_now (size
, pblock
);
1895 gfc_add_block_to_block (pblock
, &loop
.post
);
1897 /* TODO: write a function that cleans up a loopinfo without freeing
1898 the SS chains. Currently a NOP. */
1905 /* Calculate the overall iterator number of the nested forall construct. */
1908 compute_overall_iter_number (forall_info
*nested_forall_info
, tree inner_size
,
1909 stmtblock_t
*inner_size_body
, stmtblock_t
*block
)
1914 /* TODO: optimizing the computing process. */
1915 number
= gfc_create_var (gfc_array_index_type
, "num");
1916 gfc_add_modify_expr (block
, number
, gfc_index_zero_node
);
1918 gfc_start_block (&body
);
1919 if (inner_size_body
)
1920 gfc_add_block_to_block (&body
, inner_size_body
);
1921 if (nested_forall_info
)
1922 tmp
= build2 (PLUS_EXPR
, gfc_array_index_type
, number
,
1926 gfc_add_modify_expr (&body
, number
, tmp
);
1927 tmp
= gfc_finish_block (&body
);
1929 /* Generate loops. */
1930 if (nested_forall_info
!= NULL
)
1931 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, tmp
, 0, 1);
1933 gfc_add_expr_to_block (block
, tmp
);
1939 /* Allocate temporary for forall construct. SIZE is the size of temporary
1940 needed. PTEMP1 is returned for space free. */
1943 allocate_temp_for_forall_nest_1 (tree type
, tree size
, stmtblock_t
* block
,
1951 unit
= TYPE_SIZE_UNIT (type
);
1952 bytesize
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, size
, unit
);
1955 temp1
= gfc_do_allocate (bytesize
, size
, ptemp1
, block
, type
);
1958 tmp
= build_fold_indirect_ref (temp1
);
1966 /* Allocate temporary for forall construct according to the information in
1967 nested_forall_info. INNER_SIZE is the size of temporary needed in the
1968 assignment inside forall. PTEMP1 is returned for space free. */
1971 allocate_temp_for_forall_nest (forall_info
* nested_forall_info
, tree type
,
1972 tree inner_size
, stmtblock_t
* inner_size_body
,
1973 stmtblock_t
* block
, tree
* ptemp1
)
1977 /* Calculate the total size of temporary needed in forall construct. */
1978 size
= compute_overall_iter_number (nested_forall_info
, inner_size
,
1979 inner_size_body
, block
);
1981 return allocate_temp_for_forall_nest_1 (type
, size
, block
, ptemp1
);
1985 /* Handle assignments inside forall which need temporary.
1987 forall (i=start:end:stride; maskexpr)
1990 (where e,f<i> are arbitrary expressions possibly involving i
1991 and there is a dependency between e<i> and f<i>)
1993 masktmp(:) = maskexpr(:)
1998 for (i = start; i <= end; i += stride)
2002 for (i = start; i <= end; i += stride)
2004 if (masktmp[maskindex++])
2005 tmp[count1++] = f<i>
2009 for (i = start; i <= end; i += stride)
2011 if (masktmp[maskindex++])
2012 e<i> = tmp[count1++]
2017 gfc_trans_assign_need_temp (gfc_expr
* expr1
, gfc_expr
* expr2
, tree wheremask
,
2018 forall_info
* nested_forall_info
,
2019 stmtblock_t
* block
)
2027 stmtblock_t inner_size_body
;
2029 /* Create vars. count1 is the current iterator number of the nested
2031 count1
= gfc_create_var (gfc_array_index_type
, "count1");
2033 /* Count is the wheremask index. */
2036 count
= gfc_create_var (gfc_array_index_type
, "count");
2037 gfc_add_modify_expr (block
, count
, gfc_index_zero_node
);
2042 /* Initialize count1. */
2043 gfc_add_modify_expr (block
, count1
, gfc_index_zero_node
);
2045 /* Calculate the size of temporary needed in the assignment. Return loop, lss
2046 and rss which are used in function generate_loop_for_rhs_to_temp(). */
2047 gfc_init_block (&inner_size_body
);
2048 inner_size
= compute_inner_temp_size (expr1
, expr2
, &inner_size_body
,
2051 /* The type of LHS. Used in function allocate_temp_for_forall_nest */
2052 type
= gfc_typenode_for_spec (&expr1
->ts
);
2054 /* Allocate temporary for nested forall construct according to the
2055 information in nested_forall_info and inner_size. */
2056 tmp1
= allocate_temp_for_forall_nest (nested_forall_info
, type
, inner_size
,
2057 &inner_size_body
, block
, &ptemp1
);
2059 /* Generate codes to copy rhs to the temporary . */
2060 tmp
= generate_loop_for_rhs_to_temp (expr2
, tmp1
, count
, count1
, lss
, rss
,
2063 /* Generate body and loops according to the information in
2064 nested_forall_info. */
2065 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, tmp
, 1, 1);
2066 gfc_add_expr_to_block (block
, tmp
);
2069 gfc_add_modify_expr (block
, count1
, gfc_index_zero_node
);
2073 gfc_add_modify_expr (block
, count
, gfc_index_zero_node
);
2075 /* Generate codes to copy the temporary to lhs. */
2076 tmp
= generate_loop_for_temp_to_lhs (expr1
, tmp1
, count
, count1
, wheremask
);
2078 /* Generate body and loops according to the information in
2079 nested_forall_info. */
2080 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, tmp
, 1, 1);
2081 gfc_add_expr_to_block (block
, tmp
);
2085 /* Free the temporary. */
2086 tmp
= gfc_chainon_list (NULL_TREE
, ptemp1
);
2087 tmp
= build_function_call_expr (gfor_fndecl_internal_free
, tmp
);
2088 gfc_add_expr_to_block (block
, tmp
);
2093 /* Translate pointer assignment inside FORALL which need temporary. */
2096 gfc_trans_pointer_assign_need_temp (gfc_expr
* expr1
, gfc_expr
* expr2
,
2097 forall_info
* nested_forall_info
,
2098 stmtblock_t
* block
)
2112 tree tmp
, tmp1
, ptemp1
;
2114 count
= gfc_create_var (gfc_array_index_type
, "count");
2115 gfc_add_modify_expr (block
, count
, gfc_index_zero_node
);
2117 inner_size
= integer_one_node
;
2118 lss
= gfc_walk_expr (expr1
);
2119 rss
= gfc_walk_expr (expr2
);
2120 if (lss
== gfc_ss_terminator
)
2122 type
= gfc_typenode_for_spec (&expr1
->ts
);
2123 type
= build_pointer_type (type
);
2125 /* Allocate temporary for nested forall construct according to the
2126 information in nested_forall_info and inner_size. */
2127 tmp1
= allocate_temp_for_forall_nest (nested_forall_info
, type
,
2128 inner_size
, NULL
, block
, &ptemp1
);
2129 gfc_start_block (&body
);
2130 gfc_init_se (&lse
, NULL
);
2131 lse
.expr
= gfc_build_array_ref (tmp1
, count
);
2132 gfc_init_se (&rse
, NULL
);
2133 rse
.want_pointer
= 1;
2134 gfc_conv_expr (&rse
, expr2
);
2135 gfc_add_block_to_block (&body
, &rse
.pre
);
2136 gfc_add_modify_expr (&body
, lse
.expr
,
2137 fold_convert (TREE_TYPE (lse
.expr
), rse
.expr
));
2138 gfc_add_block_to_block (&body
, &rse
.post
);
2140 /* Increment count. */
2141 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
2142 count
, gfc_index_one_node
);
2143 gfc_add_modify_expr (&body
, count
, tmp
);
2145 tmp
= gfc_finish_block (&body
);
2147 /* Generate body and loops according to the information in
2148 nested_forall_info. */
2149 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, tmp
, 1, 1);
2150 gfc_add_expr_to_block (block
, tmp
);
2153 gfc_add_modify_expr (block
, count
, gfc_index_zero_node
);
2155 gfc_start_block (&body
);
2156 gfc_init_se (&lse
, NULL
);
2157 gfc_init_se (&rse
, NULL
);
2158 rse
.expr
= gfc_build_array_ref (tmp1
, count
);
2159 lse
.want_pointer
= 1;
2160 gfc_conv_expr (&lse
, expr1
);
2161 gfc_add_block_to_block (&body
, &lse
.pre
);
2162 gfc_add_modify_expr (&body
, lse
.expr
, rse
.expr
);
2163 gfc_add_block_to_block (&body
, &lse
.post
);
2164 /* Increment count. */
2165 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
2166 count
, gfc_index_one_node
);
2167 gfc_add_modify_expr (&body
, count
, tmp
);
2168 tmp
= gfc_finish_block (&body
);
2170 /* Generate body and loops according to the information in
2171 nested_forall_info. */
2172 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, tmp
, 1, 1);
2173 gfc_add_expr_to_block (block
, tmp
);
2177 gfc_init_loopinfo (&loop
);
2179 /* Associate the SS with the loop. */
2180 gfc_add_ss_to_loop (&loop
, rss
);
2182 /* Setup the scalarizing loops and bounds. */
2183 gfc_conv_ss_startstride (&loop
);
2185 gfc_conv_loop_setup (&loop
);
2187 info
= &rss
->data
.info
;
2188 desc
= info
->descriptor
;
2190 /* Make a new descriptor. */
2191 parmtype
= gfc_get_element_type (TREE_TYPE (desc
));
2192 parmtype
= gfc_get_array_type_bounds (parmtype
, loop
.dimen
,
2193 loop
.from
, loop
.to
, 1);
2195 /* Allocate temporary for nested forall construct. */
2196 tmp1
= allocate_temp_for_forall_nest (nested_forall_info
, parmtype
,
2197 inner_size
, NULL
, block
, &ptemp1
);
2198 gfc_start_block (&body
);
2199 gfc_init_se (&lse
, NULL
);
2200 lse
.expr
= gfc_build_array_ref (tmp1
, count
);
2201 lse
.direct_byref
= 1;
2202 rss
= gfc_walk_expr (expr2
);
2203 gfc_conv_expr_descriptor (&lse
, expr2
, rss
);
2205 gfc_add_block_to_block (&body
, &lse
.pre
);
2206 gfc_add_block_to_block (&body
, &lse
.post
);
2208 /* Increment count. */
2209 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
2210 count
, gfc_index_one_node
);
2211 gfc_add_modify_expr (&body
, count
, tmp
);
2213 tmp
= gfc_finish_block (&body
);
2215 /* Generate body and loops according to the information in
2216 nested_forall_info. */
2217 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, tmp
, 1, 1);
2218 gfc_add_expr_to_block (block
, tmp
);
2221 gfc_add_modify_expr (block
, count
, gfc_index_zero_node
);
2223 parm
= gfc_build_array_ref (tmp1
, count
);
2224 lss
= gfc_walk_expr (expr1
);
2225 gfc_init_se (&lse
, NULL
);
2226 gfc_conv_expr_descriptor (&lse
, expr1
, lss
);
2227 gfc_add_modify_expr (&lse
.pre
, lse
.expr
, parm
);
2228 gfc_start_block (&body
);
2229 gfc_add_block_to_block (&body
, &lse
.pre
);
2230 gfc_add_block_to_block (&body
, &lse
.post
);
2232 /* Increment count. */
2233 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
2234 count
, gfc_index_one_node
);
2235 gfc_add_modify_expr (&body
, count
, tmp
);
2237 tmp
= gfc_finish_block (&body
);
2239 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, tmp
, 1, 1);
2240 gfc_add_expr_to_block (block
, tmp
);
2242 /* Free the temporary. */
2245 tmp
= gfc_chainon_list (NULL_TREE
, ptemp1
);
2246 tmp
= build_function_call_expr (gfor_fndecl_internal_free
, tmp
);
2247 gfc_add_expr_to_block (block
, tmp
);
2252 /* FORALL and WHERE statements are really nasty, especially when you nest
2253 them. All the rhs of a forall assignment must be evaluated before the
2254 actual assignments are performed. Presumably this also applies to all the
2255 assignments in an inner where statement. */
2257 /* Generate code for a FORALL statement. Any temporaries are allocated as a
2258 linear array, relying on the fact that we process in the same order in all
2261 forall (i=start:end:stride; maskexpr)
2265 (where e,f,g,h<i> are arbitrary expressions possibly involving i)
2267 count = ((end + 1 - start) / stride)
2268 masktmp(:) = maskexpr(:)
2271 for (i = start; i <= end; i += stride)
2273 if (masktmp[maskindex++])
2277 for (i = start; i <= end; i += stride)
2279 if (masktmp[maskindex++])
2283 Note that this code only works when there are no dependencies.
2284 Forall loop with array assignments and data dependencies are a real pain,
2285 because the size of the temporary cannot always be determined before the
2286 loop is executed. This problem is compounded by the presence of nested
2291 gfc_trans_forall_1 (gfc_code
* code
, forall_info
* nested_forall_info
)
2313 gfc_forall_iterator
*fa
;
2316 gfc_saved_var
*saved_vars
;
2317 iter_info
*this_forall
, *iter_tmp
;
2318 forall_info
*info
, *forall_tmp
;
2319 temporary_list
*temp
;
2321 gfc_start_block (&block
);
2324 /* Count the FORALL index number. */
2325 for (fa
= code
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
2329 /* Allocate the space for var, start, end, step, varexpr. */
2330 var
= (tree
*) gfc_getmem (nvar
* sizeof (tree
));
2331 start
= (tree
*) gfc_getmem (nvar
* sizeof (tree
));
2332 end
= (tree
*) gfc_getmem (nvar
* sizeof (tree
));
2333 step
= (tree
*) gfc_getmem (nvar
* sizeof (tree
));
2334 varexpr
= (gfc_expr
**) gfc_getmem (nvar
* sizeof (gfc_expr
*));
2335 saved_vars
= (gfc_saved_var
*) gfc_getmem (nvar
* sizeof (gfc_saved_var
));
2337 /* Allocate the space for info. */
2338 info
= (forall_info
*) gfc_getmem (sizeof (forall_info
));
2340 for (fa
= code
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
2342 gfc_symbol
*sym
= fa
->var
->symtree
->n
.sym
;
2344 /* allocate space for this_forall. */
2345 this_forall
= (iter_info
*) gfc_getmem (sizeof (iter_info
));
2347 /* Create a temporary variable for the FORALL index. */
2348 tmp
= gfc_typenode_for_spec (&sym
->ts
);
2349 var
[n
] = gfc_create_var (tmp
, sym
->name
);
2350 gfc_shadow_sym (sym
, var
[n
], &saved_vars
[n
]);
2352 /* Record it in this_forall. */
2353 this_forall
->var
= var
[n
];
2355 /* Replace the index symbol's backend_decl with the temporary decl. */
2356 sym
->backend_decl
= var
[n
];
2358 /* Work out the start, end and stride for the loop. */
2359 gfc_init_se (&se
, NULL
);
2360 gfc_conv_expr_val (&se
, fa
->start
);
2361 /* Record it in this_forall. */
2362 this_forall
->start
= se
.expr
;
2363 gfc_add_block_to_block (&block
, &se
.pre
);
2366 gfc_init_se (&se
, NULL
);
2367 gfc_conv_expr_val (&se
, fa
->end
);
2368 /* Record it in this_forall. */
2369 this_forall
->end
= se
.expr
;
2370 gfc_make_safe_expr (&se
);
2371 gfc_add_block_to_block (&block
, &se
.pre
);
2374 gfc_init_se (&se
, NULL
);
2375 gfc_conv_expr_val (&se
, fa
->stride
);
2376 /* Record it in this_forall. */
2377 this_forall
->step
= se
.expr
;
2378 gfc_make_safe_expr (&se
);
2379 gfc_add_block_to_block (&block
, &se
.pre
);
2382 /* Set the NEXT field of this_forall to NULL. */
2383 this_forall
->next
= NULL
;
2384 /* Link this_forall to the info construct. */
2385 if (info
->this_loop
== NULL
)
2386 info
->this_loop
= this_forall
;
2389 iter_tmp
= info
->this_loop
;
2390 while (iter_tmp
->next
!= NULL
)
2391 iter_tmp
= iter_tmp
->next
;
2392 iter_tmp
->next
= this_forall
;
2399 /* Work out the number of elements in the mask array. */
2402 size
= gfc_index_one_node
;
2403 sizevar
= NULL_TREE
;
2405 for (n
= 0; n
< nvar
; n
++)
2407 if (lenvar
&& TREE_TYPE (lenvar
) != TREE_TYPE (start
[n
]))
2410 /* size = (end + step - start) / step. */
2411 tmp
= fold_build2 (MINUS_EXPR
, TREE_TYPE (start
[n
]),
2413 tmp
= fold_build2 (PLUS_EXPR
, TREE_TYPE (end
[n
]), end
[n
], tmp
);
2415 tmp
= fold_build2 (FLOOR_DIV_EXPR
, TREE_TYPE (tmp
), tmp
, step
[n
]);
2416 tmp
= convert (gfc_array_index_type
, tmp
);
2418 size
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, size
, tmp
);
2421 /* Record the nvar and size of current forall level. */
2425 /* Link the current forall level to nested_forall_info. */
2426 forall_tmp
= nested_forall_info
;
2427 if (forall_tmp
== NULL
)
2428 nested_forall_info
= info
;
2431 while (forall_tmp
->next_nest
!= NULL
)
2432 forall_tmp
= forall_tmp
->next_nest
;
2433 info
->outer
= forall_tmp
;
2434 forall_tmp
->next_nest
= info
;
2437 /* Copy the mask into a temporary variable if required.
2438 For now we assume a mask temporary is needed. */
2441 /* As the mask array can be very big, prefer compact
2443 tree smallest_boolean_type_node
2444 = gfc_get_logical_type (gfc_logical_kinds
[0].kind
);
2446 /* Allocate the mask temporary. */
2447 bytesize
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, size
,
2448 TYPE_SIZE_UNIT (smallest_boolean_type_node
));
2450 mask
= gfc_do_allocate (bytesize
, size
, &pmask
, &block
,
2451 smallest_boolean_type_node
);
2453 maskindex
= gfc_create_var_np (gfc_array_index_type
, "mi");
2454 /* Record them in the info structure. */
2455 info
->pmask
= pmask
;
2457 info
->maskindex
= maskindex
;
2459 gfc_add_modify_expr (&block
, maskindex
, gfc_index_zero_node
);
2461 /* Start of mask assignment loop body. */
2462 gfc_start_block (&body
);
2464 /* Evaluate the mask expression. */
2465 gfc_init_se (&se
, NULL
);
2466 gfc_conv_expr_val (&se
, code
->expr
);
2467 gfc_add_block_to_block (&body
, &se
.pre
);
2469 /* Store the mask. */
2470 se
.expr
= convert (smallest_boolean_type_node
, se
.expr
);
2473 tmp
= build_fold_indirect_ref (mask
);
2476 tmp
= gfc_build_array_ref (tmp
, maskindex
);
2477 gfc_add_modify_expr (&body
, tmp
, se
.expr
);
2479 /* Advance to the next mask element. */
2480 tmp
= build2 (PLUS_EXPR
, gfc_array_index_type
,
2481 maskindex
, gfc_index_one_node
);
2482 gfc_add_modify_expr (&body
, maskindex
, tmp
);
2484 /* Generate the loops. */
2485 tmp
= gfc_finish_block (&body
);
2486 tmp
= gfc_trans_nested_forall_loop (info
, tmp
, 0, 0);
2487 gfc_add_expr_to_block (&block
, tmp
);
2491 /* No mask was specified. */
2492 maskindex
= NULL_TREE
;
2493 mask
= pmask
= NULL_TREE
;
2496 c
= code
->block
->next
;
2498 /* TODO: loop merging in FORALL statements. */
2499 /* Now that we've got a copy of the mask, generate the assignment loops. */
2505 /* A scalar or array assignment. */
2506 need_temp
= gfc_check_dependency (c
->expr
, c
->expr2
, varexpr
, nvar
);
2507 /* Temporaries due to array assignment data dependencies introduce
2508 no end of problems. */
2510 gfc_trans_assign_need_temp (c
->expr
, c
->expr2
, NULL
,
2511 nested_forall_info
, &block
);
2514 /* Use the normal assignment copying routines. */
2515 assign
= gfc_trans_assignment (c
->expr
, c
->expr2
);
2517 /* Generate body and loops. */
2518 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, assign
, 1, 1);
2519 gfc_add_expr_to_block (&block
, tmp
);
2526 /* Translate WHERE or WHERE construct nested in FORALL. */
2528 gfc_trans_where_2 (c
, NULL
, NULL
, nested_forall_info
, &block
, &temp
);
2535 /* Free the temporary. */
2536 args
= gfc_chainon_list (NULL_TREE
, temp
->temporary
);
2537 tmp
= build_function_call_expr (gfor_fndecl_internal_free
, args
);
2538 gfc_add_expr_to_block (&block
, tmp
);
2547 /* Pointer assignment inside FORALL. */
2548 case EXEC_POINTER_ASSIGN
:
2549 need_temp
= gfc_check_dependency (c
->expr
, c
->expr2
, varexpr
, nvar
);
2551 gfc_trans_pointer_assign_need_temp (c
->expr
, c
->expr2
,
2552 nested_forall_info
, &block
);
2555 /* Use the normal assignment copying routines. */
2556 assign
= gfc_trans_pointer_assignment (c
->expr
, c
->expr2
);
2558 /* Generate body and loops. */
2559 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, assign
,
2561 gfc_add_expr_to_block (&block
, tmp
);
2566 tmp
= gfc_trans_forall_1 (c
, nested_forall_info
);
2567 gfc_add_expr_to_block (&block
, tmp
);
2570 /* Explicit subroutine calls are prevented by the frontend but interface
2571 assignments can legitimately produce them. */
2573 assign
= gfc_trans_call (c
);
2574 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, assign
, 1, 1);
2575 gfc_add_expr_to_block (&block
, tmp
);
2585 /* Restore the original index variables. */
2586 for (fa
= code
->ext
.forall_iterator
, n
= 0; fa
; fa
= fa
->next
, n
++)
2587 gfc_restore_sym (fa
->var
->symtree
->n
.sym
, &saved_vars
[n
]);
2589 /* Free the space for var, start, end, step, varexpr. */
2595 gfc_free (saved_vars
);
2599 /* Free the temporary for the mask. */
2600 tmp
= gfc_chainon_list (NULL_TREE
, pmask
);
2601 tmp
= build_function_call_expr (gfor_fndecl_internal_free
, tmp
);
2602 gfc_add_expr_to_block (&block
, tmp
);
2605 pushdecl (maskindex
);
2607 return gfc_finish_block (&block
);
2611 /* Translate the FORALL statement or construct. */
2613 tree
gfc_trans_forall (gfc_code
* code
)
2615 return gfc_trans_forall_1 (code
, NULL
);
2619 /* Evaluate the WHERE mask expression, copy its value to a temporary.
2620 If the WHERE construct is nested in FORALL, compute the overall temporary
2621 needed by the WHERE mask expression multiplied by the iterator number of
2623 ME is the WHERE mask expression.
2624 MASK is the temporary which value is mask's value.
2625 NMASK is another temporary which value is !mask.
2626 TEMP records the temporary's address allocated in this function in order to
2627 free them outside this function.
2628 MASK, NMASK and TEMP are all OUT arguments. */
2631 gfc_evaluate_where_mask (gfc_expr
* me
, forall_info
* nested_forall_info
,
2632 tree
* mask
, tree
* nmask
, temporary_list
** temp
,
2633 stmtblock_t
* block
)
2638 tree ptemp1
, ntmp
, ptemp2
;
2639 tree inner_size
, size
;
2640 stmtblock_t body
, body1
, inner_size_body
;
2646 gfc_init_loopinfo (&loop
);
2648 /* Calculate the size of temporary needed by the mask-expr. */
2649 gfc_init_block (&inner_size_body
);
2650 inner_size
= compute_inner_temp_size (me
, me
, &inner_size_body
, &lss
, &rss
);
2652 /* Calculate the total size of temporary needed. */
2653 size
= compute_overall_iter_number (nested_forall_info
, inner_size
,
2654 &inner_size_body
, block
);
2656 /* As the mask array can be very big, prefer compact boolean types. */
2657 mask_type
= gfc_get_logical_type (gfc_logical_kinds
[0].kind
);
2659 /* Allocate temporary for where mask. */
2660 tmp
= allocate_temp_for_forall_nest_1 (mask_type
, size
, block
, &ptemp1
);
2662 /* Record the temporary address in order to free it later. */
2665 temporary_list
*tempo
;
2666 tempo
= (temporary_list
*) gfc_getmem (sizeof (temporary_list
));
2667 tempo
->temporary
= ptemp1
;
2668 tempo
->next
= *temp
;
2672 /* Allocate temporary for !mask. */
2673 ntmp
= allocate_temp_for_forall_nest_1 (mask_type
, size
, block
, &ptemp2
);
2675 /* Record the temporary in order to free it later. */
2678 temporary_list
*tempo
;
2679 tempo
= (temporary_list
*) gfc_getmem (sizeof (temporary_list
));
2680 tempo
->temporary
= ptemp2
;
2681 tempo
->next
= *temp
;
2685 /* Variable to index the temporary. */
2686 count
= gfc_create_var (gfc_array_index_type
, "count");
2687 /* Initialize count. */
2688 gfc_add_modify_expr (block
, count
, gfc_index_zero_node
);
2690 gfc_start_block (&body
);
2692 gfc_init_se (&rse
, NULL
);
2693 gfc_init_se (&lse
, NULL
);
2695 if (lss
== gfc_ss_terminator
)
2697 gfc_init_block (&body1
);
2701 /* Initialize the loop. */
2702 gfc_init_loopinfo (&loop
);
2704 /* We may need LSS to determine the shape of the expression. */
2705 gfc_add_ss_to_loop (&loop
, lss
);
2706 gfc_add_ss_to_loop (&loop
, rss
);
2708 gfc_conv_ss_startstride (&loop
);
2709 gfc_conv_loop_setup (&loop
);
2711 gfc_mark_ss_chain_used (rss
, 1);
2712 /* Start the loop body. */
2713 gfc_start_scalarized_body (&loop
, &body1
);
2715 /* Translate the expression. */
2716 gfc_copy_loopinfo_to_se (&rse
, &loop
);
2718 gfc_conv_expr (&rse
, me
);
2720 /* Form the expression of the temporary. */
2721 lse
.expr
= gfc_build_array_ref (tmp
, count
);
2722 tmpexpr
= gfc_build_array_ref (ntmp
, count
);
2724 /* Use the scalar assignment to fill temporary TMP. */
2725 tmp1
= gfc_trans_scalar_assign (&lse
, &rse
, me
->ts
.type
);
2726 gfc_add_expr_to_block (&body1
, tmp1
);
2728 /* Fill temporary NTMP. */
2729 tmp1
= build1 (TRUTH_NOT_EXPR
, TREE_TYPE (lse
.expr
), lse
.expr
);
2730 gfc_add_modify_expr (&body1
, tmpexpr
, tmp1
);
2732 if (lss
== gfc_ss_terminator
)
2734 gfc_add_block_to_block (&body
, &body1
);
2738 /* Increment count. */
2739 tmp1
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
, count
,
2740 gfc_index_one_node
);
2741 gfc_add_modify_expr (&body1
, count
, tmp1
);
2743 /* Generate the copying loops. */
2744 gfc_trans_scalarizing_loops (&loop
, &body1
);
2746 gfc_add_block_to_block (&body
, &loop
.pre
);
2747 gfc_add_block_to_block (&body
, &loop
.post
);
2749 gfc_cleanup_loop (&loop
);
2750 /* TODO: Reuse lss and rss when copying temp->lhs. Need to be careful
2751 as tree nodes in SS may not be valid in different scope. */
2754 tmp1
= gfc_finish_block (&body
);
2755 /* If the WHERE construct is inside FORALL, fill the full temporary. */
2756 if (nested_forall_info
!= NULL
)
2757 tmp1
= gfc_trans_nested_forall_loop (nested_forall_info
, tmp1
, 1, 1);
2759 gfc_add_expr_to_block (block
, tmp1
);
2768 /* Translate an assignment statement in a WHERE statement or construct
2769 statement. The MASK expression is used to control which elements
2770 of EXPR1 shall be assigned. */
2773 gfc_trans_where_assign (gfc_expr
*expr1
, gfc_expr
*expr2
, tree mask
,
2774 tree count1
, tree count2
)
2779 gfc_ss
*lss_section
;
2786 tree index
, maskexpr
, tmp1
;
2789 /* TODO: handle this special case.
2790 Special case a single function returning an array. */
2791 if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->rank
> 0)
2793 tmp
= gfc_trans_arrayfunc_assign (expr1
, expr2
);
2799 /* Assignment of the form lhs = rhs. */
2800 gfc_start_block (&block
);
2802 gfc_init_se (&lse
, NULL
);
2803 gfc_init_se (&rse
, NULL
);
2806 lss
= gfc_walk_expr (expr1
);
2809 /* In each where-assign-stmt, the mask-expr and the variable being
2810 defined shall be arrays of the same shape. */
2811 gcc_assert (lss
!= gfc_ss_terminator
);
2813 /* The assignment needs scalarization. */
2816 /* Find a non-scalar SS from the lhs. */
2817 while (lss_section
!= gfc_ss_terminator
2818 && lss_section
->type
!= GFC_SS_SECTION
)
2819 lss_section
= lss_section
->next
;
2821 gcc_assert (lss_section
!= gfc_ss_terminator
);
2823 /* Initialize the scalarizer. */
2824 gfc_init_loopinfo (&loop
);
2827 rss
= gfc_walk_expr (expr2
);
2828 if (rss
== gfc_ss_terminator
)
2830 /* The rhs is scalar. Add a ss for the expression. */
2831 rss
= gfc_get_ss ();
2832 rss
->next
= gfc_ss_terminator
;
2833 rss
->type
= GFC_SS_SCALAR
;
2837 /* Associate the SS with the loop. */
2838 gfc_add_ss_to_loop (&loop
, lss
);
2839 gfc_add_ss_to_loop (&loop
, rss
);
2841 /* Calculate the bounds of the scalarization. */
2842 gfc_conv_ss_startstride (&loop
);
2844 /* Resolve any data dependencies in the statement. */
2845 gfc_conv_resolve_dependencies (&loop
, lss_section
, rss
);
2847 /* Setup the scalarizing loops. */
2848 gfc_conv_loop_setup (&loop
);
2850 /* Setup the gfc_se structures. */
2851 gfc_copy_loopinfo_to_se (&lse
, &loop
);
2852 gfc_copy_loopinfo_to_se (&rse
, &loop
);
2855 gfc_mark_ss_chain_used (rss
, 1);
2856 if (loop
.temp_ss
== NULL
)
2859 gfc_mark_ss_chain_used (lss
, 1);
2863 lse
.ss
= loop
.temp_ss
;
2864 gfc_mark_ss_chain_used (lss
, 3);
2865 gfc_mark_ss_chain_used (loop
.temp_ss
, 3);
2868 /* Start the scalarized loop body. */
2869 gfc_start_scalarized_body (&loop
, &body
);
2871 /* Translate the expression. */
2872 gfc_conv_expr (&rse
, expr2
);
2873 if (lss
!= gfc_ss_terminator
&& loop
.temp_ss
!= NULL
)
2875 gfc_conv_tmp_array_ref (&lse
);
2876 gfc_advance_se_ss_chain (&lse
);
2879 gfc_conv_expr (&lse
, expr1
);
2881 /* Form the mask expression according to the mask tree list. */
2885 maskexpr
= gfc_build_array_ref (tmp
, index
);
2889 tmp
= TREE_CHAIN (tmp
);
2892 tmp1
= gfc_build_array_ref (tmp
, index
);
2893 maskexpr
= build2 (TRUTH_AND_EXPR
, TREE_TYPE (tmp1
), maskexpr
, tmp1
);
2894 tmp
= TREE_CHAIN (tmp
);
2896 /* Use the scalar assignment as is. */
2897 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
.type
);
2898 tmp
= build3_v (COND_EXPR
, maskexpr
, tmp
, build_empty_stmt ());
2900 gfc_add_expr_to_block (&body
, tmp
);
2902 if (lss
== gfc_ss_terminator
)
2904 /* Increment count1. */
2905 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
2906 count1
, gfc_index_one_node
);
2907 gfc_add_modify_expr (&body
, count1
, tmp
);
2909 /* Use the scalar assignment as is. */
2910 gfc_add_block_to_block (&block
, &body
);
2914 gcc_assert (lse
.ss
== gfc_ss_terminator
2915 && rse
.ss
== gfc_ss_terminator
);
2917 if (loop
.temp_ss
!= NULL
)
2919 /* Increment count1 before finish the main body of a scalarized
2921 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
2922 count1
, gfc_index_one_node
);
2923 gfc_add_modify_expr (&body
, count1
, tmp
);
2924 gfc_trans_scalarized_loop_boundary (&loop
, &body
);
2926 /* We need to copy the temporary to the actual lhs. */
2927 gfc_init_se (&lse
, NULL
);
2928 gfc_init_se (&rse
, NULL
);
2929 gfc_copy_loopinfo_to_se (&lse
, &loop
);
2930 gfc_copy_loopinfo_to_se (&rse
, &loop
);
2932 rse
.ss
= loop
.temp_ss
;
2935 gfc_conv_tmp_array_ref (&rse
);
2936 gfc_advance_se_ss_chain (&rse
);
2937 gfc_conv_expr (&lse
, expr1
);
2939 gcc_assert (lse
.ss
== gfc_ss_terminator
2940 && rse
.ss
== gfc_ss_terminator
);
2942 /* Form the mask expression according to the mask tree list. */
2946 maskexpr
= gfc_build_array_ref (tmp
, index
);
2950 tmp
= TREE_CHAIN (tmp
);
2953 tmp1
= gfc_build_array_ref (tmp
, index
);
2954 maskexpr
= build2 (TRUTH_AND_EXPR
, TREE_TYPE (tmp1
),
2956 tmp
= TREE_CHAIN (tmp
);
2958 /* Use the scalar assignment as is. */
2959 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
.type
);
2960 tmp
= build3_v (COND_EXPR
, maskexpr
, tmp
, build_empty_stmt ());
2961 gfc_add_expr_to_block (&body
, tmp
);
2963 /* Increment count2. */
2964 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
2965 count2
, gfc_index_one_node
);
2966 gfc_add_modify_expr (&body
, count2
, tmp
);
2970 /* Increment count1. */
2971 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
2972 count1
, gfc_index_one_node
);
2973 gfc_add_modify_expr (&body
, count1
, tmp
);
2976 /* Generate the copying loops. */
2977 gfc_trans_scalarizing_loops (&loop
, &body
);
2979 /* Wrap the whole thing up. */
2980 gfc_add_block_to_block (&block
, &loop
.pre
);
2981 gfc_add_block_to_block (&block
, &loop
.post
);
2982 gfc_cleanup_loop (&loop
);
2985 return gfc_finish_block (&block
);
2989 /* Translate the WHERE construct or statement.
2990 This function can be called iteratively to translate the nested WHERE
2991 construct or statement.
2992 MASK is the control mask, and PMASK is the pending control mask.
2993 TEMP records the temporary address which must be freed later. */
2996 gfc_trans_where_2 (gfc_code
* code
, tree mask
, tree pmask
,
2997 forall_info
* nested_forall_info
, stmtblock_t
* block
,
2998 temporary_list
** temp
)
3004 tree tmp
, tmp1
, tmp2
;
3005 tree count1
, count2
;
3009 /* the WHERE statement or the WHERE construct statement. */
3010 cblock
= code
->block
;
3013 /* Has mask-expr. */
3016 /* Ensure that the WHERE mask be evaluated only once. */
3017 tmp2
= gfc_evaluate_where_mask (cblock
->expr
, nested_forall_info
,
3018 &tmp
, &tmp1
, temp
, block
);
3020 /* Set the control mask and the pending control mask. */
3021 /* It's a where-stmt. */
3027 /* It's a nested where-stmt. */
3028 else if (mask
&& pmask
== NULL
)
3031 /* Use the TREE_CHAIN to list the masks. */
3032 tmp2
= copy_list (mask
);
3033 pmask
= chainon (mask
, tmp1
);
3034 mask
= chainon (tmp2
, tmp
);
3036 /* It's a masked-elsewhere-stmt. */
3037 else if (mask
&& cblock
->expr
)
3040 tmp2
= copy_list (pmask
);
3043 tmp2
= chainon (tmp2
, tmp
);
3044 pmask
= chainon (mask
, tmp1
);
3048 /* It's a elsewhere-stmt. No mask-expr is present. */
3052 /* Get the assignment statement of a WHERE statement, or the first
3053 statement in where-body-construct of a WHERE construct. */
3054 cnext
= cblock
->next
;
3059 /* WHERE assignment statement. */
3061 expr1
= cnext
->expr
;
3062 expr2
= cnext
->expr2
;
3063 if (nested_forall_info
!= NULL
)
3068 nvar
= nested_forall_info
->nvar
;
3069 varexpr
= (gfc_expr
**)
3070 gfc_getmem (nvar
* sizeof (gfc_expr
*));
3071 need_temp
= gfc_check_dependency (expr1
, expr2
, varexpr
,
3074 gfc_trans_assign_need_temp (expr1
, expr2
, mask
,
3075 nested_forall_info
, block
);
3078 /* Variables to control maskexpr. */
3079 count1
= gfc_create_var (gfc_array_index_type
, "count1");
3080 count2
= gfc_create_var (gfc_array_index_type
, "count2");
3081 gfc_add_modify_expr (block
, count1
, gfc_index_zero_node
);
3082 gfc_add_modify_expr (block
, count2
, gfc_index_zero_node
);
3084 tmp
= gfc_trans_where_assign (expr1
, expr2
, mask
, count1
,
3087 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
,
3089 gfc_add_expr_to_block (block
, tmp
);
3094 /* Variables to control maskexpr. */
3095 count1
= gfc_create_var (gfc_array_index_type
, "count1");
3096 count2
= gfc_create_var (gfc_array_index_type
, "count2");
3097 gfc_add_modify_expr (block
, count1
, gfc_index_zero_node
);
3098 gfc_add_modify_expr (block
, count2
, gfc_index_zero_node
);
3100 tmp
= gfc_trans_where_assign (expr1
, expr2
, mask
, count1
,
3102 gfc_add_expr_to_block (block
, tmp
);
3107 /* WHERE or WHERE construct is part of a where-body-construct. */
3109 /* Ensure that MASK is not modified by next gfc_trans_where_2. */
3110 mask_copy
= copy_list (mask
);
3111 gfc_trans_where_2 (cnext
, mask_copy
, NULL
, nested_forall_info
,
3119 /* The next statement within the same where-body-construct. */
3120 cnext
= cnext
->next
;
3122 /* The next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt. */
3123 cblock
= cblock
->block
;
3128 /* As the WHERE or WHERE construct statement can be nested, we call
3129 gfc_trans_where_2 to do the translation, and pass the initial
3130 NULL values for both the control mask and the pending control mask. */
3133 gfc_trans_where (gfc_code
* code
)
3136 temporary_list
*temp
, *p
;
3140 gfc_start_block (&block
);
3143 gfc_trans_where_2 (code
, NULL
, NULL
, NULL
, &block
, &temp
);
3145 /* Add calls to free temporaries which were dynamically allocated. */
3148 args
= gfc_chainon_list (NULL_TREE
, temp
->temporary
);
3149 tmp
= build_function_call_expr (gfor_fndecl_internal_free
, args
);
3150 gfc_add_expr_to_block (&block
, tmp
);
3156 return gfc_finish_block (&block
);
3160 /* CYCLE a DO loop. The label decl has already been created by
3161 gfc_trans_do(), it's in TREE_PURPOSE (backend_decl) of the gfc_code
3162 node at the head of the loop. We must mark the label as used. */
3165 gfc_trans_cycle (gfc_code
* code
)
3169 cycle_label
= TREE_PURPOSE (code
->ext
.whichloop
->backend_decl
);
3170 TREE_USED (cycle_label
) = 1;
3171 return build1_v (GOTO_EXPR
, cycle_label
);
3175 /* EXIT a DO loop. Similar to CYCLE, but now the label is in
3176 TREE_VALUE (backend_decl) of the gfc_code node at the head of the
3180 gfc_trans_exit (gfc_code
* code
)
3184 exit_label
= TREE_VALUE (code
->ext
.whichloop
->backend_decl
);
3185 TREE_USED (exit_label
) = 1;
3186 return build1_v (GOTO_EXPR
, exit_label
);
3190 /* Translate the ALLOCATE statement. */
3193 gfc_trans_allocate (gfc_code
* code
)
3206 if (!code
->ext
.alloc_list
)
3209 gfc_start_block (&block
);
3213 tree gfc_int4_type_node
= gfc_get_int_type (4);
3215 stat
= gfc_create_var (gfc_int4_type_node
, "stat");
3216 pstat
= build_fold_addr_expr (stat
);
3218 error_label
= gfc_build_label_decl (NULL_TREE
);
3219 TREE_USED (error_label
) = 1;
3223 pstat
= integer_zero_node
;
3224 stat
= error_label
= NULL_TREE
;
3228 for (al
= code
->ext
.alloc_list
; al
!= NULL
; al
= al
->next
)
3232 gfc_init_se (&se
, NULL
);
3233 gfc_start_block (&se
.pre
);
3235 se
.want_pointer
= 1;
3236 se
.descriptor_only
= 1;
3237 gfc_conv_expr (&se
, expr
);
3241 /* Find the last reference in the chain. */
3242 while (ref
&& ref
->next
!= NULL
)
3244 gcc_assert (ref
->type
!= REF_ARRAY
|| ref
->u
.ar
.type
== AR_ELEMENT
);
3248 if (ref
!= NULL
&& ref
->type
== REF_ARRAY
)
3251 gfc_array_allocate (&se
, ref
, pstat
);
3255 /* A scalar or derived type. */
3258 val
= gfc_create_var (ppvoid_type_node
, "ptr");
3259 tmp
= gfc_build_addr_expr (ppvoid_type_node
, se
.expr
);
3260 gfc_add_modify_expr (&se
.pre
, val
, tmp
);
3262 tmp
= TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (se
.expr
)));
3263 parm
= gfc_chainon_list (NULL_TREE
, val
);
3264 parm
= gfc_chainon_list (parm
, tmp
);
3265 parm
= gfc_chainon_list (parm
, pstat
);
3266 tmp
= build_function_call_expr (gfor_fndecl_allocate
, parm
);
3267 gfc_add_expr_to_block (&se
.pre
, tmp
);
3271 tmp
= build1_v (GOTO_EXPR
, error_label
);
3272 parm
= fold_build2 (NE_EXPR
, boolean_type_node
,
3273 stat
, build_int_cst (TREE_TYPE (stat
), 0));
3274 tmp
= fold_build3 (COND_EXPR
, void_type_node
,
3275 parm
, tmp
, build_empty_stmt ());
3276 gfc_add_expr_to_block (&se
.pre
, tmp
);
3280 tmp
= gfc_finish_block (&se
.pre
);
3281 gfc_add_expr_to_block (&block
, tmp
);
3284 /* Assign the value to the status variable. */
3287 tmp
= build1_v (LABEL_EXPR
, error_label
);
3288 gfc_add_expr_to_block (&block
, tmp
);
3290 gfc_init_se (&se
, NULL
);
3291 gfc_conv_expr_lhs (&se
, code
->expr
);
3292 tmp
= convert (TREE_TYPE (se
.expr
), stat
);
3293 gfc_add_modify_expr (&block
, se
.expr
, tmp
);
3296 return gfc_finish_block (&block
);
3300 /* Translate a DEALLOCATE statement.
3301 There are two cases within the for loop:
3302 (1) deallocate(a1, a2, a3) is translated into the following sequence
3303 _gfortran_deallocate(a1, 0B)
3304 _gfortran_deallocate(a2, 0B)
3305 _gfortran_deallocate(a3, 0B)
3306 where the STAT= variable is passed a NULL pointer.
3307 (2) deallocate(a1, a2, a3, stat=i) is translated into the following
3309 _gfortran_deallocate(a1, &stat)
3310 astat = astat + stat
3311 _gfortran_deallocate(a2, &stat)
3312 astat = astat + stat
3313 _gfortran_deallocate(a3, &stat)
3314 astat = astat + stat
3315 In case (1), we simply return at the end of the for loop. In case (2)
3316 we set STAT= astat. */
3318 gfc_trans_deallocate (gfc_code
* code
)
3323 tree apstat
, astat
, parm
, pstat
, stat
, tmp
, type
, var
;
3326 gfc_start_block (&block
);
3328 /* Set up the optional STAT= */
3331 tree gfc_int4_type_node
= gfc_get_int_type (4);
3333 /* Variable used with the library call. */
3334 stat
= gfc_create_var (gfc_int4_type_node
, "stat");
3335 pstat
= build_fold_addr_expr (stat
);
3337 /* Running total of possible deallocation failures. */
3338 astat
= gfc_create_var (gfc_int4_type_node
, "astat");
3339 apstat
= build_fold_addr_expr (astat
);
3341 /* Initialize astat to 0. */
3342 gfc_add_modify_expr (&block
, astat
, build_int_cst (TREE_TYPE (astat
), 0));
3346 pstat
= apstat
= null_pointer_node
;
3347 stat
= astat
= NULL_TREE
;
3350 for (al
= code
->ext
.alloc_list
; al
!= NULL
; al
= al
->next
)
3353 gcc_assert (expr
->expr_type
== EXPR_VARIABLE
);
3355 gfc_init_se (&se
, NULL
);
3356 gfc_start_block (&se
.pre
);
3358 se
.want_pointer
= 1;
3359 se
.descriptor_only
= 1;
3360 gfc_conv_expr (&se
, expr
);
3363 tmp
= gfc_array_deallocate (se
.expr
, pstat
);
3366 type
= build_pointer_type (TREE_TYPE (se
.expr
));
3367 var
= gfc_create_var (type
, "ptr");
3368 tmp
= gfc_build_addr_expr (type
, se
.expr
);
3369 gfc_add_modify_expr (&se
.pre
, var
, tmp
);
3371 parm
= gfc_chainon_list (NULL_TREE
, var
);
3372 parm
= gfc_chainon_list (parm
, pstat
);
3373 tmp
= build_function_call_expr (gfor_fndecl_deallocate
, parm
);
3376 gfc_add_expr_to_block (&se
.pre
, tmp
);
3378 /* Keep track of the number of failed deallocations by adding stat
3379 of the last deallocation to the running total. */
3382 apstat
= build2 (PLUS_EXPR
, TREE_TYPE (stat
), astat
, stat
);
3383 gfc_add_modify_expr (&se
.pre
, astat
, apstat
);
3386 tmp
= gfc_finish_block (&se
.pre
);
3387 gfc_add_expr_to_block (&block
, tmp
);
3391 /* Assign the value to the status variable. */
3394 gfc_init_se (&se
, NULL
);
3395 gfc_conv_expr_lhs (&se
, code
->expr
);
3396 tmp
= convert (TREE_TYPE (se
.expr
), astat
);
3397 gfc_add_modify_expr (&block
, se
.expr
, tmp
);
3400 return gfc_finish_block (&block
);