1 /* Statement translation -- generate GCC trees from gfc_code.
2 Copyright (C) 2002, 2003, 2004, 2005 Free Software Foundation, Inc.
3 Contributed by Paul Brook <paul@nowt.org>
4 and Steven Bosscher <s.bosscher@student.tudelft.nl>
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 2, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING. If not, write to the Free
20 Software Foundation, 51 Franklin Street, Fifth Floor, Boston, MA
26 #include "coretypes.h"
28 #include "tree-gimple.h"
34 #include "trans-stmt.h"
35 #include "trans-types.h"
36 #include "trans-array.h"
37 #include "trans-const.h"
40 typedef struct iter_info
46 struct iter_info
*next
;
50 typedef struct temporary_list
53 struct temporary_list
*next
;
57 typedef struct forall_info
65 struct forall_info
*outer
;
66 struct forall_info
*next_nest
;
70 static void gfc_trans_where_2 (gfc_code
*, tree
, tree
, forall_info
*,
71 stmtblock_t
*, temporary_list
**temp
);
73 /* Translate a F95 label number to a LABEL_EXPR. */
76 gfc_trans_label_here (gfc_code
* code
)
78 return build1_v (LABEL_EXPR
, gfc_get_label_decl (code
->here
));
82 /* Given a variable expression which has been ASSIGNed to, find the decl
83 containing the auxiliary variables. For variables in common blocks this
87 gfc_conv_label_variable (gfc_se
* se
, gfc_expr
* expr
)
89 gcc_assert (expr
->symtree
->n
.sym
->attr
.assign
== 1);
90 gfc_conv_expr (se
, expr
);
91 /* Deals with variable in common block. Get the field declaration. */
92 if (TREE_CODE (se
->expr
) == COMPONENT_REF
)
93 se
->expr
= TREE_OPERAND (se
->expr
, 1);
96 /* Translate a label assignment statement. */
99 gfc_trans_label_assign (gfc_code
* code
)
109 /* Start a new block. */
110 gfc_init_se (&se
, NULL
);
111 gfc_start_block (&se
.pre
);
112 gfc_conv_label_variable (&se
, code
->expr
);
114 len
= GFC_DECL_STRING_LEN (se
.expr
);
115 addr
= GFC_DECL_ASSIGN_ADDR (se
.expr
);
117 label_tree
= gfc_get_label_decl (code
->label
);
119 if (code
->label
->defined
== ST_LABEL_TARGET
)
121 label_tree
= gfc_build_addr_expr (pvoid_type_node
, label_tree
);
122 len_tree
= integer_minus_one_node
;
126 label_str
= code
->label
->format
->value
.character
.string
;
127 label_len
= code
->label
->format
->value
.character
.length
;
128 len_tree
= build_int_cst (NULL_TREE
, label_len
);
129 label_tree
= gfc_build_string_const (label_len
+ 1, label_str
);
130 label_tree
= gfc_build_addr_expr (pvoid_type_node
, label_tree
);
133 gfc_add_modify_expr (&se
.pre
, len
, len_tree
);
134 gfc_add_modify_expr (&se
.pre
, addr
, label_tree
);
136 return gfc_finish_block (&se
.pre
);
139 /* Translate a GOTO statement. */
142 gfc_trans_goto (gfc_code
* code
)
152 if (code
->label
!= NULL
)
153 return build1_v (GOTO_EXPR
, gfc_get_label_decl (code
->label
));
156 gfc_init_se (&se
, NULL
);
157 gfc_start_block (&se
.pre
);
158 gfc_conv_label_variable (&se
, code
->expr
);
160 gfc_build_cstring_const ("Assigned label is not a target label");
161 tmp
= GFC_DECL_STRING_LEN (se
.expr
);
162 tmp
= build2 (NE_EXPR
, boolean_type_node
, tmp
, integer_minus_one_node
);
163 gfc_trans_runtime_check (tmp
, assign_error
, &se
.pre
);
165 assigned_goto
= GFC_DECL_ASSIGN_ADDR (se
.expr
);
170 target
= build1 (GOTO_EXPR
, void_type_node
, assigned_goto
);
171 gfc_add_expr_to_block (&se
.pre
, target
);
172 return gfc_finish_block (&se
.pre
);
175 /* Check the label list. */
176 range_error
= gfc_build_cstring_const ("Assigned label is not in the list");
180 target
= gfc_get_label_decl (code
->label
);
181 tmp
= gfc_build_addr_expr (pvoid_type_node
, target
);
182 tmp
= build2 (EQ_EXPR
, boolean_type_node
, tmp
, assigned_goto
);
183 tmp
= build3_v (COND_EXPR
, tmp
,
184 build1 (GOTO_EXPR
, void_type_node
, target
),
185 build_empty_stmt ());
186 gfc_add_expr_to_block (&se
.pre
, tmp
);
189 while (code
!= NULL
);
190 gfc_trans_runtime_check (boolean_true_node
, range_error
, &se
.pre
);
191 return gfc_finish_block (&se
.pre
);
195 /* Translate an ENTRY statement. Just adds a label for this entry point. */
197 gfc_trans_entry (gfc_code
* code
)
199 return build1_v (LABEL_EXPR
, code
->ext
.entry
->label
);
203 /* Translate the CALL statement. Builds a call to an F95 subroutine. */
206 gfc_trans_call (gfc_code
* code
)
209 int has_alternate_specifier
;
211 /* A CALL starts a new block because the actual arguments may have to
212 be evaluated first. */
213 gfc_init_se (&se
, NULL
);
214 gfc_start_block (&se
.pre
);
216 gcc_assert (code
->resolved_sym
);
218 /* Translate the call. */
219 has_alternate_specifier
220 = gfc_conv_function_call (&se
, code
->resolved_sym
, code
->ext
.actual
);
222 /* A subroutine without side-effect, by definition, does nothing! */
223 TREE_SIDE_EFFECTS (se
.expr
) = 1;
225 /* Chain the pieces together and return the block. */
226 if (has_alternate_specifier
)
228 gfc_code
*select_code
;
230 select_code
= code
->next
;
231 gcc_assert(select_code
->op
== EXEC_SELECT
);
232 sym
= select_code
->expr
->symtree
->n
.sym
;
233 se
.expr
= convert (gfc_typenode_for_spec (&sym
->ts
), se
.expr
);
234 gfc_add_modify_expr (&se
.pre
, sym
->backend_decl
, se
.expr
);
237 gfc_add_expr_to_block (&se
.pre
, se
.expr
);
239 gfc_add_block_to_block (&se
.pre
, &se
.post
);
240 return gfc_finish_block (&se
.pre
);
244 /* Translate the RETURN statement. */
247 gfc_trans_return (gfc_code
* code ATTRIBUTE_UNUSED
)
255 /* if code->expr is not NULL, this return statement must appear
256 in a subroutine and current_fake_result_decl has already
259 result
= gfc_get_fake_result_decl (NULL
);
262 gfc_warning ("An alternate return at %L without a * dummy argument",
264 return build1_v (GOTO_EXPR
, gfc_get_return_label ());
267 /* Start a new block for this statement. */
268 gfc_init_se (&se
, NULL
);
269 gfc_start_block (&se
.pre
);
271 gfc_conv_expr (&se
, code
->expr
);
273 tmp
= build2 (MODIFY_EXPR
, TREE_TYPE (result
), result
, se
.expr
);
274 gfc_add_expr_to_block (&se
.pre
, tmp
);
276 tmp
= build1_v (GOTO_EXPR
, gfc_get_return_label ());
277 gfc_add_expr_to_block (&se
.pre
, tmp
);
278 gfc_add_block_to_block (&se
.pre
, &se
.post
);
279 return gfc_finish_block (&se
.pre
);
282 return build1_v (GOTO_EXPR
, gfc_get_return_label ());
286 /* Translate the PAUSE statement. We have to translate this statement
287 to a runtime library call. */
290 gfc_trans_pause (gfc_code
* code
)
292 tree gfc_int4_type_node
= gfc_get_int_type (4);
298 /* Start a new block for this statement. */
299 gfc_init_se (&se
, NULL
);
300 gfc_start_block (&se
.pre
);
303 if (code
->expr
== NULL
)
305 tmp
= build_int_cst (gfc_int4_type_node
, code
->ext
.stop_code
);
306 args
= gfc_chainon_list (NULL_TREE
, tmp
);
307 fndecl
= gfor_fndecl_pause_numeric
;
311 gfc_conv_expr_reference (&se
, code
->expr
);
312 args
= gfc_chainon_list (NULL_TREE
, se
.expr
);
313 args
= gfc_chainon_list (args
, se
.string_length
);
314 fndecl
= gfor_fndecl_pause_string
;
317 tmp
= gfc_build_function_call (fndecl
, args
);
318 gfc_add_expr_to_block (&se
.pre
, tmp
);
320 gfc_add_block_to_block (&se
.pre
, &se
.post
);
322 return gfc_finish_block (&se
.pre
);
326 /* Translate the STOP statement. We have to translate this statement
327 to a runtime library call. */
330 gfc_trans_stop (gfc_code
* code
)
332 tree gfc_int4_type_node
= gfc_get_int_type (4);
338 /* Start a new block for this statement. */
339 gfc_init_se (&se
, NULL
);
340 gfc_start_block (&se
.pre
);
343 if (code
->expr
== NULL
)
345 tmp
= build_int_cst (gfc_int4_type_node
, code
->ext
.stop_code
);
346 args
= gfc_chainon_list (NULL_TREE
, tmp
);
347 fndecl
= gfor_fndecl_stop_numeric
;
351 gfc_conv_expr_reference (&se
, code
->expr
);
352 args
= gfc_chainon_list (NULL_TREE
, se
.expr
);
353 args
= gfc_chainon_list (args
, se
.string_length
);
354 fndecl
= gfor_fndecl_stop_string
;
357 tmp
= gfc_build_function_call (fndecl
, args
);
358 gfc_add_expr_to_block (&se
.pre
, tmp
);
360 gfc_add_block_to_block (&se
.pre
, &se
.post
);
362 return gfc_finish_block (&se
.pre
);
366 /* Generate GENERIC for the IF construct. This function also deals with
367 the simple IF statement, because the front end translates the IF
368 statement into an IF construct.
400 where COND_S is the simplified version of the predicate. PRE_COND_S
401 are the pre side-effects produced by the translation of the
403 We need to build the chain recursively otherwise we run into
404 problems with folding incomplete statements. */
407 gfc_trans_if_1 (gfc_code
* code
)
412 /* Check for an unconditional ELSE clause. */
414 return gfc_trans_code (code
->next
);
416 /* Initialize a statement builder for each block. Puts in NULL_TREEs. */
417 gfc_init_se (&if_se
, NULL
);
418 gfc_start_block (&if_se
.pre
);
420 /* Calculate the IF condition expression. */
421 gfc_conv_expr_val (&if_se
, code
->expr
);
423 /* Translate the THEN clause. */
424 stmt
= gfc_trans_code (code
->next
);
426 /* Translate the ELSE clause. */
428 elsestmt
= gfc_trans_if_1 (code
->block
);
430 elsestmt
= build_empty_stmt ();
432 /* Build the condition expression and add it to the condition block. */
433 stmt
= build3_v (COND_EXPR
, if_se
.expr
, stmt
, elsestmt
);
435 gfc_add_expr_to_block (&if_se
.pre
, stmt
);
437 /* Finish off this statement. */
438 return gfc_finish_block (&if_se
.pre
);
442 gfc_trans_if (gfc_code
* code
)
444 /* Ignore the top EXEC_IF, it only announces an IF construct. The
445 actual code we must translate is in code->block. */
447 return gfc_trans_if_1 (code
->block
);
451 /* Translage an arithmetic IF expression.
453 IF (cond) label1, label2, label3 translates to
467 gfc_trans_arithmetic_if (gfc_code
* code
)
475 /* Start a new block. */
476 gfc_init_se (&se
, NULL
);
477 gfc_start_block (&se
.pre
);
479 /* Pre-evaluate COND. */
480 gfc_conv_expr_val (&se
, code
->expr
);
482 /* Build something to compare with. */
483 zero
= gfc_build_const (TREE_TYPE (se
.expr
), integer_zero_node
);
485 /* If (cond < 0) take branch1 else take branch2.
486 First build jumps to the COND .LT. 0 and the COND .EQ. 0 cases. */
487 branch1
= build1_v (GOTO_EXPR
, gfc_get_label_decl (code
->label
));
488 branch2
= build1_v (GOTO_EXPR
, gfc_get_label_decl (code
->label2
));
490 tmp
= build2 (LT_EXPR
, boolean_type_node
, se
.expr
, zero
);
491 branch1
= build3_v (COND_EXPR
, tmp
, branch1
, branch2
);
493 /* if (cond <= 0) take branch1 else take branch2. */
494 branch2
= build1_v (GOTO_EXPR
, gfc_get_label_decl (code
->label3
));
495 tmp
= build2 (LE_EXPR
, boolean_type_node
, se
.expr
, zero
);
496 branch1
= build3_v (COND_EXPR
, tmp
, branch1
, branch2
);
498 /* Append the COND_EXPR to the evaluation of COND, and return. */
499 gfc_add_expr_to_block (&se
.pre
, branch1
);
500 return gfc_finish_block (&se
.pre
);
504 /* Translate the simple DO construct. This is where the loop variable has
505 integer type and step +-1. We can't use this in the general case
506 because integer overflow and floating point errors could give incorrect
508 We translate a do loop from:
510 DO dovar = from, to, step
516 [Evaluate loop bounds and step]
518 if ((step > 0) ? (dovar <= to) : (dovar => to))
524 cond = (dovar == to);
526 if (cond) goto end_label;
531 This helps the optimizers by avoiding the extra induction variable
532 used in the general case. */
535 gfc_trans_simple_do (gfc_code
* code
, stmtblock_t
*pblock
, tree dovar
,
536 tree from
, tree to
, tree step
)
545 type
= TREE_TYPE (dovar
);
547 /* Initialize the DO variable: dovar = from. */
548 gfc_add_modify_expr (pblock
, dovar
, from
);
550 /* Cycle and exit statements are implemented with gotos. */
551 cycle_label
= gfc_build_label_decl (NULL_TREE
);
552 exit_label
= gfc_build_label_decl (NULL_TREE
);
554 /* Put the labels where they can be found later. See gfc_trans_do(). */
555 code
->block
->backend_decl
= tree_cons (cycle_label
, exit_label
, NULL
);
558 gfc_start_block (&body
);
560 /* Main loop body. */
561 tmp
= gfc_trans_code (code
->block
->next
);
562 gfc_add_expr_to_block (&body
, tmp
);
564 /* Label for cycle statements (if needed). */
565 if (TREE_USED (cycle_label
))
567 tmp
= build1_v (LABEL_EXPR
, cycle_label
);
568 gfc_add_expr_to_block (&body
, tmp
);
571 /* Evaluate the loop condition. */
572 cond
= build2 (EQ_EXPR
, boolean_type_node
, dovar
, to
);
573 cond
= gfc_evaluate_now (cond
, &body
);
575 /* Increment the loop variable. */
576 tmp
= build2 (PLUS_EXPR
, type
, dovar
, step
);
577 gfc_add_modify_expr (&body
, dovar
, tmp
);
580 tmp
= build1_v (GOTO_EXPR
, exit_label
);
581 TREE_USED (exit_label
) = 1;
582 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt ());
583 gfc_add_expr_to_block (&body
, tmp
);
585 /* Finish the loop body. */
586 tmp
= gfc_finish_block (&body
);
587 tmp
= build1_v (LOOP_EXPR
, tmp
);
589 /* Only execute the loop if the number of iterations is positive. */
590 if (tree_int_cst_sgn (step
) > 0)
591 cond
= fold_build2 (LE_EXPR
, boolean_type_node
, dovar
, to
);
593 cond
= fold_build2 (GE_EXPR
, boolean_type_node
, dovar
, to
);
594 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt ());
595 gfc_add_expr_to_block (pblock
, tmp
);
597 /* Add the exit label. */
598 tmp
= build1_v (LABEL_EXPR
, exit_label
);
599 gfc_add_expr_to_block (pblock
, tmp
);
601 return gfc_finish_block (pblock
);
604 /* Translate the DO construct. This obviously is one of the most
605 important ones to get right with any compiler, but especially
608 We special case some loop forms as described in gfc_trans_simple_do.
609 For other cases we implement them with a separate loop count,
610 as described in the standard.
612 We translate a do loop from:
614 DO dovar = from, to, step
620 [evaluate loop bounds and step]
621 count = to + step - from;
629 if (count <=0) goto exit_label;
633 TODO: Large loop counts
634 The code above assumes the loop count fits into a signed integer kind,
635 i.e. Does not work for loop counts > 2^31 for integer(kind=4) variables
636 We must support the full range. */
639 gfc_trans_do (gfc_code
* code
)
656 gfc_start_block (&block
);
658 /* Evaluate all the expressions in the iterator. */
659 gfc_init_se (&se
, NULL
);
660 gfc_conv_expr_lhs (&se
, code
->ext
.iterator
->var
);
661 gfc_add_block_to_block (&block
, &se
.pre
);
663 type
= TREE_TYPE (dovar
);
665 gfc_init_se (&se
, NULL
);
666 gfc_conv_expr_val (&se
, code
->ext
.iterator
->start
);
667 gfc_add_block_to_block (&block
, &se
.pre
);
668 from
= gfc_evaluate_now (se
.expr
, &block
);
670 gfc_init_se (&se
, NULL
);
671 gfc_conv_expr_val (&se
, code
->ext
.iterator
->end
);
672 gfc_add_block_to_block (&block
, &se
.pre
);
673 to
= gfc_evaluate_now (se
.expr
, &block
);
675 gfc_init_se (&se
, NULL
);
676 gfc_conv_expr_val (&se
, code
->ext
.iterator
->step
);
677 gfc_add_block_to_block (&block
, &se
.pre
);
678 step
= gfc_evaluate_now (se
.expr
, &block
);
680 /* Special case simple loops. */
681 if (TREE_CODE (type
) == INTEGER_TYPE
682 && (integer_onep (step
)
683 || tree_int_cst_equal (step
, integer_minus_one_node
)))
684 return gfc_trans_simple_do (code
, &block
, dovar
, from
, to
, step
);
686 /* Initialize loop count. This code is executed before we enter the
687 loop body. We generate: count = (to + step - from) / step. */
689 tmp
= fold_build2 (MINUS_EXPR
, type
, step
, from
);
690 tmp
= fold_build2 (PLUS_EXPR
, type
, to
, tmp
);
691 if (TREE_CODE (type
) == INTEGER_TYPE
)
693 tmp
= fold_build2 (TRUNC_DIV_EXPR
, type
, tmp
, step
);
694 count
= gfc_create_var (type
, "count");
698 /* TODO: We could use the same width as the real type.
699 This would probably cause more problems that it solves
700 when we implement "long double" types. */
701 tmp
= fold_build2 (RDIV_EXPR
, type
, tmp
, step
);
702 tmp
= fold_build1 (FIX_TRUNC_EXPR
, gfc_array_index_type
, tmp
);
703 count
= gfc_create_var (gfc_array_index_type
, "count");
705 gfc_add_modify_expr (&block
, count
, tmp
);
707 count_one
= convert (TREE_TYPE (count
), integer_one_node
);
709 /* Initialize the DO variable: dovar = from. */
710 gfc_add_modify_expr (&block
, dovar
, from
);
713 gfc_start_block (&body
);
715 /* Cycle and exit statements are implemented with gotos. */
716 cycle_label
= gfc_build_label_decl (NULL_TREE
);
717 exit_label
= gfc_build_label_decl (NULL_TREE
);
719 /* Start with the loop condition. Loop until count <= 0. */
720 cond
= build2 (LE_EXPR
, boolean_type_node
, count
,
721 convert (TREE_TYPE (count
), integer_zero_node
));
722 tmp
= build1_v (GOTO_EXPR
, exit_label
);
723 TREE_USED (exit_label
) = 1;
724 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt ());
725 gfc_add_expr_to_block (&body
, tmp
);
727 /* Put these labels where they can be found later. We put the
728 labels in a TREE_LIST node (because TREE_CHAIN is already
729 used). cycle_label goes in TREE_PURPOSE (backend_decl), exit
730 label in TREE_VALUE (backend_decl). */
732 code
->block
->backend_decl
= tree_cons (cycle_label
, exit_label
, NULL
);
734 /* Main loop body. */
735 tmp
= gfc_trans_code (code
->block
->next
);
736 gfc_add_expr_to_block (&body
, tmp
);
738 /* Label for cycle statements (if needed). */
739 if (TREE_USED (cycle_label
))
741 tmp
= build1_v (LABEL_EXPR
, cycle_label
);
742 gfc_add_expr_to_block (&body
, tmp
);
745 /* Increment the loop variable. */
746 tmp
= build2 (PLUS_EXPR
, type
, dovar
, step
);
747 gfc_add_modify_expr (&body
, dovar
, tmp
);
749 /* Decrement the loop count. */
750 tmp
= build2 (MINUS_EXPR
, TREE_TYPE (count
), count
, count_one
);
751 gfc_add_modify_expr (&body
, count
, tmp
);
753 /* End of loop body. */
754 tmp
= gfc_finish_block (&body
);
756 /* The for loop itself. */
757 tmp
= build1_v (LOOP_EXPR
, tmp
);
758 gfc_add_expr_to_block (&block
, tmp
);
760 /* Add the exit label. */
761 tmp
= build1_v (LABEL_EXPR
, exit_label
);
762 gfc_add_expr_to_block (&block
, tmp
);
764 return gfc_finish_block (&block
);
768 /* Translate the DO WHILE construct.
781 if (! cond) goto exit_label;
787 Because the evaluation of the exit condition `cond' may have side
788 effects, we can't do much for empty loop bodies. The backend optimizers
789 should be smart enough to eliminate any dead loops. */
792 gfc_trans_do_while (gfc_code
* code
)
800 /* Everything we build here is part of the loop body. */
801 gfc_start_block (&block
);
803 /* Cycle and exit statements are implemented with gotos. */
804 cycle_label
= gfc_build_label_decl (NULL_TREE
);
805 exit_label
= gfc_build_label_decl (NULL_TREE
);
807 /* Put the labels where they can be found later. See gfc_trans_do(). */
808 code
->block
->backend_decl
= tree_cons (cycle_label
, exit_label
, NULL
);
810 /* Create a GIMPLE version of the exit condition. */
811 gfc_init_se (&cond
, NULL
);
812 gfc_conv_expr_val (&cond
, code
->expr
);
813 gfc_add_block_to_block (&block
, &cond
.pre
);
814 cond
.expr
= fold_build1 (TRUTH_NOT_EXPR
, boolean_type_node
, cond
.expr
);
816 /* Build "IF (! cond) GOTO exit_label". */
817 tmp
= build1_v (GOTO_EXPR
, exit_label
);
818 TREE_USED (exit_label
) = 1;
819 tmp
= build3_v (COND_EXPR
, cond
.expr
, tmp
, build_empty_stmt ());
820 gfc_add_expr_to_block (&block
, tmp
);
822 /* The main body of the loop. */
823 tmp
= gfc_trans_code (code
->block
->next
);
824 gfc_add_expr_to_block (&block
, tmp
);
826 /* Label for cycle statements (if needed). */
827 if (TREE_USED (cycle_label
))
829 tmp
= build1_v (LABEL_EXPR
, cycle_label
);
830 gfc_add_expr_to_block (&block
, tmp
);
833 /* End of loop body. */
834 tmp
= gfc_finish_block (&block
);
836 gfc_init_block (&block
);
837 /* Build the loop. */
838 tmp
= build1_v (LOOP_EXPR
, tmp
);
839 gfc_add_expr_to_block (&block
, tmp
);
841 /* Add the exit label. */
842 tmp
= build1_v (LABEL_EXPR
, exit_label
);
843 gfc_add_expr_to_block (&block
, tmp
);
845 return gfc_finish_block (&block
);
849 /* Translate the SELECT CASE construct for INTEGER case expressions,
850 without killing all potential optimizations. The problem is that
851 Fortran allows unbounded cases, but the back-end does not, so we
852 need to intercept those before we enter the equivalent SWITCH_EXPR
855 For example, we translate this,
858 CASE (:100,101,105:115)
868 to the GENERIC equivalent,
872 case (minimum value for typeof(expr) ... 100:
878 case 200 ... (maximum value for typeof(expr):
895 gfc_trans_integer_select (gfc_code
* code
)
905 gfc_start_block (&block
);
907 /* Calculate the switch expression. */
908 gfc_init_se (&se
, NULL
);
909 gfc_conv_expr_val (&se
, code
->expr
);
910 gfc_add_block_to_block (&block
, &se
.pre
);
912 end_label
= gfc_build_label_decl (NULL_TREE
);
914 gfc_init_block (&body
);
916 for (c
= code
->block
; c
; c
= c
->block
)
918 for (cp
= c
->ext
.case_list
; cp
; cp
= cp
->next
)
923 /* Assume it's the default case. */
924 low
= high
= NULL_TREE
;
928 low
= gfc_conv_constant_to_tree (cp
->low
);
930 /* If there's only a lower bound, set the high bound to the
931 maximum value of the case expression. */
933 high
= TYPE_MAX_VALUE (TREE_TYPE (se
.expr
));
938 /* Three cases are possible here:
940 1) There is no lower bound, e.g. CASE (:N).
941 2) There is a lower bound .NE. high bound, that is
942 a case range, e.g. CASE (N:M) where M>N (we make
943 sure that M>N during type resolution).
944 3) There is a lower bound, and it has the same value
945 as the high bound, e.g. CASE (N:N). This is our
946 internal representation of CASE(N).
948 In the first and second case, we need to set a value for
949 high. In the thirth case, we don't because the GCC middle
950 end represents a single case value by just letting high be
951 a NULL_TREE. We can't do that because we need to be able
952 to represent unbounded cases. */
956 && mpz_cmp (cp
->low
->value
.integer
,
957 cp
->high
->value
.integer
) != 0))
958 high
= gfc_conv_constant_to_tree (cp
->high
);
960 /* Unbounded case. */
962 low
= TYPE_MIN_VALUE (TREE_TYPE (se
.expr
));
966 label
= gfc_build_label_decl (NULL_TREE
);
968 /* Add this case label.
969 Add parameter 'label', make it match GCC backend. */
970 tmp
= build3 (CASE_LABEL_EXPR
, void_type_node
, low
, high
, label
);
971 gfc_add_expr_to_block (&body
, tmp
);
974 /* Add the statements for this case. */
975 tmp
= gfc_trans_code (c
->next
);
976 gfc_add_expr_to_block (&body
, tmp
);
978 /* Break to the end of the construct. */
979 tmp
= build1_v (GOTO_EXPR
, end_label
);
980 gfc_add_expr_to_block (&body
, tmp
);
983 tmp
= gfc_finish_block (&body
);
984 tmp
= build3_v (SWITCH_EXPR
, se
.expr
, tmp
, NULL_TREE
);
985 gfc_add_expr_to_block (&block
, tmp
);
987 tmp
= build1_v (LABEL_EXPR
, end_label
);
988 gfc_add_expr_to_block (&block
, tmp
);
990 return gfc_finish_block (&block
);
994 /* Translate the SELECT CASE construct for LOGICAL case expressions.
996 There are only two cases possible here, even though the standard
997 does allow three cases in a LOGICAL SELECT CASE construct: .TRUE.,
998 .FALSE., and DEFAULT.
1000 We never generate more than two blocks here. Instead, we always
1001 try to eliminate the DEFAULT case. This way, we can translate this
1002 kind of SELECT construct to a simple
1006 expression in GENERIC. */
1009 gfc_trans_logical_select (gfc_code
* code
)
1012 gfc_code
*t
, *f
, *d
;
1017 /* Assume we don't have any cases at all. */
1020 /* Now see which ones we actually do have. We can have at most two
1021 cases in a single case list: one for .TRUE. and one for .FALSE.
1022 The default case is always separate. If the cases for .TRUE. and
1023 .FALSE. are in the same case list, the block for that case list
1024 always executed, and we don't generate code a COND_EXPR. */
1025 for (c
= code
->block
; c
; c
= c
->block
)
1027 for (cp
= c
->ext
.case_list
; cp
; cp
= cp
->next
)
1031 if (cp
->low
->value
.logical
== 0) /* .FALSE. */
1033 else /* if (cp->value.logical != 0), thus .TRUE. */
1041 /* Start a new block. */
1042 gfc_start_block (&block
);
1044 /* Calculate the switch expression. We always need to do this
1045 because it may have side effects. */
1046 gfc_init_se (&se
, NULL
);
1047 gfc_conv_expr_val (&se
, code
->expr
);
1048 gfc_add_block_to_block (&block
, &se
.pre
);
1050 if (t
== f
&& t
!= NULL
)
1052 /* Cases for .TRUE. and .FALSE. are in the same block. Just
1053 translate the code for these cases, append it to the current
1055 gfc_add_expr_to_block (&block
, gfc_trans_code (t
->next
));
1059 tree true_tree
, false_tree
;
1061 true_tree
= build_empty_stmt ();
1062 false_tree
= build_empty_stmt ();
1064 /* If we have a case for .TRUE. and for .FALSE., discard the default case.
1065 Otherwise, if .TRUE. or .FALSE. is missing and there is a default case,
1066 make the missing case the default case. */
1067 if (t
!= NULL
&& f
!= NULL
)
1077 /* Translate the code for each of these blocks, and append it to
1078 the current block. */
1080 true_tree
= gfc_trans_code (t
->next
);
1083 false_tree
= gfc_trans_code (f
->next
);
1085 gfc_add_expr_to_block (&block
, build3_v (COND_EXPR
, se
.expr
,
1086 true_tree
, false_tree
));
1089 return gfc_finish_block (&block
);
1093 /* Translate the SELECT CASE construct for CHARACTER case expressions.
1094 Instead of generating compares and jumps, it is far simpler to
1095 generate a data structure describing the cases in order and call a
1096 library subroutine that locates the right case.
1097 This is particularly true because this is the only case where we
1098 might have to dispose of a temporary.
1099 The library subroutine returns a pointer to jump to or NULL if no
1100 branches are to be taken. */
1103 gfc_trans_character_select (gfc_code
*code
)
1105 tree init
, node
, end_label
, tmp
, type
, args
, *labels
;
1106 stmtblock_t block
, body
;
1112 static tree select_struct
;
1113 static tree ss_string1
, ss_string1_len
;
1114 static tree ss_string2
, ss_string2_len
;
1115 static tree ss_target
;
1117 if (select_struct
== NULL
)
1119 tree gfc_int4_type_node
= gfc_get_int_type (4);
1121 select_struct
= make_node (RECORD_TYPE
);
1122 TYPE_NAME (select_struct
) = get_identifier ("_jump_struct");
1125 #define ADD_FIELD(NAME, TYPE) \
1126 ss_##NAME = gfc_add_field_to_struct \
1127 (&(TYPE_FIELDS (select_struct)), select_struct, \
1128 get_identifier (stringize(NAME)), TYPE)
1130 ADD_FIELD (string1
, pchar_type_node
);
1131 ADD_FIELD (string1_len
, gfc_int4_type_node
);
1133 ADD_FIELD (string2
, pchar_type_node
);
1134 ADD_FIELD (string2_len
, gfc_int4_type_node
);
1136 ADD_FIELD (target
, pvoid_type_node
);
1139 gfc_finish_type (select_struct
);
1142 cp
= code
->block
->ext
.case_list
;
1143 while (cp
->left
!= NULL
)
1147 for (d
= cp
; d
; d
= d
->right
)
1151 labels
= gfc_getmem (n
* sizeof (tree
));
1155 for(i
= 0; i
< n
; i
++)
1157 labels
[i
] = gfc_build_label_decl (NULL_TREE
);
1158 TREE_USED (labels
[i
]) = 1;
1159 /* TODO: The gimplifier should do this for us, but it has
1160 inadequacies when dealing with static initializers. */
1161 FORCED_LABEL (labels
[i
]) = 1;
1164 end_label
= gfc_build_label_decl (NULL_TREE
);
1166 /* Generate the body */
1167 gfc_start_block (&block
);
1168 gfc_init_block (&body
);
1170 for (c
= code
->block
; c
; c
= c
->block
)
1172 for (d
= c
->ext
.case_list
; d
; d
= d
->next
)
1174 tmp
= build1_v (LABEL_EXPR
, labels
[d
->n
]);
1175 gfc_add_expr_to_block (&body
, tmp
);
1178 tmp
= gfc_trans_code (c
->next
);
1179 gfc_add_expr_to_block (&body
, tmp
);
1181 tmp
= build1_v (GOTO_EXPR
, end_label
);
1182 gfc_add_expr_to_block (&body
, tmp
);
1185 /* Generate the structure describing the branches */
1189 for(d
= cp
; d
; d
= d
->right
, i
++)
1193 gfc_init_se (&se
, NULL
);
1197 node
= tree_cons (ss_string1
, null_pointer_node
, node
);
1198 node
= tree_cons (ss_string1_len
, integer_zero_node
, node
);
1202 gfc_conv_expr_reference (&se
, d
->low
);
1204 node
= tree_cons (ss_string1
, se
.expr
, node
);
1205 node
= tree_cons (ss_string1_len
, se
.string_length
, node
);
1208 if (d
->high
== NULL
)
1210 node
= tree_cons (ss_string2
, null_pointer_node
, node
);
1211 node
= tree_cons (ss_string2_len
, integer_zero_node
, node
);
1215 gfc_init_se (&se
, NULL
);
1216 gfc_conv_expr_reference (&se
, d
->high
);
1218 node
= tree_cons (ss_string2
, se
.expr
, node
);
1219 node
= tree_cons (ss_string2_len
, se
.string_length
, node
);
1222 tmp
= gfc_build_addr_expr (pvoid_type_node
, labels
[i
]);
1223 node
= tree_cons (ss_target
, tmp
, node
);
1225 tmp
= build_constructor_from_list (select_struct
, nreverse (node
));
1226 init
= tree_cons (NULL_TREE
, tmp
, init
);
1229 type
= build_array_type (select_struct
, build_index_type
1230 (build_int_cst (NULL_TREE
, n
- 1)));
1232 init
= build_constructor_from_list (type
, nreverse(init
));
1233 TREE_CONSTANT (init
) = 1;
1234 TREE_INVARIANT (init
) = 1;
1235 TREE_STATIC (init
) = 1;
1236 /* Create a static variable to hold the jump table. */
1237 tmp
= gfc_create_var (type
, "jumptable");
1238 TREE_CONSTANT (tmp
) = 1;
1239 TREE_INVARIANT (tmp
) = 1;
1240 TREE_STATIC (tmp
) = 1;
1241 DECL_INITIAL (tmp
) = init
;
1244 /* Build an argument list for the library call */
1245 init
= gfc_build_addr_expr (pvoid_type_node
, init
);
1246 args
= gfc_chainon_list (NULL_TREE
, init
);
1248 tmp
= build_int_cst (NULL_TREE
, n
);
1249 args
= gfc_chainon_list (args
, tmp
);
1251 tmp
= gfc_build_addr_expr (pvoid_type_node
, end_label
);
1252 args
= gfc_chainon_list (args
, tmp
);
1254 gfc_init_se (&se
, NULL
);
1255 gfc_conv_expr_reference (&se
, code
->expr
);
1257 args
= gfc_chainon_list (args
, se
.expr
);
1258 args
= gfc_chainon_list (args
, se
.string_length
);
1260 gfc_add_block_to_block (&block
, &se
.pre
);
1262 tmp
= gfc_build_function_call (gfor_fndecl_select_string
, args
);
1263 tmp
= build1 (GOTO_EXPR
, void_type_node
, tmp
);
1264 gfc_add_expr_to_block (&block
, tmp
);
1266 tmp
= gfc_finish_block (&body
);
1267 gfc_add_expr_to_block (&block
, tmp
);
1268 tmp
= build1_v (LABEL_EXPR
, end_label
);
1269 gfc_add_expr_to_block (&block
, tmp
);
1274 return gfc_finish_block (&block
);
1278 /* Translate the three variants of the SELECT CASE construct.
1280 SELECT CASEs with INTEGER case expressions can be translated to an
1281 equivalent GENERIC switch statement, and for LOGICAL case
1282 expressions we build one or two if-else compares.
1284 SELECT CASEs with CHARACTER case expressions are a whole different
1285 story, because they don't exist in GENERIC. So we sort them and
1286 do a binary search at runtime.
1288 Fortran has no BREAK statement, and it does not allow jumps from
1289 one case block to another. That makes things a lot easier for
1293 gfc_trans_select (gfc_code
* code
)
1295 gcc_assert (code
&& code
->expr
);
1297 /* Empty SELECT constructs are legal. */
1298 if (code
->block
== NULL
)
1299 return build_empty_stmt ();
1301 /* Select the correct translation function. */
1302 switch (code
->expr
->ts
.type
)
1304 case BT_LOGICAL
: return gfc_trans_logical_select (code
);
1305 case BT_INTEGER
: return gfc_trans_integer_select (code
);
1306 case BT_CHARACTER
: return gfc_trans_character_select (code
);
1308 gfc_internal_error ("gfc_trans_select(): Bad type for case expr.");
1314 /* Generate the loops for a FORALL block. The normal loop format:
1315 count = (end - start + step) / step
1328 gfc_trans_forall_loop (forall_info
*forall_tmp
, int nvar
, tree body
, int mask_flag
)
1336 tree var
, start
, end
, step
;
1339 iter
= forall_tmp
->this_loop
;
1340 for (n
= 0; n
< nvar
; n
++)
1343 start
= iter
->start
;
1347 exit_label
= gfc_build_label_decl (NULL_TREE
);
1348 TREE_USED (exit_label
) = 1;
1350 /* The loop counter. */
1351 count
= gfc_create_var (TREE_TYPE (var
), "count");
1353 /* The body of the loop. */
1354 gfc_init_block (&block
);
1356 /* The exit condition. */
1357 cond
= build2 (LE_EXPR
, boolean_type_node
, count
, integer_zero_node
);
1358 tmp
= build1_v (GOTO_EXPR
, exit_label
);
1359 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt ());
1360 gfc_add_expr_to_block (&block
, tmp
);
1362 /* The main loop body. */
1363 gfc_add_expr_to_block (&block
, body
);
1365 /* Increment the loop variable. */
1366 tmp
= build2 (PLUS_EXPR
, TREE_TYPE (var
), var
, step
);
1367 gfc_add_modify_expr (&block
, var
, tmp
);
1369 /* Advance to the next mask element. Only do this for the
1371 if (n
== 0 && mask_flag
&& forall_tmp
->mask
)
1373 tree maskindex
= forall_tmp
->maskindex
;
1374 tmp
= build2 (PLUS_EXPR
, gfc_array_index_type
,
1375 maskindex
, gfc_index_one_node
);
1376 gfc_add_modify_expr (&block
, maskindex
, tmp
);
1379 /* Decrement the loop counter. */
1380 tmp
= build2 (MINUS_EXPR
, TREE_TYPE (var
), count
, gfc_index_one_node
);
1381 gfc_add_modify_expr (&block
, count
, tmp
);
1383 body
= gfc_finish_block (&block
);
1385 /* Loop var initialization. */
1386 gfc_init_block (&block
);
1387 gfc_add_modify_expr (&block
, var
, start
);
1389 /* Initialize maskindex counter. Only do this before the
1391 if (n
== nvar
- 1 && mask_flag
&& forall_tmp
->mask
)
1392 gfc_add_modify_expr (&block
, forall_tmp
->maskindex
,
1393 gfc_index_zero_node
);
1395 /* Initialize the loop counter. */
1396 tmp
= fold_build2 (MINUS_EXPR
, TREE_TYPE (var
), step
, start
);
1397 tmp
= fold_build2 (PLUS_EXPR
, TREE_TYPE (var
), end
, tmp
);
1398 tmp
= fold_build2 (TRUNC_DIV_EXPR
, TREE_TYPE (var
), tmp
, step
);
1399 gfc_add_modify_expr (&block
, count
, tmp
);
1401 /* The loop expression. */
1402 tmp
= build1_v (LOOP_EXPR
, body
);
1403 gfc_add_expr_to_block (&block
, tmp
);
1405 /* The exit label. */
1406 tmp
= build1_v (LABEL_EXPR
, exit_label
);
1407 gfc_add_expr_to_block (&block
, tmp
);
1409 body
= gfc_finish_block (&block
);
1416 /* Generate the body and loops according to MASK_FLAG and NEST_FLAG.
1417 if MASK_FLAG is nonzero, the body is controlled by maskes in forall
1418 nest, otherwise, the body is not controlled by maskes.
1419 if NEST_FLAG is nonzero, generate loops for nested forall, otherwise,
1420 only generate loops for the current forall level. */
1423 gfc_trans_nested_forall_loop (forall_info
* nested_forall_info
, tree body
,
1424 int mask_flag
, int nest_flag
)
1428 forall_info
*forall_tmp
;
1429 tree pmask
, mask
, maskindex
;
1431 forall_tmp
= nested_forall_info
;
1432 /* Generate loops for nested forall. */
1435 while (forall_tmp
->next_nest
!= NULL
)
1436 forall_tmp
= forall_tmp
->next_nest
;
1437 while (forall_tmp
!= NULL
)
1439 /* Generate body with masks' control. */
1442 pmask
= forall_tmp
->pmask
;
1443 mask
= forall_tmp
->mask
;
1444 maskindex
= forall_tmp
->maskindex
;
1448 /* If a mask was specified make the assignment conditional. */
1450 tmp
= gfc_build_indirect_ref (mask
);
1453 tmp
= gfc_build_array_ref (tmp
, maskindex
);
1455 body
= build3_v (COND_EXPR
, tmp
, body
, build_empty_stmt ());
1458 nvar
= forall_tmp
->nvar
;
1459 body
= gfc_trans_forall_loop (forall_tmp
, nvar
, body
, mask_flag
);
1460 forall_tmp
= forall_tmp
->outer
;
1465 nvar
= forall_tmp
->nvar
;
1466 body
= gfc_trans_forall_loop (forall_tmp
, nvar
, body
, mask_flag
);
1473 /* Allocate data for holding a temporary array. Returns either a local
1474 temporary array or a pointer variable. */
1477 gfc_do_allocate (tree bytesize
, tree size
, tree
* pdata
, stmtblock_t
* pblock
,
1485 if (INTEGER_CST_P (size
))
1487 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, size
,
1488 gfc_index_one_node
);
1493 type
= build_range_type (gfc_array_index_type
, gfc_index_zero_node
, tmp
);
1494 type
= build_array_type (elem_type
, type
);
1495 if (gfc_can_put_var_on_stack (bytesize
))
1497 gcc_assert (INTEGER_CST_P (size
));
1498 tmpvar
= gfc_create_var (type
, "temp");
1503 tmpvar
= gfc_create_var (build_pointer_type (type
), "temp");
1504 *pdata
= convert (pvoid_type_node
, tmpvar
);
1506 args
= gfc_chainon_list (NULL_TREE
, bytesize
);
1507 if (gfc_index_integer_kind
== 4)
1508 tmp
= gfor_fndecl_internal_malloc
;
1509 else if (gfc_index_integer_kind
== 8)
1510 tmp
= gfor_fndecl_internal_malloc64
;
1513 tmp
= gfc_build_function_call (tmp
, args
);
1514 tmp
= convert (TREE_TYPE (tmpvar
), tmp
);
1515 gfc_add_modify_expr (pblock
, tmpvar
, tmp
);
1521 /* Generate codes to copy the temporary to the actual lhs. */
1524 generate_loop_for_temp_to_lhs (gfc_expr
*expr
, tree tmp1
, tree count3
,
1525 tree count1
, tree wheremask
)
1529 stmtblock_t block
, body
;
1535 lss
= gfc_walk_expr (expr
);
1537 if (lss
== gfc_ss_terminator
)
1539 gfc_start_block (&block
);
1541 gfc_init_se (&lse
, NULL
);
1543 /* Translate the expression. */
1544 gfc_conv_expr (&lse
, expr
);
1546 /* Form the expression for the temporary. */
1547 tmp
= gfc_build_array_ref (tmp1
, count1
);
1549 /* Use the scalar assignment as is. */
1550 gfc_add_block_to_block (&block
, &lse
.pre
);
1551 gfc_add_modify_expr (&block
, lse
.expr
, tmp
);
1552 gfc_add_block_to_block (&block
, &lse
.post
);
1554 /* Increment the count1. */
1555 tmp
= fold_build2 (PLUS_EXPR
, TREE_TYPE (count1
), count1
,
1556 gfc_index_one_node
);
1557 gfc_add_modify_expr (&block
, count1
, tmp
);
1559 tmp
= gfc_finish_block (&block
);
1563 gfc_start_block (&block
);
1565 gfc_init_loopinfo (&loop1
);
1566 gfc_init_se (&rse
, NULL
);
1567 gfc_init_se (&lse
, NULL
);
1569 /* Associate the lss with the loop. */
1570 gfc_add_ss_to_loop (&loop1
, lss
);
1572 /* Calculate the bounds of the scalarization. */
1573 gfc_conv_ss_startstride (&loop1
);
1574 /* Setup the scalarizing loops. */
1575 gfc_conv_loop_setup (&loop1
);
1577 gfc_mark_ss_chain_used (lss
, 1);
1579 /* Start the scalarized loop body. */
1580 gfc_start_scalarized_body (&loop1
, &body
);
1582 /* Setup the gfc_se structures. */
1583 gfc_copy_loopinfo_to_se (&lse
, &loop1
);
1586 /* Form the expression of the temporary. */
1587 if (lss
!= gfc_ss_terminator
)
1588 rse
.expr
= gfc_build_array_ref (tmp1
, count1
);
1589 /* Translate expr. */
1590 gfc_conv_expr (&lse
, expr
);
1592 /* Use the scalar assignment. */
1593 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
.type
);
1595 /* Form the mask expression according to the mask tree list. */
1598 wheremaskexpr
= gfc_build_array_ref (wheremask
, count3
);
1599 tmp2
= TREE_CHAIN (wheremask
);
1602 tmp1
= gfc_build_array_ref (tmp2
, count3
);
1603 wheremaskexpr
= build2 (TRUTH_AND_EXPR
, TREE_TYPE (tmp1
),
1604 wheremaskexpr
, tmp1
);
1605 tmp2
= TREE_CHAIN (tmp2
);
1607 tmp
= build3_v (COND_EXPR
, wheremaskexpr
, tmp
, build_empty_stmt ());
1610 gfc_add_expr_to_block (&body
, tmp
);
1612 /* Increment count1. */
1613 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
1614 count1
, gfc_index_one_node
);
1615 gfc_add_modify_expr (&body
, count1
, tmp
);
1617 /* Increment count3. */
1620 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
1621 count3
, gfc_index_one_node
);
1622 gfc_add_modify_expr (&body
, count3
, tmp
);
1625 /* Generate the copying loops. */
1626 gfc_trans_scalarizing_loops (&loop1
, &body
);
1627 gfc_add_block_to_block (&block
, &loop1
.pre
);
1628 gfc_add_block_to_block (&block
, &loop1
.post
);
1629 gfc_cleanup_loop (&loop1
);
1631 tmp
= gfc_finish_block (&block
);
1637 /* Generate codes to copy rhs to the temporary. TMP1 is the address of temporary
1638 LSS and RSS are formed in function compute_inner_temp_size(), and should
1642 generate_loop_for_rhs_to_temp (gfc_expr
*expr2
, tree tmp1
, tree count3
,
1643 tree count1
, gfc_ss
*lss
, gfc_ss
*rss
,
1646 stmtblock_t block
, body1
;
1653 gfc_start_block (&block
);
1655 gfc_init_se (&rse
, NULL
);
1656 gfc_init_se (&lse
, NULL
);
1658 if (lss
== gfc_ss_terminator
)
1660 gfc_init_block (&body1
);
1661 gfc_conv_expr (&rse
, expr2
);
1662 lse
.expr
= gfc_build_array_ref (tmp1
, count1
);
1666 /* Initialize the loop. */
1667 gfc_init_loopinfo (&loop
);
1669 /* We may need LSS to determine the shape of the expression. */
1670 gfc_add_ss_to_loop (&loop
, lss
);
1671 gfc_add_ss_to_loop (&loop
, rss
);
1673 gfc_conv_ss_startstride (&loop
);
1674 gfc_conv_loop_setup (&loop
);
1676 gfc_mark_ss_chain_used (rss
, 1);
1677 /* Start the loop body. */
1678 gfc_start_scalarized_body (&loop
, &body1
);
1680 /* Translate the expression. */
1681 gfc_copy_loopinfo_to_se (&rse
, &loop
);
1683 gfc_conv_expr (&rse
, expr2
);
1685 /* Form the expression of the temporary. */
1686 lse
.expr
= gfc_build_array_ref (tmp1
, count1
);
1689 /* Use the scalar assignment. */
1690 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr2
->ts
.type
);
1692 /* Form the mask expression according to the mask tree list. */
1695 wheremaskexpr
= gfc_build_array_ref (wheremask
, count3
);
1696 tmp2
= TREE_CHAIN (wheremask
);
1699 tmp1
= gfc_build_array_ref (tmp2
, count3
);
1700 wheremaskexpr
= build2 (TRUTH_AND_EXPR
, TREE_TYPE (tmp1
),
1701 wheremaskexpr
, tmp1
);
1702 tmp2
= TREE_CHAIN (tmp2
);
1704 tmp
= build3_v (COND_EXPR
, wheremaskexpr
, tmp
, build_empty_stmt ());
1707 gfc_add_expr_to_block (&body1
, tmp
);
1709 if (lss
== gfc_ss_terminator
)
1711 gfc_add_block_to_block (&block
, &body1
);
1713 /* Increment count1. */
1714 tmp
= fold_build2 (PLUS_EXPR
, TREE_TYPE (count1
), count1
,
1715 gfc_index_one_node
);
1716 gfc_add_modify_expr (&block
, count1
, tmp
);
1720 /* Increment count1. */
1721 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
1722 count1
, gfc_index_one_node
);
1723 gfc_add_modify_expr (&body1
, count1
, tmp
);
1725 /* Increment count3. */
1728 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
1729 count3
, gfc_index_one_node
);
1730 gfc_add_modify_expr (&body1
, count3
, tmp
);
1733 /* Generate the copying loops. */
1734 gfc_trans_scalarizing_loops (&loop
, &body1
);
1736 gfc_add_block_to_block (&block
, &loop
.pre
);
1737 gfc_add_block_to_block (&block
, &loop
.post
);
1739 gfc_cleanup_loop (&loop
);
1740 /* TODO: Reuse lss and rss when copying temp->lhs. Need to be careful
1741 as tree nodes in SS may not be valid in different scope. */
1744 tmp
= gfc_finish_block (&block
);
1749 /* Calculate the size of temporary needed in the assignment inside forall.
1750 LSS and RSS are filled in this function. */
1753 compute_inner_temp_size (gfc_expr
*expr1
, gfc_expr
*expr2
,
1754 stmtblock_t
* pblock
,
1755 gfc_ss
**lss
, gfc_ss
**rss
)
1762 *lss
= gfc_walk_expr (expr1
);
1765 size
= gfc_index_one_node
;
1766 if (*lss
!= gfc_ss_terminator
)
1768 gfc_init_loopinfo (&loop
);
1770 /* Walk the RHS of the expression. */
1771 *rss
= gfc_walk_expr (expr2
);
1772 if (*rss
== gfc_ss_terminator
)
1774 /* The rhs is scalar. Add a ss for the expression. */
1775 *rss
= gfc_get_ss ();
1776 (*rss
)->next
= gfc_ss_terminator
;
1777 (*rss
)->type
= GFC_SS_SCALAR
;
1778 (*rss
)->expr
= expr2
;
1781 /* Associate the SS with the loop. */
1782 gfc_add_ss_to_loop (&loop
, *lss
);
1783 /* We don't actually need to add the rhs at this point, but it might
1784 make guessing the loop bounds a bit easier. */
1785 gfc_add_ss_to_loop (&loop
, *rss
);
1787 /* We only want the shape of the expression, not rest of the junk
1788 generated by the scalarizer. */
1789 loop
.array_parameter
= 1;
1791 /* Calculate the bounds of the scalarization. */
1792 gfc_conv_ss_startstride (&loop
);
1793 gfc_conv_loop_setup (&loop
);
1795 /* Figure out how many elements we need. */
1796 for (i
= 0; i
< loop
.dimen
; i
++)
1798 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
1799 gfc_index_one_node
, loop
.from
[i
]);
1800 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
1802 size
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, size
, tmp
);
1804 gfc_add_block_to_block (pblock
, &loop
.pre
);
1805 size
= gfc_evaluate_now (size
, pblock
);
1806 gfc_add_block_to_block (pblock
, &loop
.post
);
1808 /* TODO: write a function that cleans up a loopinfo without freeing
1809 the SS chains. Currently a NOP. */
1816 /* Calculate the overall iterator number of the nested forall construct. */
1819 compute_overall_iter_number (forall_info
*nested_forall_info
, tree inner_size
,
1820 stmtblock_t
*inner_size_body
, stmtblock_t
*block
)
1825 /* TODO: optimizing the computing process. */
1826 number
= gfc_create_var (gfc_array_index_type
, "num");
1827 gfc_add_modify_expr (block
, number
, gfc_index_zero_node
);
1829 gfc_start_block (&body
);
1830 if (inner_size_body
)
1831 gfc_add_block_to_block (&body
, inner_size_body
);
1832 if (nested_forall_info
)
1833 tmp
= build2 (PLUS_EXPR
, gfc_array_index_type
, number
,
1837 gfc_add_modify_expr (&body
, number
, tmp
);
1838 tmp
= gfc_finish_block (&body
);
1840 /* Generate loops. */
1841 if (nested_forall_info
!= NULL
)
1842 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, tmp
, 0, 1);
1844 gfc_add_expr_to_block (block
, tmp
);
1850 /* Allocate temporary for forall construct. SIZE is the size of temporary
1851 needed. PTEMP1 is returned for space free. */
1854 allocate_temp_for_forall_nest_1 (tree type
, tree size
, stmtblock_t
* block
,
1862 unit
= TYPE_SIZE_UNIT (type
);
1863 bytesize
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, size
, unit
);
1866 temp1
= gfc_do_allocate (bytesize
, size
, ptemp1
, block
, type
);
1869 tmp
= gfc_build_indirect_ref (temp1
);
1877 /* Allocate temporary for forall construct according to the information in
1878 nested_forall_info. INNER_SIZE is the size of temporary needed in the
1879 assignment inside forall. PTEMP1 is returned for space free. */
1882 allocate_temp_for_forall_nest (forall_info
* nested_forall_info
, tree type
,
1883 tree inner_size
, stmtblock_t
* inner_size_body
,
1884 stmtblock_t
* block
, tree
* ptemp1
)
1888 /* Calculate the total size of temporary needed in forall construct. */
1889 size
= compute_overall_iter_number (nested_forall_info
, inner_size
,
1890 inner_size_body
, block
);
1892 return allocate_temp_for_forall_nest_1 (type
, size
, block
, ptemp1
);
1896 /* Handle assignments inside forall which need temporary.
1898 forall (i=start:end:stride; maskexpr)
1901 (where e,f<i> are arbitrary expressions possibly involving i
1902 and there is a dependency between e<i> and f<i>)
1904 masktmp(:) = maskexpr(:)
1909 for (i = start; i <= end; i += stride)
1913 for (i = start; i <= end; i += stride)
1915 if (masktmp[maskindex++])
1916 tmp[count1++] = f<i>
1920 for (i = start; i <= end; i += stride)
1922 if (masktmp[maskindex++])
1923 e<i> = tmp[count1++]
1928 gfc_trans_assign_need_temp (gfc_expr
* expr1
, gfc_expr
* expr2
, tree wheremask
,
1929 forall_info
* nested_forall_info
,
1930 stmtblock_t
* block
)
1938 stmtblock_t inner_size_body
;
1940 /* Create vars. count1 is the current iterator number of the nested
1942 count1
= gfc_create_var (gfc_array_index_type
, "count1");
1944 /* Count is the wheremask index. */
1947 count
= gfc_create_var (gfc_array_index_type
, "count");
1948 gfc_add_modify_expr (block
, count
, gfc_index_zero_node
);
1953 /* Initialize count1. */
1954 gfc_add_modify_expr (block
, count1
, gfc_index_zero_node
);
1956 /* Calculate the size of temporary needed in the assignment. Return loop, lss
1957 and rss which are used in function generate_loop_for_rhs_to_temp(). */
1958 gfc_init_block (&inner_size_body
);
1959 inner_size
= compute_inner_temp_size (expr1
, expr2
, &inner_size_body
,
1962 /* The type of LHS. Used in function allocate_temp_for_forall_nest */
1963 type
= gfc_typenode_for_spec (&expr1
->ts
);
1965 /* Allocate temporary for nested forall construct according to the
1966 information in nested_forall_info and inner_size. */
1967 tmp1
= allocate_temp_for_forall_nest (nested_forall_info
, type
, inner_size
,
1968 &inner_size_body
, block
, &ptemp1
);
1970 /* Generate codes to copy rhs to the temporary . */
1971 tmp
= generate_loop_for_rhs_to_temp (expr2
, tmp1
, count
, count1
, lss
, rss
,
1974 /* Generate body and loops according to the information in
1975 nested_forall_info. */
1976 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, tmp
, 1, 1);
1977 gfc_add_expr_to_block (block
, tmp
);
1980 gfc_add_modify_expr (block
, count1
, gfc_index_zero_node
);
1984 gfc_add_modify_expr (block
, count
, gfc_index_zero_node
);
1986 /* Generate codes to copy the temporary to lhs. */
1987 tmp
= generate_loop_for_temp_to_lhs (expr1
, tmp1
, count
, count1
, wheremask
);
1989 /* Generate body and loops according to the information in
1990 nested_forall_info. */
1991 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, tmp
, 1, 1);
1992 gfc_add_expr_to_block (block
, tmp
);
1996 /* Free the temporary. */
1997 tmp
= gfc_chainon_list (NULL_TREE
, ptemp1
);
1998 tmp
= gfc_build_function_call (gfor_fndecl_internal_free
, tmp
);
1999 gfc_add_expr_to_block (block
, tmp
);
2004 /* Translate pointer assignment inside FORALL which need temporary. */
2007 gfc_trans_pointer_assign_need_temp (gfc_expr
* expr1
, gfc_expr
* expr2
,
2008 forall_info
* nested_forall_info
,
2009 stmtblock_t
* block
)
2023 tree tmp
, tmp1
, ptemp1
;
2025 count
= gfc_create_var (gfc_array_index_type
, "count");
2026 gfc_add_modify_expr (block
, count
, gfc_index_zero_node
);
2028 inner_size
= integer_one_node
;
2029 lss
= gfc_walk_expr (expr1
);
2030 rss
= gfc_walk_expr (expr2
);
2031 if (lss
== gfc_ss_terminator
)
2033 type
= gfc_typenode_for_spec (&expr1
->ts
);
2034 type
= build_pointer_type (type
);
2036 /* Allocate temporary for nested forall construct according to the
2037 information in nested_forall_info and inner_size. */
2038 tmp1
= allocate_temp_for_forall_nest (nested_forall_info
, type
,
2039 inner_size
, NULL
, block
, &ptemp1
);
2040 gfc_start_block (&body
);
2041 gfc_init_se (&lse
, NULL
);
2042 lse
.expr
= gfc_build_array_ref (tmp1
, count
);
2043 gfc_init_se (&rse
, NULL
);
2044 rse
.want_pointer
= 1;
2045 gfc_conv_expr (&rse
, expr2
);
2046 gfc_add_block_to_block (&body
, &rse
.pre
);
2047 gfc_add_modify_expr (&body
, lse
.expr
, rse
.expr
);
2048 gfc_add_block_to_block (&body
, &rse
.post
);
2050 /* Increment count. */
2051 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
2052 count
, gfc_index_one_node
);
2053 gfc_add_modify_expr (&body
, count
, tmp
);
2055 tmp
= gfc_finish_block (&body
);
2057 /* Generate body and loops according to the information in
2058 nested_forall_info. */
2059 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, tmp
, 1, 1);
2060 gfc_add_expr_to_block (block
, tmp
);
2063 gfc_add_modify_expr (block
, count
, gfc_index_zero_node
);
2065 gfc_start_block (&body
);
2066 gfc_init_se (&lse
, NULL
);
2067 gfc_init_se (&rse
, NULL
);
2068 rse
.expr
= gfc_build_array_ref (tmp1
, count
);
2069 lse
.want_pointer
= 1;
2070 gfc_conv_expr (&lse
, expr1
);
2071 gfc_add_block_to_block (&body
, &lse
.pre
);
2072 gfc_add_modify_expr (&body
, lse
.expr
, rse
.expr
);
2073 gfc_add_block_to_block (&body
, &lse
.post
);
2074 /* Increment count. */
2075 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
2076 count
, gfc_index_one_node
);
2077 gfc_add_modify_expr (&body
, count
, tmp
);
2078 tmp
= gfc_finish_block (&body
);
2080 /* Generate body and loops according to the information in
2081 nested_forall_info. */
2082 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, tmp
, 1, 1);
2083 gfc_add_expr_to_block (block
, tmp
);
2087 gfc_init_loopinfo (&loop
);
2089 /* Associate the SS with the loop. */
2090 gfc_add_ss_to_loop (&loop
, rss
);
2092 /* Setup the scalarizing loops and bounds. */
2093 gfc_conv_ss_startstride (&loop
);
2095 gfc_conv_loop_setup (&loop
);
2097 info
= &rss
->data
.info
;
2098 desc
= info
->descriptor
;
2100 /* Make a new descriptor. */
2101 parmtype
= gfc_get_element_type (TREE_TYPE (desc
));
2102 parmtype
= gfc_get_array_type_bounds (parmtype
, loop
.dimen
,
2103 loop
.from
, loop
.to
, 1);
2105 /* Allocate temporary for nested forall construct. */
2106 tmp1
= allocate_temp_for_forall_nest (nested_forall_info
, parmtype
,
2107 inner_size
, NULL
, block
, &ptemp1
);
2108 gfc_start_block (&body
);
2109 gfc_init_se (&lse
, NULL
);
2110 lse
.expr
= gfc_build_array_ref (tmp1
, count
);
2111 lse
.direct_byref
= 1;
2112 rss
= gfc_walk_expr (expr2
);
2113 gfc_conv_expr_descriptor (&lse
, expr2
, rss
);
2115 gfc_add_block_to_block (&body
, &lse
.pre
);
2116 gfc_add_block_to_block (&body
, &lse
.post
);
2118 /* Increment count. */
2119 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
2120 count
, gfc_index_one_node
);
2121 gfc_add_modify_expr (&body
, count
, tmp
);
2123 tmp
= gfc_finish_block (&body
);
2125 /* Generate body and loops according to the information in
2126 nested_forall_info. */
2127 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, tmp
, 1, 1);
2128 gfc_add_expr_to_block (block
, tmp
);
2131 gfc_add_modify_expr (block
, count
, gfc_index_zero_node
);
2133 parm
= gfc_build_array_ref (tmp1
, count
);
2134 lss
= gfc_walk_expr (expr1
);
2135 gfc_init_se (&lse
, NULL
);
2136 gfc_conv_expr_descriptor (&lse
, expr1
, lss
);
2137 gfc_add_modify_expr (&lse
.pre
, lse
.expr
, parm
);
2138 gfc_start_block (&body
);
2139 gfc_add_block_to_block (&body
, &lse
.pre
);
2140 gfc_add_block_to_block (&body
, &lse
.post
);
2142 /* Increment count. */
2143 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
2144 count
, gfc_index_one_node
);
2145 gfc_add_modify_expr (&body
, count
, tmp
);
2147 tmp
= gfc_finish_block (&body
);
2149 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, tmp
, 1, 1);
2150 gfc_add_expr_to_block (block
, tmp
);
2152 /* Free the temporary. */
2155 tmp
= gfc_chainon_list (NULL_TREE
, ptemp1
);
2156 tmp
= gfc_build_function_call (gfor_fndecl_internal_free
, tmp
);
2157 gfc_add_expr_to_block (block
, tmp
);
2162 /* FORALL and WHERE statements are really nasty, especially when you nest
2163 them. All the rhs of a forall assignment must be evaluated before the
2164 actual assignments are performed. Presumably this also applies to all the
2165 assignments in an inner where statement. */
2167 /* Generate code for a FORALL statement. Any temporaries are allocated as a
2168 linear array, relying on the fact that we process in the same order in all
2171 forall (i=start:end:stride; maskexpr)
2175 (where e,f,g,h<i> are arbitrary expressions possibly involving i)
2177 count = ((end + 1 - start) / stride)
2178 masktmp(:) = maskexpr(:)
2181 for (i = start; i <= end; i += stride)
2183 if (masktmp[maskindex++])
2187 for (i = start; i <= end; i += stride)
2189 if (masktmp[maskindex++])
2193 Note that this code only works when there are no dependencies.
2194 Forall loop with array assignments and data dependencies are a real pain,
2195 because the size of the temporary cannot always be determined before the
2196 loop is executed. This problem is compounded by the presence of nested
2201 gfc_trans_forall_1 (gfc_code
* code
, forall_info
* nested_forall_info
)
2223 gfc_forall_iterator
*fa
;
2226 gfc_saved_var
*saved_vars
;
2227 iter_info
*this_forall
, *iter_tmp
;
2228 forall_info
*info
, *forall_tmp
;
2229 temporary_list
*temp
;
2231 gfc_start_block (&block
);
2234 /* Count the FORALL index number. */
2235 for (fa
= code
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
2239 /* Allocate the space for var, start, end, step, varexpr. */
2240 var
= (tree
*) gfc_getmem (nvar
* sizeof (tree
));
2241 start
= (tree
*) gfc_getmem (nvar
* sizeof (tree
));
2242 end
= (tree
*) gfc_getmem (nvar
* sizeof (tree
));
2243 step
= (tree
*) gfc_getmem (nvar
* sizeof (tree
));
2244 varexpr
= (gfc_expr
**) gfc_getmem (nvar
* sizeof (gfc_expr
*));
2245 saved_vars
= (gfc_saved_var
*) gfc_getmem (nvar
* sizeof (gfc_saved_var
));
2247 /* Allocate the space for info. */
2248 info
= (forall_info
*) gfc_getmem (sizeof (forall_info
));
2250 for (fa
= code
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
2252 gfc_symbol
*sym
= fa
->var
->symtree
->n
.sym
;
2254 /* allocate space for this_forall. */
2255 this_forall
= (iter_info
*) gfc_getmem (sizeof (iter_info
));
2257 /* Create a temporary variable for the FORALL index. */
2258 tmp
= gfc_typenode_for_spec (&sym
->ts
);
2259 var
[n
] = gfc_create_var (tmp
, sym
->name
);
2260 gfc_shadow_sym (sym
, var
[n
], &saved_vars
[n
]);
2262 /* Record it in this_forall. */
2263 this_forall
->var
= var
[n
];
2265 /* Replace the index symbol's backend_decl with the temporary decl. */
2266 sym
->backend_decl
= var
[n
];
2268 /* Work out the start, end and stride for the loop. */
2269 gfc_init_se (&se
, NULL
);
2270 gfc_conv_expr_val (&se
, fa
->start
);
2271 /* Record it in this_forall. */
2272 this_forall
->start
= se
.expr
;
2273 gfc_add_block_to_block (&block
, &se
.pre
);
2276 gfc_init_se (&se
, NULL
);
2277 gfc_conv_expr_val (&se
, fa
->end
);
2278 /* Record it in this_forall. */
2279 this_forall
->end
= se
.expr
;
2280 gfc_make_safe_expr (&se
);
2281 gfc_add_block_to_block (&block
, &se
.pre
);
2284 gfc_init_se (&se
, NULL
);
2285 gfc_conv_expr_val (&se
, fa
->stride
);
2286 /* Record it in this_forall. */
2287 this_forall
->step
= se
.expr
;
2288 gfc_make_safe_expr (&se
);
2289 gfc_add_block_to_block (&block
, &se
.pre
);
2292 /* Set the NEXT field of this_forall to NULL. */
2293 this_forall
->next
= NULL
;
2294 /* Link this_forall to the info construct. */
2295 if (info
->this_loop
== NULL
)
2296 info
->this_loop
= this_forall
;
2299 iter_tmp
= info
->this_loop
;
2300 while (iter_tmp
->next
!= NULL
)
2301 iter_tmp
= iter_tmp
->next
;
2302 iter_tmp
->next
= this_forall
;
2309 /* Work out the number of elements in the mask array. */
2312 size
= gfc_index_one_node
;
2313 sizevar
= NULL_TREE
;
2315 for (n
= 0; n
< nvar
; n
++)
2317 if (lenvar
&& TREE_TYPE (lenvar
) != TREE_TYPE (start
[n
]))
2320 /* size = (end + step - start) / step. */
2321 tmp
= fold_build2 (MINUS_EXPR
, TREE_TYPE (start
[n
]),
2323 tmp
= fold_build2 (PLUS_EXPR
, TREE_TYPE (end
[n
]), end
[n
], tmp
);
2325 tmp
= fold_build2 (FLOOR_DIV_EXPR
, TREE_TYPE (tmp
), tmp
, step
[n
]);
2326 tmp
= convert (gfc_array_index_type
, tmp
);
2328 size
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, size
, tmp
);
2331 /* Record the nvar and size of current forall level. */
2335 /* Link the current forall level to nested_forall_info. */
2336 forall_tmp
= nested_forall_info
;
2337 if (forall_tmp
== NULL
)
2338 nested_forall_info
= info
;
2341 while (forall_tmp
->next_nest
!= NULL
)
2342 forall_tmp
= forall_tmp
->next_nest
;
2343 info
->outer
= forall_tmp
;
2344 forall_tmp
->next_nest
= info
;
2347 /* Copy the mask into a temporary variable if required.
2348 For now we assume a mask temporary is needed. */
2351 /* As the mask array can be very big, prefer compact
2353 tree smallest_boolean_type_node
2354 = gfc_get_logical_type (gfc_logical_kinds
[0].kind
);
2356 /* Allocate the mask temporary. */
2357 bytesize
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, size
,
2358 TYPE_SIZE_UNIT (smallest_boolean_type_node
));
2360 mask
= gfc_do_allocate (bytesize
, size
, &pmask
, &block
,
2361 smallest_boolean_type_node
);
2363 maskindex
= gfc_create_var_np (gfc_array_index_type
, "mi");
2364 /* Record them in the info structure. */
2365 info
->pmask
= pmask
;
2367 info
->maskindex
= maskindex
;
2369 gfc_add_modify_expr (&block
, maskindex
, gfc_index_zero_node
);
2371 /* Start of mask assignment loop body. */
2372 gfc_start_block (&body
);
2374 /* Evaluate the mask expression. */
2375 gfc_init_se (&se
, NULL
);
2376 gfc_conv_expr_val (&se
, code
->expr
);
2377 gfc_add_block_to_block (&body
, &se
.pre
);
2379 /* Store the mask. */
2380 se
.expr
= convert (smallest_boolean_type_node
, se
.expr
);
2383 tmp
= gfc_build_indirect_ref (mask
);
2386 tmp
= gfc_build_array_ref (tmp
, maskindex
);
2387 gfc_add_modify_expr (&body
, tmp
, se
.expr
);
2389 /* Advance to the next mask element. */
2390 tmp
= build2 (PLUS_EXPR
, gfc_array_index_type
,
2391 maskindex
, gfc_index_one_node
);
2392 gfc_add_modify_expr (&body
, maskindex
, tmp
);
2394 /* Generate the loops. */
2395 tmp
= gfc_finish_block (&body
);
2396 tmp
= gfc_trans_nested_forall_loop (info
, tmp
, 0, 0);
2397 gfc_add_expr_to_block (&block
, tmp
);
2401 /* No mask was specified. */
2402 maskindex
= NULL_TREE
;
2403 mask
= pmask
= NULL_TREE
;
2406 c
= code
->block
->next
;
2408 /* TODO: loop merging in FORALL statements. */
2409 /* Now that we've got a copy of the mask, generate the assignment loops. */
2415 /* A scalar or array assignment. */
2416 need_temp
= gfc_check_dependency (c
->expr
, c
->expr2
, varexpr
, nvar
);
2417 /* Temporaries due to array assignment data dependencies introduce
2418 no end of problems. */
2420 gfc_trans_assign_need_temp (c
->expr
, c
->expr2
, NULL
,
2421 nested_forall_info
, &block
);
2424 /* Use the normal assignment copying routines. */
2425 assign
= gfc_trans_assignment (c
->expr
, c
->expr2
);
2427 /* Generate body and loops. */
2428 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, assign
, 1, 1);
2429 gfc_add_expr_to_block (&block
, tmp
);
2436 /* Translate WHERE or WHERE construct nested in FORALL. */
2438 gfc_trans_where_2 (c
, NULL
, NULL
, nested_forall_info
, &block
, &temp
);
2445 /* Free the temporary. */
2446 args
= gfc_chainon_list (NULL_TREE
, temp
->temporary
);
2447 tmp
= gfc_build_function_call (gfor_fndecl_internal_free
, args
);
2448 gfc_add_expr_to_block (&block
, tmp
);
2457 /* Pointer assignment inside FORALL. */
2458 case EXEC_POINTER_ASSIGN
:
2459 need_temp
= gfc_check_dependency (c
->expr
, c
->expr2
, varexpr
, nvar
);
2461 gfc_trans_pointer_assign_need_temp (c
->expr
, c
->expr2
,
2462 nested_forall_info
, &block
);
2465 /* Use the normal assignment copying routines. */
2466 assign
= gfc_trans_pointer_assignment (c
->expr
, c
->expr2
);
2468 /* Generate body and loops. */
2469 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, assign
,
2471 gfc_add_expr_to_block (&block
, tmp
);
2476 tmp
= gfc_trans_forall_1 (c
, nested_forall_info
);
2477 gfc_add_expr_to_block (&block
, tmp
);
2487 /* Restore the original index variables. */
2488 for (fa
= code
->ext
.forall_iterator
, n
= 0; fa
; fa
= fa
->next
, n
++)
2489 gfc_restore_sym (fa
->var
->symtree
->n
.sym
, &saved_vars
[n
]);
2491 /* Free the space for var, start, end, step, varexpr. */
2497 gfc_free (saved_vars
);
2501 /* Free the temporary for the mask. */
2502 tmp
= gfc_chainon_list (NULL_TREE
, pmask
);
2503 tmp
= gfc_build_function_call (gfor_fndecl_internal_free
, tmp
);
2504 gfc_add_expr_to_block (&block
, tmp
);
2507 pushdecl (maskindex
);
2509 return gfc_finish_block (&block
);
2513 /* Translate the FORALL statement or construct. */
2515 tree
gfc_trans_forall (gfc_code
* code
)
2517 return gfc_trans_forall_1 (code
, NULL
);
2521 /* Evaluate the WHERE mask expression, copy its value to a temporary.
2522 If the WHERE construct is nested in FORALL, compute the overall temporary
2523 needed by the WHERE mask expression multiplied by the iterator number of
2525 ME is the WHERE mask expression.
2526 MASK is the temporary which value is mask's value.
2527 NMASK is another temporary which value is !mask.
2528 TEMP records the temporary's address allocated in this function in order to
2529 free them outside this function.
2530 MASK, NMASK and TEMP are all OUT arguments. */
2533 gfc_evaluate_where_mask (gfc_expr
* me
, forall_info
* nested_forall_info
,
2534 tree
* mask
, tree
* nmask
, temporary_list
** temp
,
2535 stmtblock_t
* block
)
2540 tree ptemp1
, ntmp
, ptemp2
;
2541 tree inner_size
, size
;
2542 stmtblock_t body
, body1
, inner_size_body
;
2547 gfc_init_loopinfo (&loop
);
2549 /* Calculate the size of temporary needed by the mask-expr. */
2550 gfc_init_block (&inner_size_body
);
2551 inner_size
= compute_inner_temp_size (me
, me
, &inner_size_body
, &lss
, &rss
);
2553 /* Calculate the total size of temporary needed. */
2554 size
= compute_overall_iter_number (nested_forall_info
, inner_size
,
2555 &inner_size_body
, block
);
2557 /* Allocate temporary for where mask. */
2558 tmp
= allocate_temp_for_forall_nest_1 (boolean_type_node
, size
, block
,
2560 /* Record the temporary address in order to free it later. */
2563 temporary_list
*tempo
;
2564 tempo
= (temporary_list
*) gfc_getmem (sizeof (temporary_list
));
2565 tempo
->temporary
= ptemp1
;
2566 tempo
->next
= *temp
;
2570 /* Allocate temporary for !mask. */
2571 ntmp
= allocate_temp_for_forall_nest_1 (boolean_type_node
, size
, block
,
2573 /* Record the temporary in order to free it later. */
2576 temporary_list
*tempo
;
2577 tempo
= (temporary_list
*) gfc_getmem (sizeof (temporary_list
));
2578 tempo
->temporary
= ptemp2
;
2579 tempo
->next
= *temp
;
2583 /* Variable to index the temporary. */
2584 count
= gfc_create_var (gfc_array_index_type
, "count");
2585 /* Initialize count. */
2586 gfc_add_modify_expr (block
, count
, gfc_index_zero_node
);
2588 gfc_start_block (&body
);
2590 gfc_init_se (&rse
, NULL
);
2591 gfc_init_se (&lse
, NULL
);
2593 if (lss
== gfc_ss_terminator
)
2595 gfc_init_block (&body1
);
2599 /* Initialize the loop. */
2600 gfc_init_loopinfo (&loop
);
2602 /* We may need LSS to determine the shape of the expression. */
2603 gfc_add_ss_to_loop (&loop
, lss
);
2604 gfc_add_ss_to_loop (&loop
, rss
);
2606 gfc_conv_ss_startstride (&loop
);
2607 gfc_conv_loop_setup (&loop
);
2609 gfc_mark_ss_chain_used (rss
, 1);
2610 /* Start the loop body. */
2611 gfc_start_scalarized_body (&loop
, &body1
);
2613 /* Translate the expression. */
2614 gfc_copy_loopinfo_to_se (&rse
, &loop
);
2616 gfc_conv_expr (&rse
, me
);
2618 /* Form the expression of the temporary. */
2619 lse
.expr
= gfc_build_array_ref (tmp
, count
);
2620 tmpexpr
= gfc_build_array_ref (ntmp
, count
);
2622 /* Use the scalar assignment to fill temporary TMP. */
2623 tmp1
= gfc_trans_scalar_assign (&lse
, &rse
, me
->ts
.type
);
2624 gfc_add_expr_to_block (&body1
, tmp1
);
2626 /* Fill temporary NTMP. */
2627 tmp1
= build1 (TRUTH_NOT_EXPR
, TREE_TYPE (lse
.expr
), lse
.expr
);
2628 gfc_add_modify_expr (&body1
, tmpexpr
, tmp1
);
2630 if (lss
== gfc_ss_terminator
)
2632 gfc_add_block_to_block (&body
, &body1
);
2636 /* Increment count. */
2637 tmp1
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
, count
,
2638 gfc_index_one_node
);
2639 gfc_add_modify_expr (&body1
, count
, tmp1
);
2641 /* Generate the copying loops. */
2642 gfc_trans_scalarizing_loops (&loop
, &body1
);
2644 gfc_add_block_to_block (&body
, &loop
.pre
);
2645 gfc_add_block_to_block (&body
, &loop
.post
);
2647 gfc_cleanup_loop (&loop
);
2648 /* TODO: Reuse lss and rss when copying temp->lhs. Need to be careful
2649 as tree nodes in SS may not be valid in different scope. */
2652 tmp1
= gfc_finish_block (&body
);
2653 /* If the WHERE construct is inside FORALL, fill the full temporary. */
2654 if (nested_forall_info
!= NULL
)
2655 tmp1
= gfc_trans_nested_forall_loop (nested_forall_info
, tmp1
, 1, 1);
2657 gfc_add_expr_to_block (block
, tmp1
);
2666 /* Translate an assignment statement in a WHERE statement or construct
2667 statement. The MASK expression is used to control which elements
2668 of EXPR1 shall be assigned. */
2671 gfc_trans_where_assign (gfc_expr
*expr1
, gfc_expr
*expr2
, tree mask
,
2672 tree count1
, tree count2
)
2677 gfc_ss
*lss_section
;
2684 tree index
, maskexpr
, tmp1
;
2687 /* TODO: handle this special case.
2688 Special case a single function returning an array. */
2689 if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->rank
> 0)
2691 tmp
= gfc_trans_arrayfunc_assign (expr1
, expr2
);
2697 /* Assignment of the form lhs = rhs. */
2698 gfc_start_block (&block
);
2700 gfc_init_se (&lse
, NULL
);
2701 gfc_init_se (&rse
, NULL
);
2704 lss
= gfc_walk_expr (expr1
);
2707 /* In each where-assign-stmt, the mask-expr and the variable being
2708 defined shall be arrays of the same shape. */
2709 gcc_assert (lss
!= gfc_ss_terminator
);
2711 /* The assignment needs scalarization. */
2714 /* Find a non-scalar SS from the lhs. */
2715 while (lss_section
!= gfc_ss_terminator
2716 && lss_section
->type
!= GFC_SS_SECTION
)
2717 lss_section
= lss_section
->next
;
2719 gcc_assert (lss_section
!= gfc_ss_terminator
);
2721 /* Initialize the scalarizer. */
2722 gfc_init_loopinfo (&loop
);
2725 rss
= gfc_walk_expr (expr2
);
2726 if (rss
== gfc_ss_terminator
)
2728 /* The rhs is scalar. Add a ss for the expression. */
2729 rss
= gfc_get_ss ();
2730 rss
->next
= gfc_ss_terminator
;
2731 rss
->type
= GFC_SS_SCALAR
;
2735 /* Associate the SS with the loop. */
2736 gfc_add_ss_to_loop (&loop
, lss
);
2737 gfc_add_ss_to_loop (&loop
, rss
);
2739 /* Calculate the bounds of the scalarization. */
2740 gfc_conv_ss_startstride (&loop
);
2742 /* Resolve any data dependencies in the statement. */
2743 gfc_conv_resolve_dependencies (&loop
, lss_section
, rss
);
2745 /* Setup the scalarizing loops. */
2746 gfc_conv_loop_setup (&loop
);
2748 /* Setup the gfc_se structures. */
2749 gfc_copy_loopinfo_to_se (&lse
, &loop
);
2750 gfc_copy_loopinfo_to_se (&rse
, &loop
);
2753 gfc_mark_ss_chain_used (rss
, 1);
2754 if (loop
.temp_ss
== NULL
)
2757 gfc_mark_ss_chain_used (lss
, 1);
2761 lse
.ss
= loop
.temp_ss
;
2762 gfc_mark_ss_chain_used (lss
, 3);
2763 gfc_mark_ss_chain_used (loop
.temp_ss
, 3);
2766 /* Start the scalarized loop body. */
2767 gfc_start_scalarized_body (&loop
, &body
);
2769 /* Translate the expression. */
2770 gfc_conv_expr (&rse
, expr2
);
2771 if (lss
!= gfc_ss_terminator
&& loop
.temp_ss
!= NULL
)
2773 gfc_conv_tmp_array_ref (&lse
);
2774 gfc_advance_se_ss_chain (&lse
);
2777 gfc_conv_expr (&lse
, expr1
);
2779 /* Form the mask expression according to the mask tree list. */
2783 maskexpr
= gfc_build_array_ref (tmp
, index
);
2787 tmp
= TREE_CHAIN (tmp
);
2790 tmp1
= gfc_build_array_ref (tmp
, index
);
2791 maskexpr
= build2 (TRUTH_AND_EXPR
, TREE_TYPE (tmp1
), maskexpr
, tmp1
);
2792 tmp
= TREE_CHAIN (tmp
);
2794 /* Use the scalar assignment as is. */
2795 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
.type
);
2796 tmp
= build3_v (COND_EXPR
, maskexpr
, tmp
, build_empty_stmt ());
2798 gfc_add_expr_to_block (&body
, tmp
);
2800 if (lss
== gfc_ss_terminator
)
2802 /* Increment count1. */
2803 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
2804 count1
, gfc_index_one_node
);
2805 gfc_add_modify_expr (&body
, count1
, tmp
);
2807 /* Use the scalar assignment as is. */
2808 gfc_add_block_to_block (&block
, &body
);
2812 gcc_assert (lse
.ss
== gfc_ss_terminator
2813 && rse
.ss
== gfc_ss_terminator
);
2815 if (loop
.temp_ss
!= NULL
)
2817 /* Increment count1 before finish the main body of a scalarized
2819 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
2820 count1
, gfc_index_one_node
);
2821 gfc_add_modify_expr (&body
, count1
, tmp
);
2822 gfc_trans_scalarized_loop_boundary (&loop
, &body
);
2824 /* We need to copy the temporary to the actual lhs. */
2825 gfc_init_se (&lse
, NULL
);
2826 gfc_init_se (&rse
, NULL
);
2827 gfc_copy_loopinfo_to_se (&lse
, &loop
);
2828 gfc_copy_loopinfo_to_se (&rse
, &loop
);
2830 rse
.ss
= loop
.temp_ss
;
2833 gfc_conv_tmp_array_ref (&rse
);
2834 gfc_advance_se_ss_chain (&rse
);
2835 gfc_conv_expr (&lse
, expr1
);
2837 gcc_assert (lse
.ss
== gfc_ss_terminator
2838 && rse
.ss
== gfc_ss_terminator
);
2840 /* Form the mask expression according to the mask tree list. */
2844 maskexpr
= gfc_build_array_ref (tmp
, index
);
2848 tmp
= TREE_CHAIN (tmp
);
2851 tmp1
= gfc_build_array_ref (tmp
, index
);
2852 maskexpr
= build2 (TRUTH_AND_EXPR
, TREE_TYPE (tmp1
),
2854 tmp
= TREE_CHAIN (tmp
);
2856 /* Use the scalar assignment as is. */
2857 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
.type
);
2858 tmp
= build3_v (COND_EXPR
, maskexpr
, tmp
, build_empty_stmt ());
2859 gfc_add_expr_to_block (&body
, tmp
);
2861 /* Increment count2. */
2862 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
2863 count2
, gfc_index_one_node
);
2864 gfc_add_modify_expr (&body
, count2
, tmp
);
2868 /* Increment count1. */
2869 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
2870 count1
, gfc_index_one_node
);
2871 gfc_add_modify_expr (&body
, count1
, tmp
);
2874 /* Generate the copying loops. */
2875 gfc_trans_scalarizing_loops (&loop
, &body
);
2877 /* Wrap the whole thing up. */
2878 gfc_add_block_to_block (&block
, &loop
.pre
);
2879 gfc_add_block_to_block (&block
, &loop
.post
);
2880 gfc_cleanup_loop (&loop
);
2883 return gfc_finish_block (&block
);
2887 /* Translate the WHERE construct or statement.
2888 This function can be called iteratively to translate the nested WHERE
2889 construct or statement.
2890 MASK is the control mask, and PMASK is the pending control mask.
2891 TEMP records the temporary address which must be freed later. */
2894 gfc_trans_where_2 (gfc_code
* code
, tree mask
, tree pmask
,
2895 forall_info
* nested_forall_info
, stmtblock_t
* block
,
2896 temporary_list
** temp
)
2902 tree tmp
, tmp1
, tmp2
;
2903 tree count1
, count2
;
2907 /* the WHERE statement or the WHERE construct statement. */
2908 cblock
= code
->block
;
2911 /* Has mask-expr. */
2914 /* Ensure that the WHERE mask be evaluated only once. */
2915 tmp2
= gfc_evaluate_where_mask (cblock
->expr
, nested_forall_info
,
2916 &tmp
, &tmp1
, temp
, block
);
2918 /* Set the control mask and the pending control mask. */
2919 /* It's a where-stmt. */
2925 /* It's a nested where-stmt. */
2926 else if (mask
&& pmask
== NULL
)
2929 /* Use the TREE_CHAIN to list the masks. */
2930 tmp2
= copy_list (mask
);
2931 pmask
= chainon (mask
, tmp1
);
2932 mask
= chainon (tmp2
, tmp
);
2934 /* It's a masked-elsewhere-stmt. */
2935 else if (mask
&& cblock
->expr
)
2938 tmp2
= copy_list (pmask
);
2941 tmp2
= chainon (tmp2
, tmp
);
2942 pmask
= chainon (mask
, tmp1
);
2946 /* It's a elsewhere-stmt. No mask-expr is present. */
2950 /* Get the assignment statement of a WHERE statement, or the first
2951 statement in where-body-construct of a WHERE construct. */
2952 cnext
= cblock
->next
;
2957 /* WHERE assignment statement. */
2959 expr1
= cnext
->expr
;
2960 expr2
= cnext
->expr2
;
2961 if (nested_forall_info
!= NULL
)
2966 nvar
= nested_forall_info
->nvar
;
2967 varexpr
= (gfc_expr
**)
2968 gfc_getmem (nvar
* sizeof (gfc_expr
*));
2969 need_temp
= gfc_check_dependency (expr1
, expr2
, varexpr
,
2972 gfc_trans_assign_need_temp (expr1
, expr2
, mask
,
2973 nested_forall_info
, block
);
2976 /* Variables to control maskexpr. */
2977 count1
= gfc_create_var (gfc_array_index_type
, "count1");
2978 count2
= gfc_create_var (gfc_array_index_type
, "count2");
2979 gfc_add_modify_expr (block
, count1
, gfc_index_zero_node
);
2980 gfc_add_modify_expr (block
, count2
, gfc_index_zero_node
);
2982 tmp
= gfc_trans_where_assign (expr1
, expr2
, mask
, count1
,
2985 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
,
2987 gfc_add_expr_to_block (block
, tmp
);
2992 /* Variables to control maskexpr. */
2993 count1
= gfc_create_var (gfc_array_index_type
, "count1");
2994 count2
= gfc_create_var (gfc_array_index_type
, "count2");
2995 gfc_add_modify_expr (block
, count1
, gfc_index_zero_node
);
2996 gfc_add_modify_expr (block
, count2
, gfc_index_zero_node
);
2998 tmp
= gfc_trans_where_assign (expr1
, expr2
, mask
, count1
,
3000 gfc_add_expr_to_block (block
, tmp
);
3005 /* WHERE or WHERE construct is part of a where-body-construct. */
3007 /* Ensure that MASK is not modified by next gfc_trans_where_2. */
3008 mask_copy
= copy_list (mask
);
3009 gfc_trans_where_2 (cnext
, mask_copy
, NULL
, nested_forall_info
,
3017 /* The next statement within the same where-body-construct. */
3018 cnext
= cnext
->next
;
3020 /* The next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt. */
3021 cblock
= cblock
->block
;
3026 /* As the WHERE or WHERE construct statement can be nested, we call
3027 gfc_trans_where_2 to do the translation, and pass the initial
3028 NULL values for both the control mask and the pending control mask. */
3031 gfc_trans_where (gfc_code
* code
)
3034 temporary_list
*temp
, *p
;
3038 gfc_start_block (&block
);
3041 gfc_trans_where_2 (code
, NULL
, NULL
, NULL
, &block
, &temp
);
3043 /* Add calls to free temporaries which were dynamically allocated. */
3046 args
= gfc_chainon_list (NULL_TREE
, temp
->temporary
);
3047 tmp
= gfc_build_function_call (gfor_fndecl_internal_free
, args
);
3048 gfc_add_expr_to_block (&block
, tmp
);
3054 return gfc_finish_block (&block
);
3058 /* CYCLE a DO loop. The label decl has already been created by
3059 gfc_trans_do(), it's in TREE_PURPOSE (backend_decl) of the gfc_code
3060 node at the head of the loop. We must mark the label as used. */
3063 gfc_trans_cycle (gfc_code
* code
)
3067 cycle_label
= TREE_PURPOSE (code
->ext
.whichloop
->backend_decl
);
3068 TREE_USED (cycle_label
) = 1;
3069 return build1_v (GOTO_EXPR
, cycle_label
);
3073 /* EXIT a DO loop. Similar to CYCLE, but now the label is in
3074 TREE_VALUE (backend_decl) of the gfc_code node at the head of the
3078 gfc_trans_exit (gfc_code
* code
)
3082 exit_label
= TREE_VALUE (code
->ext
.whichloop
->backend_decl
);
3083 TREE_USED (exit_label
) = 1;
3084 return build1_v (GOTO_EXPR
, exit_label
);
3088 /* Translate the ALLOCATE statement. */
3091 gfc_trans_allocate (gfc_code
* code
)
3104 if (!code
->ext
.alloc_list
)
3107 gfc_start_block (&block
);
3111 tree gfc_int4_type_node
= gfc_get_int_type (4);
3113 stat
= gfc_create_var (gfc_int4_type_node
, "stat");
3114 pstat
= gfc_build_addr_expr (NULL
, stat
);
3116 error_label
= gfc_build_label_decl (NULL_TREE
);
3117 TREE_USED (error_label
) = 1;
3121 pstat
= integer_zero_node
;
3122 stat
= error_label
= NULL_TREE
;
3126 for (al
= code
->ext
.alloc_list
; al
!= NULL
; al
= al
->next
)
3130 gfc_init_se (&se
, NULL
);
3131 gfc_start_block (&se
.pre
);
3133 se
.want_pointer
= 1;
3134 se
.descriptor_only
= 1;
3135 gfc_conv_expr (&se
, expr
);
3139 /* Find the last reference in the chain. */
3140 while (ref
&& ref
->next
!= NULL
)
3142 gcc_assert (ref
->type
!= REF_ARRAY
|| ref
->u
.ar
.type
== AR_ELEMENT
);
3146 if (ref
!= NULL
&& ref
->type
== REF_ARRAY
)
3149 gfc_array_allocate (&se
, ref
, pstat
);
3153 /* A scalar or derived type. */
3156 val
= gfc_create_var (ppvoid_type_node
, "ptr");
3157 tmp
= gfc_build_addr_expr (ppvoid_type_node
, se
.expr
);
3158 gfc_add_modify_expr (&se
.pre
, val
, tmp
);
3160 tmp
= TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (se
.expr
)));
3161 parm
= gfc_chainon_list (NULL_TREE
, val
);
3162 parm
= gfc_chainon_list (parm
, tmp
);
3163 parm
= gfc_chainon_list (parm
, pstat
);
3164 tmp
= gfc_build_function_call (gfor_fndecl_allocate
, parm
);
3165 gfc_add_expr_to_block (&se
.pre
, tmp
);
3169 tmp
= build1_v (GOTO_EXPR
, error_label
);
3171 build2 (NE_EXPR
, boolean_type_node
, stat
, integer_zero_node
);
3172 tmp
= build3_v (COND_EXPR
, parm
, tmp
, build_empty_stmt ());
3173 gfc_add_expr_to_block (&se
.pre
, tmp
);
3177 tmp
= gfc_finish_block (&se
.pre
);
3178 gfc_add_expr_to_block (&block
, tmp
);
3181 /* Assign the value to the status variable. */
3184 tmp
= build1_v (LABEL_EXPR
, error_label
);
3185 gfc_add_expr_to_block (&block
, tmp
);
3187 gfc_init_se (&se
, NULL
);
3188 gfc_conv_expr_lhs (&se
, code
->expr
);
3189 tmp
= convert (TREE_TYPE (se
.expr
), stat
);
3190 gfc_add_modify_expr (&block
, se
.expr
, tmp
);
3193 return gfc_finish_block (&block
);
3197 /* Translate a DEALLOCATE statement.
3198 There are two cases within the for loop:
3199 (1) deallocate(a1, a2, a3) is translated into the following sequence
3200 _gfortran_deallocate(a1, 0B)
3201 _gfortran_deallocate(a2, 0B)
3202 _gfortran_deallocate(a3, 0B)
3203 where the STAT= variable is passed a NULL pointer.
3204 (2) deallocate(a1, a2, a3, stat=i) is translated into the following
3206 _gfortran_deallocate(a1, &stat)
3207 astat = astat + stat
3208 _gfortran_deallocate(a2, &stat)
3209 astat = astat + stat
3210 _gfortran_deallocate(a3, &stat)
3211 astat = astat + stat
3212 In case (1), we simply return at the end of the for loop. In case (2)
3213 we set STAT= astat. */
3215 gfc_trans_deallocate (gfc_code
* code
)
3220 tree apstat
, astat
, parm
, pstat
, stat
, tmp
, type
, var
;
3223 gfc_start_block (&block
);
3225 /* Set up the optional STAT= */
3228 tree gfc_int4_type_node
= gfc_get_int_type (4);
3230 /* Variable used with the library call. */
3231 stat
= gfc_create_var (gfc_int4_type_node
, "stat");
3232 pstat
= gfc_build_addr_expr (NULL
, stat
);
3234 /* Running total of possible deallocation failures. */
3235 astat
= gfc_create_var (gfc_int4_type_node
, "astat");
3236 apstat
= gfc_build_addr_expr (NULL
, astat
);
3238 /* Initialize astat to 0. */
3239 gfc_add_modify_expr (&block
, astat
, build_int_cst (TREE_TYPE (astat
), 0));
3243 pstat
= apstat
= null_pointer_node
;
3244 stat
= astat
= NULL_TREE
;
3247 for (al
= code
->ext
.alloc_list
; al
!= NULL
; al
= al
->next
)
3250 gcc_assert (expr
->expr_type
== EXPR_VARIABLE
);
3252 gfc_init_se (&se
, NULL
);
3253 gfc_start_block (&se
.pre
);
3255 se
.want_pointer
= 1;
3256 se
.descriptor_only
= 1;
3257 gfc_conv_expr (&se
, expr
);
3259 if (expr
->symtree
->n
.sym
->attr
.dimension
)
3260 tmp
= gfc_array_deallocate (se
.expr
, pstat
);
3263 type
= build_pointer_type (TREE_TYPE (se
.expr
));
3264 var
= gfc_create_var (type
, "ptr");
3265 tmp
= gfc_build_addr_expr (type
, se
.expr
);
3266 gfc_add_modify_expr (&se
.pre
, var
, tmp
);
3268 parm
= gfc_chainon_list (NULL_TREE
, var
);
3269 parm
= gfc_chainon_list (parm
, pstat
);
3270 tmp
= gfc_build_function_call (gfor_fndecl_deallocate
, parm
);
3273 gfc_add_expr_to_block (&se
.pre
, tmp
);
3275 /* Keep track of the number of failed deallocations by adding stat
3276 of the last deallocation to the running total. */
3279 apstat
= build2 (PLUS_EXPR
, TREE_TYPE (stat
), astat
, stat
);
3280 gfc_add_modify_expr (&se
.pre
, astat
, apstat
);
3283 tmp
= gfc_finish_block (&se
.pre
);
3284 gfc_add_expr_to_block (&block
, tmp
);
3288 /* Assign the value to the status variable. */
3291 gfc_init_se (&se
, NULL
);
3292 gfc_conv_expr_lhs (&se
, code
->expr
);
3293 tmp
= convert (TREE_TYPE (se
.expr
), astat
);
3294 gfc_add_modify_expr (&block
, se
.expr
, tmp
);
3297 return gfc_finish_block (&block
);