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
);
166 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 tmp
= gfc_get_label_decl (code
->label
);
181 tmp
= gfc_build_addr_expr (pvoid_type_node
, tmp
);
182 tmp
= build2 (EQ_EXPR
, boolean_type_node
, tmp
, assigned_goto
);
183 tmp
= build3_v (COND_EXPR
, tmp
, target
, build_empty_stmt ());
184 gfc_add_expr_to_block (&se
.pre
, tmp
);
187 while (code
!= NULL
);
188 gfc_trans_runtime_check (boolean_true_node
, range_error
, &se
.pre
);
189 return gfc_finish_block (&se
.pre
);
193 /* Translate an ENTRY statement. Just adds a label for this entry point. */
195 gfc_trans_entry (gfc_code
* code
)
197 return build1_v (LABEL_EXPR
, code
->ext
.entry
->label
);
201 /* Translate the CALL statement. Builds a call to an F95 subroutine. */
204 gfc_trans_call (gfc_code
* code
)
207 int has_alternate_specifier
;
209 /* A CALL starts a new block because the actual arguments may have to
210 be evaluated first. */
211 gfc_init_se (&se
, NULL
);
212 gfc_start_block (&se
.pre
);
214 gcc_assert (code
->resolved_sym
);
216 /* Translate the call. */
217 has_alternate_specifier
218 = gfc_conv_function_call (&se
, code
->resolved_sym
, code
->ext
.actual
);
220 /* A subroutine without side-effect, by definition, does nothing! */
221 TREE_SIDE_EFFECTS (se
.expr
) = 1;
223 /* Chain the pieces together and return the block. */
224 if (has_alternate_specifier
)
226 gfc_code
*select_code
;
228 select_code
= code
->next
;
229 gcc_assert(select_code
->op
== EXEC_SELECT
);
230 sym
= select_code
->expr
->symtree
->n
.sym
;
231 se
.expr
= convert (gfc_typenode_for_spec (&sym
->ts
), se
.expr
);
232 gfc_add_modify_expr (&se
.pre
, sym
->backend_decl
, se
.expr
);
235 gfc_add_expr_to_block (&se
.pre
, se
.expr
);
237 gfc_add_block_to_block (&se
.pre
, &se
.post
);
238 return gfc_finish_block (&se
.pre
);
242 /* Translate the RETURN statement. */
245 gfc_trans_return (gfc_code
* code ATTRIBUTE_UNUSED
)
253 /* if code->expr is not NULL, this return statement must appear
254 in a subroutine and current_fake_result_decl has already
257 result
= gfc_get_fake_result_decl (NULL
);
260 gfc_warning ("An alternate return at %L without a * dummy argument",
262 return build1_v (GOTO_EXPR
, gfc_get_return_label ());
265 /* Start a new block for this statement. */
266 gfc_init_se (&se
, NULL
);
267 gfc_start_block (&se
.pre
);
269 gfc_conv_expr (&se
, code
->expr
);
271 tmp
= build2 (MODIFY_EXPR
, TREE_TYPE (result
), result
, se
.expr
);
272 gfc_add_expr_to_block (&se
.pre
, tmp
);
274 tmp
= build1_v (GOTO_EXPR
, gfc_get_return_label ());
275 gfc_add_expr_to_block (&se
.pre
, tmp
);
276 gfc_add_block_to_block (&se
.pre
, &se
.post
);
277 return gfc_finish_block (&se
.pre
);
280 return build1_v (GOTO_EXPR
, gfc_get_return_label ());
284 /* Translate the PAUSE statement. We have to translate this statement
285 to a runtime library call. */
288 gfc_trans_pause (gfc_code
* code
)
290 tree gfc_int4_type_node
= gfc_get_int_type (4);
296 /* Start a new block for this statement. */
297 gfc_init_se (&se
, NULL
);
298 gfc_start_block (&se
.pre
);
301 if (code
->expr
== NULL
)
303 tmp
= build_int_cst (gfc_int4_type_node
, code
->ext
.stop_code
);
304 args
= gfc_chainon_list (NULL_TREE
, tmp
);
305 fndecl
= gfor_fndecl_pause_numeric
;
309 gfc_conv_expr_reference (&se
, code
->expr
);
310 args
= gfc_chainon_list (NULL_TREE
, se
.expr
);
311 args
= gfc_chainon_list (args
, se
.string_length
);
312 fndecl
= gfor_fndecl_pause_string
;
315 tmp
= gfc_build_function_call (fndecl
, args
);
316 gfc_add_expr_to_block (&se
.pre
, tmp
);
318 gfc_add_block_to_block (&se
.pre
, &se
.post
);
320 return gfc_finish_block (&se
.pre
);
324 /* Translate the STOP statement. We have to translate this statement
325 to a runtime library call. */
328 gfc_trans_stop (gfc_code
* code
)
330 tree gfc_int4_type_node
= gfc_get_int_type (4);
336 /* Start a new block for this statement. */
337 gfc_init_se (&se
, NULL
);
338 gfc_start_block (&se
.pre
);
341 if (code
->expr
== NULL
)
343 tmp
= build_int_cst (gfc_int4_type_node
, code
->ext
.stop_code
);
344 args
= gfc_chainon_list (NULL_TREE
, tmp
);
345 fndecl
= gfor_fndecl_stop_numeric
;
349 gfc_conv_expr_reference (&se
, code
->expr
);
350 args
= gfc_chainon_list (NULL_TREE
, se
.expr
);
351 args
= gfc_chainon_list (args
, se
.string_length
);
352 fndecl
= gfor_fndecl_stop_string
;
355 tmp
= gfc_build_function_call (fndecl
, args
);
356 gfc_add_expr_to_block (&se
.pre
, tmp
);
358 gfc_add_block_to_block (&se
.pre
, &se
.post
);
360 return gfc_finish_block (&se
.pre
);
364 /* Generate GENERIC for the IF construct. This function also deals with
365 the simple IF statement, because the front end translates the IF
366 statement into an IF construct.
398 where COND_S is the simplified version of the predicate. PRE_COND_S
399 are the pre side-effects produced by the translation of the
401 We need to build the chain recursively otherwise we run into
402 problems with folding incomplete statements. */
405 gfc_trans_if_1 (gfc_code
* code
)
410 /* Check for an unconditional ELSE clause. */
412 return gfc_trans_code (code
->next
);
414 /* Initialize a statement builder for each block. Puts in NULL_TREEs. */
415 gfc_init_se (&if_se
, NULL
);
416 gfc_start_block (&if_se
.pre
);
418 /* Calculate the IF condition expression. */
419 gfc_conv_expr_val (&if_se
, code
->expr
);
421 /* Translate the THEN clause. */
422 stmt
= gfc_trans_code (code
->next
);
424 /* Translate the ELSE clause. */
426 elsestmt
= gfc_trans_if_1 (code
->block
);
428 elsestmt
= build_empty_stmt ();
430 /* Build the condition expression and add it to the condition block. */
431 stmt
= build3_v (COND_EXPR
, if_se
.expr
, stmt
, elsestmt
);
433 gfc_add_expr_to_block (&if_se
.pre
, stmt
);
435 /* Finish off this statement. */
436 return gfc_finish_block (&if_se
.pre
);
440 gfc_trans_if (gfc_code
* code
)
442 /* Ignore the top EXEC_IF, it only announces an IF construct. The
443 actual code we must translate is in code->block. */
445 return gfc_trans_if_1 (code
->block
);
449 /* Translage an arithmetic IF expression.
451 IF (cond) label1, label2, label3 translates to
465 gfc_trans_arithmetic_if (gfc_code
* code
)
473 /* Start a new block. */
474 gfc_init_se (&se
, NULL
);
475 gfc_start_block (&se
.pre
);
477 /* Pre-evaluate COND. */
478 gfc_conv_expr_val (&se
, code
->expr
);
480 /* Build something to compare with. */
481 zero
= gfc_build_const (TREE_TYPE (se
.expr
), integer_zero_node
);
483 /* If (cond < 0) take branch1 else take branch2.
484 First build jumps to the COND .LT. 0 and the COND .EQ. 0 cases. */
485 branch1
= build1_v (GOTO_EXPR
, gfc_get_label_decl (code
->label
));
486 branch2
= build1_v (GOTO_EXPR
, gfc_get_label_decl (code
->label2
));
488 tmp
= build2 (LT_EXPR
, boolean_type_node
, se
.expr
, zero
);
489 branch1
= build3_v (COND_EXPR
, tmp
, branch1
, branch2
);
491 /* if (cond <= 0) take branch1 else take branch2. */
492 branch2
= build1_v (GOTO_EXPR
, gfc_get_label_decl (code
->label3
));
493 tmp
= build2 (LE_EXPR
, boolean_type_node
, se
.expr
, zero
);
494 branch1
= build3_v (COND_EXPR
, tmp
, branch1
, branch2
);
496 /* Append the COND_EXPR to the evaluation of COND, and return. */
497 gfc_add_expr_to_block (&se
.pre
, branch1
);
498 return gfc_finish_block (&se
.pre
);
502 /* Translate the simple DO construct. This is where the loop variable has
503 integer type and step +-1. We can't use this in the general case
504 because integer overflow and floating point errors could give incorrect
506 We translate a do loop from:
508 DO dovar = from, to, step
514 [Evaluate loop bounds and step]
516 if ((step > 0) ? (dovar <= to) : (dovar => to))
522 cond = (dovar == to);
524 if (cond) goto end_label;
529 This helps the optimizers by avoiding the extra induction variable
530 used in the general case. */
533 gfc_trans_simple_do (gfc_code
* code
, stmtblock_t
*pblock
, tree dovar
,
534 tree from
, tree to
, tree step
)
543 type
= TREE_TYPE (dovar
);
545 /* Initialize the DO variable: dovar = from. */
546 gfc_add_modify_expr (pblock
, dovar
, from
);
548 /* Cycle and exit statements are implemented with gotos. */
549 cycle_label
= gfc_build_label_decl (NULL_TREE
);
550 exit_label
= gfc_build_label_decl (NULL_TREE
);
552 /* Put the labels where they can be found later. See gfc_trans_do(). */
553 code
->block
->backend_decl
= tree_cons (cycle_label
, exit_label
, NULL
);
556 gfc_start_block (&body
);
558 /* Main loop body. */
559 tmp
= gfc_trans_code (code
->block
->next
);
560 gfc_add_expr_to_block (&body
, tmp
);
562 /* Label for cycle statements (if needed). */
563 if (TREE_USED (cycle_label
))
565 tmp
= build1_v (LABEL_EXPR
, cycle_label
);
566 gfc_add_expr_to_block (&body
, tmp
);
569 /* Evaluate the loop condition. */
570 cond
= build2 (EQ_EXPR
, boolean_type_node
, dovar
, to
);
571 cond
= gfc_evaluate_now (cond
, &body
);
573 /* Increment the loop variable. */
574 tmp
= build2 (PLUS_EXPR
, type
, dovar
, step
);
575 gfc_add_modify_expr (&body
, dovar
, tmp
);
578 tmp
= build1_v (GOTO_EXPR
, exit_label
);
579 TREE_USED (exit_label
) = 1;
580 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt ());
581 gfc_add_expr_to_block (&body
, tmp
);
583 /* Finish the loop body. */
584 tmp
= gfc_finish_block (&body
);
585 tmp
= build1_v (LOOP_EXPR
, tmp
);
587 /* Only execute the loop if the number of iterations is positive. */
588 if (tree_int_cst_sgn (step
) > 0)
589 cond
= fold_build2 (LE_EXPR
, boolean_type_node
, dovar
, to
);
591 cond
= fold_build2 (GE_EXPR
, boolean_type_node
, dovar
, to
);
592 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt ());
593 gfc_add_expr_to_block (pblock
, tmp
);
595 /* Add the exit label. */
596 tmp
= build1_v (LABEL_EXPR
, exit_label
);
597 gfc_add_expr_to_block (pblock
, tmp
);
599 return gfc_finish_block (pblock
);
602 /* Translate the DO construct. This obviously is one of the most
603 important ones to get right with any compiler, but especially
606 We special case some loop forms as described in gfc_trans_simple_do.
607 For other cases we implement them with a separate loop count,
608 as described in the standard.
610 We translate a do loop from:
612 DO dovar = from, to, step
618 [evaluate loop bounds and step]
619 count = to + step - from;
627 if (count <=0) goto exit_label;
631 TODO: Large loop counts
632 The code above assumes the loop count fits into a signed integer kind,
633 i.e. Does not work for loop counts > 2^31 for integer(kind=4) variables
634 We must support the full range. */
637 gfc_trans_do (gfc_code
* code
)
654 gfc_start_block (&block
);
656 /* Evaluate all the expressions in the iterator. */
657 gfc_init_se (&se
, NULL
);
658 gfc_conv_expr_lhs (&se
, code
->ext
.iterator
->var
);
659 gfc_add_block_to_block (&block
, &se
.pre
);
661 type
= TREE_TYPE (dovar
);
663 gfc_init_se (&se
, NULL
);
664 gfc_conv_expr_val (&se
, code
->ext
.iterator
->start
);
665 gfc_add_block_to_block (&block
, &se
.pre
);
666 from
= gfc_evaluate_now (se
.expr
, &block
);
668 gfc_init_se (&se
, NULL
);
669 gfc_conv_expr_val (&se
, code
->ext
.iterator
->end
);
670 gfc_add_block_to_block (&block
, &se
.pre
);
671 to
= gfc_evaluate_now (se
.expr
, &block
);
673 gfc_init_se (&se
, NULL
);
674 gfc_conv_expr_val (&se
, code
->ext
.iterator
->step
);
675 gfc_add_block_to_block (&block
, &se
.pre
);
676 step
= gfc_evaluate_now (se
.expr
, &block
);
678 /* Special case simple loops. */
679 if (TREE_CODE (type
) == INTEGER_TYPE
680 && (integer_onep (step
)
681 || tree_int_cst_equal (step
, integer_minus_one_node
)))
682 return gfc_trans_simple_do (code
, &block
, dovar
, from
, to
, step
);
684 /* Initialize loop count. This code is executed before we enter the
685 loop body. We generate: count = (to + step - from) / step. */
687 tmp
= fold_build2 (MINUS_EXPR
, type
, step
, from
);
688 tmp
= fold_build2 (PLUS_EXPR
, type
, to
, tmp
);
689 if (TREE_CODE (type
) == INTEGER_TYPE
)
691 tmp
= fold_build2 (TRUNC_DIV_EXPR
, type
, tmp
, step
);
692 count
= gfc_create_var (type
, "count");
696 /* TODO: We could use the same width as the real type.
697 This would probably cause more problems that it solves
698 when we implement "long double" types. */
699 tmp
= fold_build2 (RDIV_EXPR
, type
, tmp
, step
);
700 tmp
= fold_build1 (FIX_TRUNC_EXPR
, gfc_array_index_type
, tmp
);
701 count
= gfc_create_var (gfc_array_index_type
, "count");
703 gfc_add_modify_expr (&block
, count
, tmp
);
705 count_one
= convert (TREE_TYPE (count
), integer_one_node
);
707 /* Initialize the DO variable: dovar = from. */
708 gfc_add_modify_expr (&block
, dovar
, from
);
711 gfc_start_block (&body
);
713 /* Cycle and exit statements are implemented with gotos. */
714 cycle_label
= gfc_build_label_decl (NULL_TREE
);
715 exit_label
= gfc_build_label_decl (NULL_TREE
);
717 /* Start with the loop condition. Loop until count <= 0. */
718 cond
= build2 (LE_EXPR
, boolean_type_node
, count
,
719 convert (TREE_TYPE (count
), integer_zero_node
));
720 tmp
= build1_v (GOTO_EXPR
, exit_label
);
721 TREE_USED (exit_label
) = 1;
722 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt ());
723 gfc_add_expr_to_block (&body
, tmp
);
725 /* Put these labels where they can be found later. We put the
726 labels in a TREE_LIST node (because TREE_CHAIN is already
727 used). cycle_label goes in TREE_PURPOSE (backend_decl), exit
728 label in TREE_VALUE (backend_decl). */
730 code
->block
->backend_decl
= tree_cons (cycle_label
, exit_label
, NULL
);
732 /* Main loop body. */
733 tmp
= gfc_trans_code (code
->block
->next
);
734 gfc_add_expr_to_block (&body
, tmp
);
736 /* Label for cycle statements (if needed). */
737 if (TREE_USED (cycle_label
))
739 tmp
= build1_v (LABEL_EXPR
, cycle_label
);
740 gfc_add_expr_to_block (&body
, tmp
);
743 /* Increment the loop variable. */
744 tmp
= build2 (PLUS_EXPR
, type
, dovar
, step
);
745 gfc_add_modify_expr (&body
, dovar
, tmp
);
747 /* Decrement the loop count. */
748 tmp
= build2 (MINUS_EXPR
, TREE_TYPE (count
), count
, count_one
);
749 gfc_add_modify_expr (&body
, count
, tmp
);
751 /* End of loop body. */
752 tmp
= gfc_finish_block (&body
);
754 /* The for loop itself. */
755 tmp
= build1_v (LOOP_EXPR
, tmp
);
756 gfc_add_expr_to_block (&block
, tmp
);
758 /* Add the exit label. */
759 tmp
= build1_v (LABEL_EXPR
, exit_label
);
760 gfc_add_expr_to_block (&block
, tmp
);
762 return gfc_finish_block (&block
);
766 /* Translate the DO WHILE construct.
779 if (! cond) goto exit_label;
785 Because the evaluation of the exit condition `cond' may have side
786 effects, we can't do much for empty loop bodies. The backend optimizers
787 should be smart enough to eliminate any dead loops. */
790 gfc_trans_do_while (gfc_code
* code
)
798 /* Everything we build here is part of the loop body. */
799 gfc_start_block (&block
);
801 /* Cycle and exit statements are implemented with gotos. */
802 cycle_label
= gfc_build_label_decl (NULL_TREE
);
803 exit_label
= gfc_build_label_decl (NULL_TREE
);
805 /* Put the labels where they can be found later. See gfc_trans_do(). */
806 code
->block
->backend_decl
= tree_cons (cycle_label
, exit_label
, NULL
);
808 /* Create a GIMPLE version of the exit condition. */
809 gfc_init_se (&cond
, NULL
);
810 gfc_conv_expr_val (&cond
, code
->expr
);
811 gfc_add_block_to_block (&block
, &cond
.pre
);
812 cond
.expr
= fold_build1 (TRUTH_NOT_EXPR
, boolean_type_node
, cond
.expr
);
814 /* Build "IF (! cond) GOTO exit_label". */
815 tmp
= build1_v (GOTO_EXPR
, exit_label
);
816 TREE_USED (exit_label
) = 1;
817 tmp
= build3_v (COND_EXPR
, cond
.expr
, tmp
, build_empty_stmt ());
818 gfc_add_expr_to_block (&block
, tmp
);
820 /* The main body of the loop. */
821 tmp
= gfc_trans_code (code
->block
->next
);
822 gfc_add_expr_to_block (&block
, tmp
);
824 /* Label for cycle statements (if needed). */
825 if (TREE_USED (cycle_label
))
827 tmp
= build1_v (LABEL_EXPR
, cycle_label
);
828 gfc_add_expr_to_block (&block
, tmp
);
831 /* End of loop body. */
832 tmp
= gfc_finish_block (&block
);
834 gfc_init_block (&block
);
835 /* Build the loop. */
836 tmp
= build1_v (LOOP_EXPR
, tmp
);
837 gfc_add_expr_to_block (&block
, tmp
);
839 /* Add the exit label. */
840 tmp
= build1_v (LABEL_EXPR
, exit_label
);
841 gfc_add_expr_to_block (&block
, tmp
);
843 return gfc_finish_block (&block
);
847 /* Translate the SELECT CASE construct for INTEGER case expressions,
848 without killing all potential optimizations. The problem is that
849 Fortran allows unbounded cases, but the back-end does not, so we
850 need to intercept those before we enter the equivalent SWITCH_EXPR
853 For example, we translate this,
856 CASE (:100,101,105:115)
866 to the GENERIC equivalent,
870 case (minimum value for typeof(expr) ... 100:
876 case 200 ... (maximum value for typeof(expr):
893 gfc_trans_integer_select (gfc_code
* code
)
903 gfc_start_block (&block
);
905 /* Calculate the switch expression. */
906 gfc_init_se (&se
, NULL
);
907 gfc_conv_expr_val (&se
, code
->expr
);
908 gfc_add_block_to_block (&block
, &se
.pre
);
910 end_label
= gfc_build_label_decl (NULL_TREE
);
912 gfc_init_block (&body
);
914 for (c
= code
->block
; c
; c
= c
->block
)
916 for (cp
= c
->ext
.case_list
; cp
; cp
= cp
->next
)
921 /* Assume it's the default case. */
922 low
= high
= NULL_TREE
;
926 low
= gfc_conv_constant_to_tree (cp
->low
);
928 /* If there's only a lower bound, set the high bound to the
929 maximum value of the case expression. */
931 high
= TYPE_MAX_VALUE (TREE_TYPE (se
.expr
));
936 /* Three cases are possible here:
938 1) There is no lower bound, e.g. CASE (:N).
939 2) There is a lower bound .NE. high bound, that is
940 a case range, e.g. CASE (N:M) where M>N (we make
941 sure that M>N during type resolution).
942 3) There is a lower bound, and it has the same value
943 as the high bound, e.g. CASE (N:N). This is our
944 internal representation of CASE(N).
946 In the first and second case, we need to set a value for
947 high. In the thirth case, we don't because the GCC middle
948 end represents a single case value by just letting high be
949 a NULL_TREE. We can't do that because we need to be able
950 to represent unbounded cases. */
954 && mpz_cmp (cp
->low
->value
.integer
,
955 cp
->high
->value
.integer
) != 0))
956 high
= gfc_conv_constant_to_tree (cp
->high
);
958 /* Unbounded case. */
960 low
= TYPE_MIN_VALUE (TREE_TYPE (se
.expr
));
964 label
= gfc_build_label_decl (NULL_TREE
);
966 /* Add this case label.
967 Add parameter 'label', make it match GCC backend. */
968 tmp
= build3 (CASE_LABEL_EXPR
, void_type_node
, low
, high
, label
);
969 gfc_add_expr_to_block (&body
, tmp
);
972 /* Add the statements for this case. */
973 tmp
= gfc_trans_code (c
->next
);
974 gfc_add_expr_to_block (&body
, tmp
);
976 /* Break to the end of the construct. */
977 tmp
= build1_v (GOTO_EXPR
, end_label
);
978 gfc_add_expr_to_block (&body
, tmp
);
981 tmp
= gfc_finish_block (&body
);
982 tmp
= build3_v (SWITCH_EXPR
, se
.expr
, tmp
, NULL_TREE
);
983 gfc_add_expr_to_block (&block
, tmp
);
985 tmp
= build1_v (LABEL_EXPR
, end_label
);
986 gfc_add_expr_to_block (&block
, tmp
);
988 return gfc_finish_block (&block
);
992 /* Translate the SELECT CASE construct for LOGICAL case expressions.
994 There are only two cases possible here, even though the standard
995 does allow three cases in a LOGICAL SELECT CASE construct: .TRUE.,
996 .FALSE., and DEFAULT.
998 We never generate more than two blocks here. Instead, we always
999 try to eliminate the DEFAULT case. This way, we can translate this
1000 kind of SELECT construct to a simple
1004 expression in GENERIC. */
1007 gfc_trans_logical_select (gfc_code
* code
)
1010 gfc_code
*t
, *f
, *d
;
1015 /* Assume we don't have any cases at all. */
1018 /* Now see which ones we actually do have. We can have at most two
1019 cases in a single case list: one for .TRUE. and one for .FALSE.
1020 The default case is always separate. If the cases for .TRUE. and
1021 .FALSE. are in the same case list, the block for that case list
1022 always executed, and we don't generate code a COND_EXPR. */
1023 for (c
= code
->block
; c
; c
= c
->block
)
1025 for (cp
= c
->ext
.case_list
; cp
; cp
= cp
->next
)
1029 if (cp
->low
->value
.logical
== 0) /* .FALSE. */
1031 else /* if (cp->value.logical != 0), thus .TRUE. */
1039 /* Start a new block. */
1040 gfc_start_block (&block
);
1042 /* Calculate the switch expression. We always need to do this
1043 because it may have side effects. */
1044 gfc_init_se (&se
, NULL
);
1045 gfc_conv_expr_val (&se
, code
->expr
);
1046 gfc_add_block_to_block (&block
, &se
.pre
);
1048 if (t
== f
&& t
!= NULL
)
1050 /* Cases for .TRUE. and .FALSE. are in the same block. Just
1051 translate the code for these cases, append it to the current
1053 gfc_add_expr_to_block (&block
, gfc_trans_code (t
->next
));
1057 tree true_tree
, false_tree
;
1059 true_tree
= build_empty_stmt ();
1060 false_tree
= build_empty_stmt ();
1062 /* If we have a case for .TRUE. and for .FALSE., discard the default case.
1063 Otherwise, if .TRUE. or .FALSE. is missing and there is a default case,
1064 make the missing case the default case. */
1065 if (t
!= NULL
&& f
!= NULL
)
1075 /* Translate the code for each of these blocks, and append it to
1076 the current block. */
1078 true_tree
= gfc_trans_code (t
->next
);
1081 false_tree
= gfc_trans_code (f
->next
);
1083 gfc_add_expr_to_block (&block
, build3_v (COND_EXPR
, se
.expr
,
1084 true_tree
, false_tree
));
1087 return gfc_finish_block (&block
);
1091 /* Translate the SELECT CASE construct for CHARACTER case expressions.
1092 Instead of generating compares and jumps, it is far simpler to
1093 generate a data structure describing the cases in order and call a
1094 library subroutine that locates the right case.
1095 This is particularly true because this is the only case where we
1096 might have to dispose of a temporary.
1097 The library subroutine returns a pointer to jump to or NULL if no
1098 branches are to be taken. */
1101 gfc_trans_character_select (gfc_code
*code
)
1103 tree init
, node
, end_label
, tmp
, type
, args
, *labels
;
1104 stmtblock_t block
, body
;
1110 static tree select_struct
;
1111 static tree ss_string1
, ss_string1_len
;
1112 static tree ss_string2
, ss_string2_len
;
1113 static tree ss_target
;
1115 if (select_struct
== NULL
)
1117 tree gfc_int4_type_node
= gfc_get_int_type (4);
1119 select_struct
= make_node (RECORD_TYPE
);
1120 TYPE_NAME (select_struct
) = get_identifier ("_jump_struct");
1123 #define ADD_FIELD(NAME, TYPE) \
1124 ss_##NAME = gfc_add_field_to_struct \
1125 (&(TYPE_FIELDS (select_struct)), select_struct, \
1126 get_identifier (stringize(NAME)), TYPE)
1128 ADD_FIELD (string1
, pchar_type_node
);
1129 ADD_FIELD (string1_len
, gfc_int4_type_node
);
1131 ADD_FIELD (string2
, pchar_type_node
);
1132 ADD_FIELD (string2_len
, gfc_int4_type_node
);
1134 ADD_FIELD (target
, pvoid_type_node
);
1137 gfc_finish_type (select_struct
);
1140 cp
= code
->block
->ext
.case_list
;
1141 while (cp
->left
!= NULL
)
1145 for (d
= cp
; d
; d
= d
->right
)
1149 labels
= gfc_getmem (n
* sizeof (tree
));
1153 for(i
= 0; i
< n
; i
++)
1155 labels
[i
] = gfc_build_label_decl (NULL_TREE
);
1156 TREE_USED (labels
[i
]) = 1;
1157 /* TODO: The gimplifier should do this for us, but it has
1158 inadequacies when dealing with static initializers. */
1159 FORCED_LABEL (labels
[i
]) = 1;
1162 end_label
= gfc_build_label_decl (NULL_TREE
);
1164 /* Generate the body */
1165 gfc_start_block (&block
);
1166 gfc_init_block (&body
);
1168 for (c
= code
->block
; c
; c
= c
->block
)
1170 for (d
= c
->ext
.case_list
; d
; d
= d
->next
)
1172 tmp
= build1_v (LABEL_EXPR
, labels
[d
->n
]);
1173 gfc_add_expr_to_block (&body
, tmp
);
1176 tmp
= gfc_trans_code (c
->next
);
1177 gfc_add_expr_to_block (&body
, tmp
);
1179 tmp
= build1_v (GOTO_EXPR
, end_label
);
1180 gfc_add_expr_to_block (&body
, tmp
);
1183 /* Generate the structure describing the branches */
1187 for(d
= cp
; d
; d
= d
->right
, i
++)
1191 gfc_init_se (&se
, NULL
);
1195 node
= tree_cons (ss_string1
, null_pointer_node
, node
);
1196 node
= tree_cons (ss_string1_len
, integer_zero_node
, node
);
1200 gfc_conv_expr_reference (&se
, d
->low
);
1202 node
= tree_cons (ss_string1
, se
.expr
, node
);
1203 node
= tree_cons (ss_string1_len
, se
.string_length
, node
);
1206 if (d
->high
== NULL
)
1208 node
= tree_cons (ss_string2
, null_pointer_node
, node
);
1209 node
= tree_cons (ss_string2_len
, integer_zero_node
, node
);
1213 gfc_init_se (&se
, NULL
);
1214 gfc_conv_expr_reference (&se
, d
->high
);
1216 node
= tree_cons (ss_string2
, se
.expr
, node
);
1217 node
= tree_cons (ss_string2_len
, se
.string_length
, node
);
1220 tmp
= gfc_build_addr_expr (pvoid_type_node
, labels
[i
]);
1221 node
= tree_cons (ss_target
, tmp
, node
);
1223 tmp
= build1 (CONSTRUCTOR
, select_struct
, nreverse (node
));
1224 init
= tree_cons (NULL_TREE
, tmp
, init
);
1227 type
= build_array_type (select_struct
, build_index_type
1228 (build_int_cst (NULL_TREE
, n
- 1)));
1230 init
= build1 (CONSTRUCTOR
, type
, nreverse(init
));
1231 TREE_CONSTANT (init
) = 1;
1232 TREE_INVARIANT (init
) = 1;
1233 TREE_STATIC (init
) = 1;
1234 /* Create a static variable to hold the jump table. */
1235 tmp
= gfc_create_var (type
, "jumptable");
1236 TREE_CONSTANT (tmp
) = 1;
1237 TREE_INVARIANT (tmp
) = 1;
1238 TREE_STATIC (tmp
) = 1;
1239 DECL_INITIAL (tmp
) = init
;
1242 /* Build an argument list for the library call */
1243 init
= gfc_build_addr_expr (pvoid_type_node
, init
);
1244 args
= gfc_chainon_list (NULL_TREE
, init
);
1246 tmp
= build_int_cst (NULL_TREE
, n
);
1247 args
= gfc_chainon_list (args
, tmp
);
1249 tmp
= gfc_build_addr_expr (pvoid_type_node
, end_label
);
1250 args
= gfc_chainon_list (args
, tmp
);
1252 gfc_init_se (&se
, NULL
);
1253 gfc_conv_expr_reference (&se
, code
->expr
);
1255 args
= gfc_chainon_list (args
, se
.expr
);
1256 args
= gfc_chainon_list (args
, se
.string_length
);
1258 gfc_add_block_to_block (&block
, &se
.pre
);
1260 tmp
= gfc_build_function_call (gfor_fndecl_select_string
, args
);
1261 tmp
= build1 (GOTO_EXPR
, void_type_node
, tmp
);
1262 gfc_add_expr_to_block (&block
, tmp
);
1264 tmp
= gfc_finish_block (&body
);
1265 gfc_add_expr_to_block (&block
, tmp
);
1266 tmp
= build1_v (LABEL_EXPR
, end_label
);
1267 gfc_add_expr_to_block (&block
, tmp
);
1272 return gfc_finish_block (&block
);
1276 /* Translate the three variants of the SELECT CASE construct.
1278 SELECT CASEs with INTEGER case expressions can be translated to an
1279 equivalent GENERIC switch statement, and for LOGICAL case
1280 expressions we build one or two if-else compares.
1282 SELECT CASEs with CHARACTER case expressions are a whole different
1283 story, because they don't exist in GENERIC. So we sort them and
1284 do a binary search at runtime.
1286 Fortran has no BREAK statement, and it does not allow jumps from
1287 one case block to another. That makes things a lot easier for
1291 gfc_trans_select (gfc_code
* code
)
1293 gcc_assert (code
&& code
->expr
);
1295 /* Empty SELECT constructs are legal. */
1296 if (code
->block
== NULL
)
1297 return build_empty_stmt ();
1299 /* Select the correct translation function. */
1300 switch (code
->expr
->ts
.type
)
1302 case BT_LOGICAL
: return gfc_trans_logical_select (code
);
1303 case BT_INTEGER
: return gfc_trans_integer_select (code
);
1304 case BT_CHARACTER
: return gfc_trans_character_select (code
);
1306 gfc_internal_error ("gfc_trans_select(): Bad type for case expr.");
1312 /* Generate the loops for a FORALL block. The normal loop format:
1313 count = (end - start + step) / step
1326 gfc_trans_forall_loop (forall_info
*forall_tmp
, int nvar
, tree body
, int mask_flag
)
1334 tree var
, start
, end
, step
, mask
, maskindex
;
1337 iter
= forall_tmp
->this_loop
;
1338 for (n
= 0; n
< nvar
; n
++)
1341 start
= iter
->start
;
1345 exit_label
= gfc_build_label_decl (NULL_TREE
);
1346 TREE_USED (exit_label
) = 1;
1348 /* The loop counter. */
1349 count
= gfc_create_var (TREE_TYPE (var
), "count");
1351 /* The body of the loop. */
1352 gfc_init_block (&block
);
1354 /* The exit condition. */
1355 cond
= build2 (LE_EXPR
, boolean_type_node
, count
, integer_zero_node
);
1356 tmp
= build1_v (GOTO_EXPR
, exit_label
);
1357 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt ());
1358 gfc_add_expr_to_block (&block
, tmp
);
1360 /* The main loop body. */
1361 gfc_add_expr_to_block (&block
, body
);
1363 /* Increment the loop variable. */
1364 tmp
= build2 (PLUS_EXPR
, TREE_TYPE (var
), var
, step
);
1365 gfc_add_modify_expr (&block
, var
, tmp
);
1367 /* Advance to the next mask element. Only do this for the
1369 if (n
== 0 && mask_flag
)
1371 mask
= forall_tmp
->mask
;
1372 maskindex
= forall_tmp
->maskindex
;
1375 tmp
= build2 (PLUS_EXPR
, gfc_array_index_type
,
1376 maskindex
, gfc_index_one_node
);
1377 gfc_add_modify_expr (&block
, maskindex
, tmp
);
1380 /* Decrement the loop counter. */
1381 tmp
= build2 (MINUS_EXPR
, TREE_TYPE (var
), count
, gfc_index_one_node
);
1382 gfc_add_modify_expr (&block
, count
, tmp
);
1384 body
= gfc_finish_block (&block
);
1386 /* Loop var initialization. */
1387 gfc_init_block (&block
);
1388 gfc_add_modify_expr (&block
, var
, start
);
1390 /* Initialize the loop counter. */
1391 tmp
= fold_build2 (MINUS_EXPR
, TREE_TYPE (var
), step
, start
);
1392 tmp
= fold_build2 (PLUS_EXPR
, TREE_TYPE (var
), end
, tmp
);
1393 tmp
= fold_build2 (TRUNC_DIV_EXPR
, TREE_TYPE (var
), tmp
, step
);
1394 gfc_add_modify_expr (&block
, count
, tmp
);
1396 /* The loop expression. */
1397 tmp
= build1_v (LOOP_EXPR
, body
);
1398 gfc_add_expr_to_block (&block
, tmp
);
1400 /* The exit label. */
1401 tmp
= build1_v (LABEL_EXPR
, exit_label
);
1402 gfc_add_expr_to_block (&block
, tmp
);
1404 body
= gfc_finish_block (&block
);
1411 /* Generate the body and loops according to MASK_FLAG and NEST_FLAG.
1412 if MASK_FLAG is nonzero, the body is controlled by maskes in forall
1413 nest, otherwise, the body is not controlled by maskes.
1414 if NEST_FLAG is nonzero, generate loops for nested forall, otherwise,
1415 only generate loops for the current forall level. */
1418 gfc_trans_nested_forall_loop (forall_info
* nested_forall_info
, tree body
,
1419 int mask_flag
, int nest_flag
)
1423 forall_info
*forall_tmp
;
1424 tree pmask
, mask
, maskindex
;
1426 forall_tmp
= nested_forall_info
;
1427 /* Generate loops for nested forall. */
1430 while (forall_tmp
->next_nest
!= NULL
)
1431 forall_tmp
= forall_tmp
->next_nest
;
1432 while (forall_tmp
!= NULL
)
1434 /* Generate body with masks' control. */
1437 pmask
= forall_tmp
->pmask
;
1438 mask
= forall_tmp
->mask
;
1439 maskindex
= forall_tmp
->maskindex
;
1443 /* If a mask was specified make the assignment conditional. */
1445 tmp
= gfc_build_indirect_ref (mask
);
1448 tmp
= gfc_build_array_ref (tmp
, maskindex
);
1450 body
= build3_v (COND_EXPR
, tmp
, body
, build_empty_stmt ());
1453 nvar
= forall_tmp
->nvar
;
1454 body
= gfc_trans_forall_loop (forall_tmp
, nvar
, body
, mask_flag
);
1455 forall_tmp
= forall_tmp
->outer
;
1460 nvar
= forall_tmp
->nvar
;
1461 body
= gfc_trans_forall_loop (forall_tmp
, nvar
, body
, mask_flag
);
1468 /* Allocate data for holding a temporary array. Returns either a local
1469 temporary array or a pointer variable. */
1472 gfc_do_allocate (tree bytesize
, tree size
, tree
* pdata
, stmtblock_t
* pblock
,
1480 if (INTEGER_CST_P (size
))
1482 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, size
,
1483 gfc_index_one_node
);
1488 type
= build_range_type (gfc_array_index_type
, gfc_index_zero_node
, tmp
);
1489 type
= build_array_type (elem_type
, type
);
1490 if (gfc_can_put_var_on_stack (bytesize
))
1492 gcc_assert (INTEGER_CST_P (size
));
1493 tmpvar
= gfc_create_var (type
, "temp");
1498 tmpvar
= gfc_create_var (build_pointer_type (type
), "temp");
1499 *pdata
= convert (pvoid_type_node
, tmpvar
);
1501 args
= gfc_chainon_list (NULL_TREE
, bytesize
);
1502 if (gfc_index_integer_kind
== 4)
1503 tmp
= gfor_fndecl_internal_malloc
;
1504 else if (gfc_index_integer_kind
== 8)
1505 tmp
= gfor_fndecl_internal_malloc64
;
1508 tmp
= gfc_build_function_call (tmp
, args
);
1509 tmp
= convert (TREE_TYPE (tmpvar
), tmp
);
1510 gfc_add_modify_expr (pblock
, tmpvar
, tmp
);
1516 /* Generate codes to copy the temporary to the actual lhs. */
1519 generate_loop_for_temp_to_lhs (gfc_expr
*expr
, tree tmp1
, tree count3
,
1520 tree count1
, tree wheremask
)
1524 stmtblock_t block
, body
;
1530 lss
= gfc_walk_expr (expr
);
1532 if (lss
== gfc_ss_terminator
)
1534 gfc_start_block (&block
);
1536 gfc_init_se (&lse
, NULL
);
1538 /* Translate the expression. */
1539 gfc_conv_expr (&lse
, expr
);
1541 /* Form the expression for the temporary. */
1542 tmp
= gfc_build_array_ref (tmp1
, count1
);
1544 /* Use the scalar assignment as is. */
1545 gfc_add_block_to_block (&block
, &lse
.pre
);
1546 gfc_add_modify_expr (&block
, lse
.expr
, tmp
);
1547 gfc_add_block_to_block (&block
, &lse
.post
);
1549 /* Increment the count1. */
1550 tmp
= fold_build2 (PLUS_EXPR
, TREE_TYPE (count1
), count1
,
1551 gfc_index_one_node
);
1552 gfc_add_modify_expr (&block
, count1
, tmp
);
1554 tmp
= gfc_finish_block (&block
);
1558 gfc_start_block (&block
);
1560 gfc_init_loopinfo (&loop1
);
1561 gfc_init_se (&rse
, NULL
);
1562 gfc_init_se (&lse
, NULL
);
1564 /* Associate the lss with the loop. */
1565 gfc_add_ss_to_loop (&loop1
, lss
);
1567 /* Calculate the bounds of the scalarization. */
1568 gfc_conv_ss_startstride (&loop1
);
1569 /* Setup the scalarizing loops. */
1570 gfc_conv_loop_setup (&loop1
);
1572 gfc_mark_ss_chain_used (lss
, 1);
1574 /* Start the scalarized loop body. */
1575 gfc_start_scalarized_body (&loop1
, &body
);
1577 /* Setup the gfc_se structures. */
1578 gfc_copy_loopinfo_to_se (&lse
, &loop1
);
1581 /* Form the expression of the temporary. */
1582 if (lss
!= gfc_ss_terminator
)
1583 rse
.expr
= gfc_build_array_ref (tmp1
, count1
);
1584 /* Translate expr. */
1585 gfc_conv_expr (&lse
, expr
);
1587 /* Use the scalar assignment. */
1588 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
.type
);
1590 /* Form the mask expression according to the mask tree list. */
1593 wheremaskexpr
= gfc_build_array_ref (wheremask
, count3
);
1594 tmp2
= TREE_CHAIN (wheremask
);
1597 tmp1
= gfc_build_array_ref (tmp2
, count3
);
1598 wheremaskexpr
= build2 (TRUTH_AND_EXPR
, TREE_TYPE (tmp1
),
1599 wheremaskexpr
, tmp1
);
1600 tmp2
= TREE_CHAIN (tmp2
);
1602 tmp
= build3_v (COND_EXPR
, wheremaskexpr
, tmp
, build_empty_stmt ());
1605 gfc_add_expr_to_block (&body
, tmp
);
1607 /* Increment count1. */
1608 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
1609 count1
, gfc_index_one_node
);
1610 gfc_add_modify_expr (&body
, count1
, tmp
);
1612 /* Increment count3. */
1615 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
1616 count3
, gfc_index_one_node
);
1617 gfc_add_modify_expr (&body
, count3
, tmp
);
1620 /* Generate the copying loops. */
1621 gfc_trans_scalarizing_loops (&loop1
, &body
);
1622 gfc_add_block_to_block (&block
, &loop1
.pre
);
1623 gfc_add_block_to_block (&block
, &loop1
.post
);
1624 gfc_cleanup_loop (&loop1
);
1626 tmp
= gfc_finish_block (&block
);
1632 /* Generate codes to copy rhs to the temporary. TMP1 is the address of temporary
1633 LSS and RSS are formed in function compute_inner_temp_size(), and should
1637 generate_loop_for_rhs_to_temp (gfc_expr
*expr2
, tree tmp1
, tree count3
,
1638 tree count1
, gfc_ss
*lss
, gfc_ss
*rss
,
1641 stmtblock_t block
, body1
;
1648 gfc_start_block (&block
);
1650 gfc_init_se (&rse
, NULL
);
1651 gfc_init_se (&lse
, NULL
);
1653 if (lss
== gfc_ss_terminator
)
1655 gfc_init_block (&body1
);
1656 gfc_conv_expr (&rse
, expr2
);
1657 lse
.expr
= gfc_build_array_ref (tmp1
, count1
);
1661 /* Initialize the loop. */
1662 gfc_init_loopinfo (&loop
);
1664 /* We may need LSS to determine the shape of the expression. */
1665 gfc_add_ss_to_loop (&loop
, lss
);
1666 gfc_add_ss_to_loop (&loop
, rss
);
1668 gfc_conv_ss_startstride (&loop
);
1669 gfc_conv_loop_setup (&loop
);
1671 gfc_mark_ss_chain_used (rss
, 1);
1672 /* Start the loop body. */
1673 gfc_start_scalarized_body (&loop
, &body1
);
1675 /* Translate the expression. */
1676 gfc_copy_loopinfo_to_se (&rse
, &loop
);
1678 gfc_conv_expr (&rse
, expr2
);
1680 /* Form the expression of the temporary. */
1681 lse
.expr
= gfc_build_array_ref (tmp1
, count1
);
1684 /* Use the scalar assignment. */
1685 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr2
->ts
.type
);
1687 /* Form the mask expression according to the mask tree list. */
1690 wheremaskexpr
= gfc_build_array_ref (wheremask
, count3
);
1691 tmp2
= TREE_CHAIN (wheremask
);
1694 tmp1
= gfc_build_array_ref (tmp2
, count3
);
1695 wheremaskexpr
= build2 (TRUTH_AND_EXPR
, TREE_TYPE (tmp1
),
1696 wheremaskexpr
, tmp1
);
1697 tmp2
= TREE_CHAIN (tmp2
);
1699 tmp
= build3_v (COND_EXPR
, wheremaskexpr
, tmp
, build_empty_stmt ());
1702 gfc_add_expr_to_block (&body1
, tmp
);
1704 if (lss
== gfc_ss_terminator
)
1706 gfc_add_block_to_block (&block
, &body1
);
1708 /* Increment count1. */
1709 tmp
= fold_build2 (PLUS_EXPR
, TREE_TYPE (count1
), count1
,
1710 gfc_index_one_node
);
1711 gfc_add_modify_expr (&block
, count1
, tmp
);
1715 /* Increment count1. */
1716 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
1717 count1
, gfc_index_one_node
);
1718 gfc_add_modify_expr (&body1
, count1
, tmp
);
1720 /* Increment count3. */
1723 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
1724 count3
, gfc_index_one_node
);
1725 gfc_add_modify_expr (&body1
, count3
, tmp
);
1728 /* Generate the copying loops. */
1729 gfc_trans_scalarizing_loops (&loop
, &body1
);
1731 gfc_add_block_to_block (&block
, &loop
.pre
);
1732 gfc_add_block_to_block (&block
, &loop
.post
);
1734 gfc_cleanup_loop (&loop
);
1735 /* TODO: Reuse lss and rss when copying temp->lhs. Need to be careful
1736 as tree nodes in SS may not be valid in different scope. */
1739 tmp
= gfc_finish_block (&block
);
1744 /* Calculate the size of temporary needed in the assignment inside forall.
1745 LSS and RSS are filled in this function. */
1748 compute_inner_temp_size (gfc_expr
*expr1
, gfc_expr
*expr2
,
1749 stmtblock_t
* pblock
,
1750 gfc_ss
**lss
, gfc_ss
**rss
)
1757 *lss
= gfc_walk_expr (expr1
);
1760 size
= gfc_index_one_node
;
1761 if (*lss
!= gfc_ss_terminator
)
1763 gfc_init_loopinfo (&loop
);
1765 /* Walk the RHS of the expression. */
1766 *rss
= gfc_walk_expr (expr2
);
1767 if (*rss
== gfc_ss_terminator
)
1769 /* The rhs is scalar. Add a ss for the expression. */
1770 *rss
= gfc_get_ss ();
1771 (*rss
)->next
= gfc_ss_terminator
;
1772 (*rss
)->type
= GFC_SS_SCALAR
;
1773 (*rss
)->expr
= expr2
;
1776 /* Associate the SS with the loop. */
1777 gfc_add_ss_to_loop (&loop
, *lss
);
1778 /* We don't actually need to add the rhs at this point, but it might
1779 make guessing the loop bounds a bit easier. */
1780 gfc_add_ss_to_loop (&loop
, *rss
);
1782 /* We only want the shape of the expression, not rest of the junk
1783 generated by the scalarizer. */
1784 loop
.array_parameter
= 1;
1786 /* Calculate the bounds of the scalarization. */
1787 gfc_conv_ss_startstride (&loop
);
1788 gfc_conv_loop_setup (&loop
);
1790 /* Figure out how many elements we need. */
1791 for (i
= 0; i
< loop
.dimen
; i
++)
1793 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
1794 gfc_index_one_node
, loop
.from
[i
]);
1795 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
1797 size
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, size
, tmp
);
1799 gfc_add_block_to_block (pblock
, &loop
.pre
);
1800 size
= gfc_evaluate_now (size
, pblock
);
1801 gfc_add_block_to_block (pblock
, &loop
.post
);
1803 /* TODO: write a function that cleans up a loopinfo without freeing
1804 the SS chains. Currently a NOP. */
1811 /* Calculate the overall iterator number of the nested forall construct. */
1814 compute_overall_iter_number (forall_info
*nested_forall_info
, tree inner_size
,
1815 stmtblock_t
*inner_size_body
, stmtblock_t
*block
)
1820 /* TODO: optimizing the computing process. */
1821 number
= gfc_create_var (gfc_array_index_type
, "num");
1822 gfc_add_modify_expr (block
, number
, gfc_index_zero_node
);
1824 gfc_start_block (&body
);
1825 if (inner_size_body
)
1826 gfc_add_block_to_block (&body
, inner_size_body
);
1827 if (nested_forall_info
)
1828 tmp
= build2 (PLUS_EXPR
, gfc_array_index_type
, number
,
1832 gfc_add_modify_expr (&body
, number
, tmp
);
1833 tmp
= gfc_finish_block (&body
);
1835 /* Generate loops. */
1836 if (nested_forall_info
!= NULL
)
1837 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, tmp
, 0, 1);
1839 gfc_add_expr_to_block (block
, tmp
);
1845 /* Allocate temporary for forall construct. SIZE is the size of temporary
1846 needed. PTEMP1 is returned for space free. */
1849 allocate_temp_for_forall_nest_1 (tree type
, tree size
, stmtblock_t
* block
,
1857 unit
= TYPE_SIZE_UNIT (type
);
1858 bytesize
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, size
, unit
);
1861 temp1
= gfc_do_allocate (bytesize
, size
, ptemp1
, block
, type
);
1864 tmp
= gfc_build_indirect_ref (temp1
);
1872 /* Allocate temporary for forall construct according to the information in
1873 nested_forall_info. INNER_SIZE is the size of temporary needed in the
1874 assignment inside forall. PTEMP1 is returned for space free. */
1877 allocate_temp_for_forall_nest (forall_info
* nested_forall_info
, tree type
,
1878 tree inner_size
, stmtblock_t
* inner_size_body
,
1879 stmtblock_t
* block
, tree
* ptemp1
)
1883 /* Calculate the total size of temporary needed in forall construct. */
1884 size
= compute_overall_iter_number (nested_forall_info
, inner_size
,
1885 inner_size_body
, block
);
1887 return allocate_temp_for_forall_nest_1 (type
, size
, block
, ptemp1
);
1891 /* Handle assignments inside forall which need temporary.
1893 forall (i=start:end:stride; maskexpr)
1896 (where e,f<i> are arbitrary expressions possibly involving i
1897 and there is a dependency between e<i> and f<i>)
1899 masktmp(:) = maskexpr(:)
1904 for (i = start; i <= end; i += stride)
1908 for (i = start; i <= end; i += stride)
1910 if (masktmp[maskindex++])
1911 tmp[count1++] = f<i>
1915 for (i = start; i <= end; i += stride)
1917 if (masktmp[maskindex++])
1918 e<i> = tmp[count1++]
1923 gfc_trans_assign_need_temp (gfc_expr
* expr1
, gfc_expr
* expr2
, tree wheremask
,
1924 forall_info
* nested_forall_info
,
1925 stmtblock_t
* block
)
1933 tree mask
, maskindex
;
1934 forall_info
*forall_tmp
;
1935 stmtblock_t inner_size_body
;
1937 /* Create vars. count1 is the current iterator number of the nested
1939 count1
= gfc_create_var (gfc_array_index_type
, "count1");
1941 /* Count is the wheremask index. */
1944 count
= gfc_create_var (gfc_array_index_type
, "count");
1945 gfc_add_modify_expr (block
, count
, gfc_index_zero_node
);
1950 /* Initialize count1. */
1951 gfc_add_modify_expr (block
, count1
, gfc_index_zero_node
);
1953 /* Calculate the size of temporary needed in the assignment. Return loop, lss
1954 and rss which are used in function generate_loop_for_rhs_to_temp(). */
1955 gfc_init_block (&inner_size_body
);
1956 inner_size
= compute_inner_temp_size (expr1
, expr2
, &inner_size_body
,
1959 /* The type of LHS. Used in function allocate_temp_for_forall_nest */
1960 type
= gfc_typenode_for_spec (&expr1
->ts
);
1962 /* Allocate temporary for nested forall construct according to the
1963 information in nested_forall_info and inner_size. */
1964 tmp1
= allocate_temp_for_forall_nest (nested_forall_info
, type
, inner_size
,
1965 &inner_size_body
, block
, &ptemp1
);
1967 /* Initialize the maskindexes. */
1968 forall_tmp
= nested_forall_info
;
1969 while (forall_tmp
!= NULL
)
1971 mask
= forall_tmp
->mask
;
1972 maskindex
= forall_tmp
->maskindex
;
1974 gfc_add_modify_expr (block
, maskindex
, gfc_index_zero_node
);
1975 forall_tmp
= forall_tmp
->next_nest
;
1978 /* Generate codes to copy rhs to the temporary . */
1979 tmp
= generate_loop_for_rhs_to_temp (expr2
, tmp1
, count
, count1
, lss
, rss
,
1982 /* Generate body and loops according to the information in
1983 nested_forall_info. */
1984 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, tmp
, 1, 1);
1985 gfc_add_expr_to_block (block
, tmp
);
1988 gfc_add_modify_expr (block
, count1
, gfc_index_zero_node
);
1990 /* Reset maskindexed. */
1991 forall_tmp
= nested_forall_info
;
1992 while (forall_tmp
!= NULL
)
1994 mask
= forall_tmp
->mask
;
1995 maskindex
= forall_tmp
->maskindex
;
1997 gfc_add_modify_expr (block
, maskindex
, gfc_index_zero_node
);
1998 forall_tmp
= forall_tmp
->next_nest
;
2003 gfc_add_modify_expr (block
, count
, gfc_index_zero_node
);
2005 /* Generate codes to copy the temporary to lhs. */
2006 tmp
= generate_loop_for_temp_to_lhs (expr1
, tmp1
, count
, count1
, wheremask
);
2008 /* Generate body and loops according to the information in
2009 nested_forall_info. */
2010 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, tmp
, 1, 1);
2011 gfc_add_expr_to_block (block
, tmp
);
2015 /* Free the temporary. */
2016 tmp
= gfc_chainon_list (NULL_TREE
, ptemp1
);
2017 tmp
= gfc_build_function_call (gfor_fndecl_internal_free
, tmp
);
2018 gfc_add_expr_to_block (block
, tmp
);
2023 /* Translate pointer assignment inside FORALL which need temporary. */
2026 gfc_trans_pointer_assign_need_temp (gfc_expr
* expr1
, gfc_expr
* expr2
,
2027 forall_info
* nested_forall_info
,
2028 stmtblock_t
* block
)
2042 tree tmp
, tmp1
, ptemp1
;
2043 tree mask
, maskindex
;
2044 forall_info
*forall_tmp
;
2046 count
= gfc_create_var (gfc_array_index_type
, "count");
2047 gfc_add_modify_expr (block
, count
, gfc_index_zero_node
);
2049 inner_size
= integer_one_node
;
2050 lss
= gfc_walk_expr (expr1
);
2051 rss
= gfc_walk_expr (expr2
);
2052 if (lss
== gfc_ss_terminator
)
2054 type
= gfc_typenode_for_spec (&expr1
->ts
);
2055 type
= build_pointer_type (type
);
2057 /* Allocate temporary for nested forall construct according to the
2058 information in nested_forall_info and inner_size. */
2059 tmp1
= allocate_temp_for_forall_nest (nested_forall_info
, type
,
2060 inner_size
, NULL
, block
, &ptemp1
);
2061 gfc_start_block (&body
);
2062 gfc_init_se (&lse
, NULL
);
2063 lse
.expr
= gfc_build_array_ref (tmp1
, count
);
2064 gfc_init_se (&rse
, NULL
);
2065 rse
.want_pointer
= 1;
2066 gfc_conv_expr (&rse
, expr2
);
2067 gfc_add_block_to_block (&body
, &rse
.pre
);
2068 gfc_add_modify_expr (&body
, lse
.expr
, rse
.expr
);
2069 gfc_add_block_to_block (&body
, &rse
.post
);
2071 /* Increment count. */
2072 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
2073 count
, gfc_index_one_node
);
2074 gfc_add_modify_expr (&body
, count
, tmp
);
2076 tmp
= gfc_finish_block (&body
);
2078 /* Initialize the maskindexes. */
2079 forall_tmp
= nested_forall_info
;
2080 while (forall_tmp
!= NULL
)
2082 mask
= forall_tmp
->mask
;
2083 maskindex
= forall_tmp
->maskindex
;
2085 gfc_add_modify_expr (block
, maskindex
, gfc_index_zero_node
);
2086 forall_tmp
= forall_tmp
->next_nest
;
2089 /* Generate body and loops according to the information in
2090 nested_forall_info. */
2091 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, tmp
, 1, 1);
2092 gfc_add_expr_to_block (block
, tmp
);
2095 gfc_add_modify_expr (block
, count
, gfc_index_zero_node
);
2097 /* Reset maskindexes. */
2098 forall_tmp
= nested_forall_info
;
2099 while (forall_tmp
!= NULL
)
2101 mask
= forall_tmp
->mask
;
2102 maskindex
= forall_tmp
->maskindex
;
2104 gfc_add_modify_expr (block
, maskindex
, gfc_index_zero_node
);
2105 forall_tmp
= forall_tmp
->next_nest
;
2107 gfc_start_block (&body
);
2108 gfc_init_se (&lse
, NULL
);
2109 gfc_init_se (&rse
, NULL
);
2110 rse
.expr
= gfc_build_array_ref (tmp1
, count
);
2111 lse
.want_pointer
= 1;
2112 gfc_conv_expr (&lse
, expr1
);
2113 gfc_add_block_to_block (&body
, &lse
.pre
);
2114 gfc_add_modify_expr (&body
, lse
.expr
, rse
.expr
);
2115 gfc_add_block_to_block (&body
, &lse
.post
);
2116 /* Increment count. */
2117 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
2118 count
, gfc_index_one_node
);
2119 gfc_add_modify_expr (&body
, count
, tmp
);
2120 tmp
= gfc_finish_block (&body
);
2122 /* Generate body and loops according to the information in
2123 nested_forall_info. */
2124 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, tmp
, 1, 1);
2125 gfc_add_expr_to_block (block
, tmp
);
2129 gfc_init_loopinfo (&loop
);
2131 /* Associate the SS with the loop. */
2132 gfc_add_ss_to_loop (&loop
, rss
);
2134 /* Setup the scalarizing loops and bounds. */
2135 gfc_conv_ss_startstride (&loop
);
2137 gfc_conv_loop_setup (&loop
);
2139 info
= &rss
->data
.info
;
2140 desc
= info
->descriptor
;
2142 /* Make a new descriptor. */
2143 parmtype
= gfc_get_element_type (TREE_TYPE (desc
));
2144 parmtype
= gfc_get_array_type_bounds (parmtype
, loop
.dimen
,
2145 loop
.from
, loop
.to
, 1);
2147 /* Allocate temporary for nested forall construct. */
2148 tmp1
= allocate_temp_for_forall_nest (nested_forall_info
, parmtype
,
2149 inner_size
, NULL
, block
, &ptemp1
);
2150 gfc_start_block (&body
);
2151 gfc_init_se (&lse
, NULL
);
2152 lse
.expr
= gfc_build_array_ref (tmp1
, count
);
2153 lse
.direct_byref
= 1;
2154 rss
= gfc_walk_expr (expr2
);
2155 gfc_conv_expr_descriptor (&lse
, expr2
, rss
);
2157 gfc_add_block_to_block (&body
, &lse
.pre
);
2158 gfc_add_block_to_block (&body
, &lse
.post
);
2160 /* Increment count. */
2161 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
2162 count
, gfc_index_one_node
);
2163 gfc_add_modify_expr (&body
, count
, tmp
);
2165 tmp
= gfc_finish_block (&body
);
2167 /* Initialize the maskindexes. */
2168 forall_tmp
= nested_forall_info
;
2169 while (forall_tmp
!= NULL
)
2171 mask
= forall_tmp
->mask
;
2172 maskindex
= forall_tmp
->maskindex
;
2174 gfc_add_modify_expr (block
, maskindex
, gfc_index_zero_node
);
2175 forall_tmp
= forall_tmp
->next_nest
;
2178 /* Generate body and loops according to the information in
2179 nested_forall_info. */
2180 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, tmp
, 1, 1);
2181 gfc_add_expr_to_block (block
, tmp
);
2184 gfc_add_modify_expr (block
, count
, gfc_index_zero_node
);
2186 /* Reset maskindexes. */
2187 forall_tmp
= nested_forall_info
;
2188 while (forall_tmp
!= NULL
)
2190 mask
= forall_tmp
->mask
;
2191 maskindex
= forall_tmp
->maskindex
;
2193 gfc_add_modify_expr (block
, maskindex
, gfc_index_zero_node
);
2194 forall_tmp
= forall_tmp
->next_nest
;
2196 parm
= gfc_build_array_ref (tmp1
, count
);
2197 lss
= gfc_walk_expr (expr1
);
2198 gfc_init_se (&lse
, NULL
);
2199 gfc_conv_expr_descriptor (&lse
, expr1
, lss
);
2200 gfc_add_modify_expr (&lse
.pre
, lse
.expr
, parm
);
2201 gfc_start_block (&body
);
2202 gfc_add_block_to_block (&body
, &lse
.pre
);
2203 gfc_add_block_to_block (&body
, &lse
.post
);
2205 /* Increment count. */
2206 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
2207 count
, gfc_index_one_node
);
2208 gfc_add_modify_expr (&body
, count
, tmp
);
2210 tmp
= gfc_finish_block (&body
);
2212 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, tmp
, 1, 1);
2213 gfc_add_expr_to_block (block
, tmp
);
2215 /* Free the temporary. */
2218 tmp
= gfc_chainon_list (NULL_TREE
, ptemp1
);
2219 tmp
= gfc_build_function_call (gfor_fndecl_internal_free
, tmp
);
2220 gfc_add_expr_to_block (block
, tmp
);
2225 /* FORALL and WHERE statements are really nasty, especially when you nest
2226 them. All the rhs of a forall assignment must be evaluated before the
2227 actual assignments are performed. Presumably this also applies to all the
2228 assignments in an inner where statement. */
2230 /* Generate code for a FORALL statement. Any temporaries are allocated as a
2231 linear array, relying on the fact that we process in the same order in all
2234 forall (i=start:end:stride; maskexpr)
2238 (where e,f,g,h<i> are arbitrary expressions possibly involving i)
2240 count = ((end + 1 - start) / stride)
2241 masktmp(:) = maskexpr(:)
2244 for (i = start; i <= end; i += stride)
2246 if (masktmp[maskindex++])
2250 for (i = start; i <= end; i += stride)
2252 if (masktmp[maskindex++])
2256 Note that this code only works when there are no dependencies.
2257 Forall loop with array assignments and data dependencies are a real pain,
2258 because the size of the temporary cannot always be determined before the
2259 loop is executed. This problem is compounded by the presence of nested
2264 gfc_trans_forall_1 (gfc_code
* code
, forall_info
* nested_forall_info
)
2286 gfc_forall_iterator
*fa
;
2289 gfc_saved_var
*saved_vars
;
2290 iter_info
*this_forall
, *iter_tmp
;
2291 forall_info
*info
, *forall_tmp
;
2292 temporary_list
*temp
;
2294 gfc_start_block (&block
);
2297 /* Count the FORALL index number. */
2298 for (fa
= code
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
2302 /* Allocate the space for var, start, end, step, varexpr. */
2303 var
= (tree
*) gfc_getmem (nvar
* sizeof (tree
));
2304 start
= (tree
*) gfc_getmem (nvar
* sizeof (tree
));
2305 end
= (tree
*) gfc_getmem (nvar
* sizeof (tree
));
2306 step
= (tree
*) gfc_getmem (nvar
* sizeof (tree
));
2307 varexpr
= (gfc_expr
**) gfc_getmem (nvar
* sizeof (gfc_expr
*));
2308 saved_vars
= (gfc_saved_var
*) gfc_getmem (nvar
* sizeof (gfc_saved_var
));
2310 /* Allocate the space for info. */
2311 info
= (forall_info
*) gfc_getmem (sizeof (forall_info
));
2313 for (fa
= code
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
2315 gfc_symbol
*sym
= fa
->var
->symtree
->n
.sym
;
2317 /* allocate space for this_forall. */
2318 this_forall
= (iter_info
*) gfc_getmem (sizeof (iter_info
));
2320 /* Create a temporary variable for the FORALL index. */
2321 tmp
= gfc_typenode_for_spec (&sym
->ts
);
2322 var
[n
] = gfc_create_var (tmp
, sym
->name
);
2323 gfc_shadow_sym (sym
, var
[n
], &saved_vars
[n
]);
2325 /* Record it in this_forall. */
2326 this_forall
->var
= var
[n
];
2328 /* Replace the index symbol's backend_decl with the temporary decl. */
2329 sym
->backend_decl
= var
[n
];
2331 /* Work out the start, end and stride for the loop. */
2332 gfc_init_se (&se
, NULL
);
2333 gfc_conv_expr_val (&se
, fa
->start
);
2334 /* Record it in this_forall. */
2335 this_forall
->start
= se
.expr
;
2336 gfc_add_block_to_block (&block
, &se
.pre
);
2339 gfc_init_se (&se
, NULL
);
2340 gfc_conv_expr_val (&se
, fa
->end
);
2341 /* Record it in this_forall. */
2342 this_forall
->end
= se
.expr
;
2343 gfc_make_safe_expr (&se
);
2344 gfc_add_block_to_block (&block
, &se
.pre
);
2347 gfc_init_se (&se
, NULL
);
2348 gfc_conv_expr_val (&se
, fa
->stride
);
2349 /* Record it in this_forall. */
2350 this_forall
->step
= se
.expr
;
2351 gfc_make_safe_expr (&se
);
2352 gfc_add_block_to_block (&block
, &se
.pre
);
2355 /* Set the NEXT field of this_forall to NULL. */
2356 this_forall
->next
= NULL
;
2357 /* Link this_forall to the info construct. */
2358 if (info
->this_loop
== NULL
)
2359 info
->this_loop
= this_forall
;
2362 iter_tmp
= info
->this_loop
;
2363 while (iter_tmp
->next
!= NULL
)
2364 iter_tmp
= iter_tmp
->next
;
2365 iter_tmp
->next
= this_forall
;
2372 /* Work out the number of elements in the mask array. */
2375 size
= gfc_index_one_node
;
2376 sizevar
= NULL_TREE
;
2378 for (n
= 0; n
< nvar
; n
++)
2380 if (lenvar
&& TREE_TYPE (lenvar
) != TREE_TYPE (start
[n
]))
2383 /* size = (end + step - start) / step. */
2384 tmp
= fold_build2 (MINUS_EXPR
, TREE_TYPE (start
[n
]),
2386 tmp
= fold_build2 (PLUS_EXPR
, TREE_TYPE (end
[n
]), end
[n
], tmp
);
2388 tmp
= fold_build2 (FLOOR_DIV_EXPR
, TREE_TYPE (tmp
), tmp
, step
[n
]);
2389 tmp
= convert (gfc_array_index_type
, tmp
);
2391 size
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, size
, tmp
);
2394 /* Record the nvar and size of current forall level. */
2398 /* Link the current forall level to nested_forall_info. */
2399 forall_tmp
= nested_forall_info
;
2400 if (forall_tmp
== NULL
)
2401 nested_forall_info
= info
;
2404 while (forall_tmp
->next_nest
!= NULL
)
2405 forall_tmp
= forall_tmp
->next_nest
;
2406 info
->outer
= forall_tmp
;
2407 forall_tmp
->next_nest
= info
;
2410 /* Copy the mask into a temporary variable if required.
2411 For now we assume a mask temporary is needed. */
2414 /* Allocate the mask temporary. */
2415 bytesize
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, size
,
2416 TYPE_SIZE_UNIT (boolean_type_node
));
2418 mask
= gfc_do_allocate (bytesize
, size
, &pmask
, &block
, boolean_type_node
);
2420 maskindex
= gfc_create_var_np (gfc_array_index_type
, "mi");
2421 /* Record them in the info structure. */
2422 info
->pmask
= pmask
;
2424 info
->maskindex
= maskindex
;
2426 gfc_add_modify_expr (&block
, maskindex
, gfc_index_zero_node
);
2428 /* Start of mask assignment loop body. */
2429 gfc_start_block (&body
);
2431 /* Evaluate the mask expression. */
2432 gfc_init_se (&se
, NULL
);
2433 gfc_conv_expr_val (&se
, code
->expr
);
2434 gfc_add_block_to_block (&body
, &se
.pre
);
2436 /* Store the mask. */
2437 se
.expr
= convert (boolean_type_node
, se
.expr
);
2440 tmp
= gfc_build_indirect_ref (mask
);
2443 tmp
= gfc_build_array_ref (tmp
, maskindex
);
2444 gfc_add_modify_expr (&body
, tmp
, se
.expr
);
2446 /* Advance to the next mask element. */
2447 tmp
= build2 (PLUS_EXPR
, gfc_array_index_type
,
2448 maskindex
, gfc_index_one_node
);
2449 gfc_add_modify_expr (&body
, maskindex
, tmp
);
2451 /* Generate the loops. */
2452 tmp
= gfc_finish_block (&body
);
2453 tmp
= gfc_trans_nested_forall_loop (info
, tmp
, 0, 0);
2454 gfc_add_expr_to_block (&block
, tmp
);
2458 /* No mask was specified. */
2459 maskindex
= NULL_TREE
;
2460 mask
= pmask
= NULL_TREE
;
2463 c
= code
->block
->next
;
2465 /* TODO: loop merging in FORALL statements. */
2466 /* Now that we've got a copy of the mask, generate the assignment loops. */
2472 /* A scalar or array assignment. */
2473 need_temp
= gfc_check_dependency (c
->expr
, c
->expr2
, varexpr
, nvar
);
2474 /* Temporaries due to array assignment data dependencies introduce
2475 no end of problems. */
2477 gfc_trans_assign_need_temp (c
->expr
, c
->expr2
, NULL
,
2478 nested_forall_info
, &block
);
2481 /* Use the normal assignment copying routines. */
2482 assign
= gfc_trans_assignment (c
->expr
, c
->expr2
);
2484 /* Reset the mask index. */
2486 gfc_add_modify_expr (&block
, maskindex
, gfc_index_zero_node
);
2488 /* Generate body and loops. */
2489 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, assign
, 1, 1);
2490 gfc_add_expr_to_block (&block
, tmp
);
2497 /* Translate WHERE or WHERE construct nested in FORALL. */
2499 gfc_trans_where_2 (c
, NULL
, NULL
, nested_forall_info
, &block
, &temp
);
2506 /* Free the temporary. */
2507 args
= gfc_chainon_list (NULL_TREE
, temp
->temporary
);
2508 tmp
= gfc_build_function_call (gfor_fndecl_internal_free
, args
);
2509 gfc_add_expr_to_block (&block
, tmp
);
2518 /* Pointer assignment inside FORALL. */
2519 case EXEC_POINTER_ASSIGN
:
2520 need_temp
= gfc_check_dependency (c
->expr
, c
->expr2
, varexpr
, nvar
);
2522 gfc_trans_pointer_assign_need_temp (c
->expr
, c
->expr2
,
2523 nested_forall_info
, &block
);
2526 /* Use the normal assignment copying routines. */
2527 assign
= gfc_trans_pointer_assignment (c
->expr
, c
->expr2
);
2529 /* Reset the mask index. */
2531 gfc_add_modify_expr (&block
, maskindex
, gfc_index_zero_node
);
2533 /* Generate body and loops. */
2534 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, assign
,
2536 gfc_add_expr_to_block (&block
, tmp
);
2541 tmp
= gfc_trans_forall_1 (c
, nested_forall_info
);
2542 gfc_add_expr_to_block (&block
, tmp
);
2552 /* Restore the original index variables. */
2553 for (fa
= code
->ext
.forall_iterator
, n
= 0; fa
; fa
= fa
->next
, n
++)
2554 gfc_restore_sym (fa
->var
->symtree
->n
.sym
, &saved_vars
[n
]);
2556 /* Free the space for var, start, end, step, varexpr. */
2562 gfc_free (saved_vars
);
2566 /* Free the temporary for the mask. */
2567 tmp
= gfc_chainon_list (NULL_TREE
, pmask
);
2568 tmp
= gfc_build_function_call (gfor_fndecl_internal_free
, tmp
);
2569 gfc_add_expr_to_block (&block
, tmp
);
2572 pushdecl (maskindex
);
2574 return gfc_finish_block (&block
);
2578 /* Translate the FORALL statement or construct. */
2580 tree
gfc_trans_forall (gfc_code
* code
)
2582 return gfc_trans_forall_1 (code
, NULL
);
2586 /* Evaluate the WHERE mask expression, copy its value to a temporary.
2587 If the WHERE construct is nested in FORALL, compute the overall temporary
2588 needed by the WHERE mask expression multiplied by the iterator number of
2590 ME is the WHERE mask expression.
2591 MASK is the temporary which value is mask's value.
2592 NMASK is another temporary which value is !mask.
2593 TEMP records the temporary's address allocated in this function in order to
2594 free them outside this function.
2595 MASK, NMASK and TEMP are all OUT arguments. */
2598 gfc_evaluate_where_mask (gfc_expr
* me
, forall_info
* nested_forall_info
,
2599 tree
* mask
, tree
* nmask
, temporary_list
** temp
,
2600 stmtblock_t
* block
)
2605 tree ptemp1
, ntmp
, ptemp2
;
2606 tree inner_size
, size
;
2607 stmtblock_t body
, body1
, inner_size_body
;
2612 gfc_init_loopinfo (&loop
);
2614 /* Calculate the size of temporary needed by the mask-expr. */
2615 gfc_init_block (&inner_size_body
);
2616 inner_size
= compute_inner_temp_size (me
, me
, &inner_size_body
, &lss
, &rss
);
2618 /* Calculate the total size of temporary needed. */
2619 size
= compute_overall_iter_number (nested_forall_info
, inner_size
,
2620 &inner_size_body
, block
);
2622 /* Allocate temporary for where mask. */
2623 tmp
= allocate_temp_for_forall_nest_1 (boolean_type_node
, size
, block
,
2625 /* Record the temporary address in order to free it later. */
2628 temporary_list
*tempo
;
2629 tempo
= (temporary_list
*) gfc_getmem (sizeof (temporary_list
));
2630 tempo
->temporary
= ptemp1
;
2631 tempo
->next
= *temp
;
2635 /* Allocate temporary for !mask. */
2636 ntmp
= allocate_temp_for_forall_nest_1 (boolean_type_node
, size
, block
,
2638 /* Record the temporary in order to free it later. */
2641 temporary_list
*tempo
;
2642 tempo
= (temporary_list
*) gfc_getmem (sizeof (temporary_list
));
2643 tempo
->temporary
= ptemp2
;
2644 tempo
->next
= *temp
;
2648 /* Variable to index the temporary. */
2649 count
= gfc_create_var (gfc_array_index_type
, "count");
2650 /* Initialize count. */
2651 gfc_add_modify_expr (block
, count
, gfc_index_zero_node
);
2653 gfc_start_block (&body
);
2655 gfc_init_se (&rse
, NULL
);
2656 gfc_init_se (&lse
, NULL
);
2658 if (lss
== gfc_ss_terminator
)
2660 gfc_init_block (&body1
);
2664 /* Initialize the loop. */
2665 gfc_init_loopinfo (&loop
);
2667 /* We may need LSS to determine the shape of the expression. */
2668 gfc_add_ss_to_loop (&loop
, lss
);
2669 gfc_add_ss_to_loop (&loop
, rss
);
2671 gfc_conv_ss_startstride (&loop
);
2672 gfc_conv_loop_setup (&loop
);
2674 gfc_mark_ss_chain_used (rss
, 1);
2675 /* Start the loop body. */
2676 gfc_start_scalarized_body (&loop
, &body1
);
2678 /* Translate the expression. */
2679 gfc_copy_loopinfo_to_se (&rse
, &loop
);
2681 gfc_conv_expr (&rse
, me
);
2683 /* Form the expression of the temporary. */
2684 lse
.expr
= gfc_build_array_ref (tmp
, count
);
2685 tmpexpr
= gfc_build_array_ref (ntmp
, count
);
2687 /* Use the scalar assignment to fill temporary TMP. */
2688 tmp1
= gfc_trans_scalar_assign (&lse
, &rse
, me
->ts
.type
);
2689 gfc_add_expr_to_block (&body1
, tmp1
);
2691 /* Fill temporary NTMP. */
2692 tmp1
= build1 (TRUTH_NOT_EXPR
, TREE_TYPE (lse
.expr
), lse
.expr
);
2693 gfc_add_modify_expr (&body1
, tmpexpr
, tmp1
);
2695 if (lss
== gfc_ss_terminator
)
2697 gfc_add_block_to_block (&body
, &body1
);
2701 /* Increment count. */
2702 tmp1
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
, count
,
2703 gfc_index_one_node
);
2704 gfc_add_modify_expr (&body1
, count
, tmp1
);
2706 /* Generate the copying loops. */
2707 gfc_trans_scalarizing_loops (&loop
, &body1
);
2709 gfc_add_block_to_block (&body
, &loop
.pre
);
2710 gfc_add_block_to_block (&body
, &loop
.post
);
2712 gfc_cleanup_loop (&loop
);
2713 /* TODO: Reuse lss and rss when copying temp->lhs. Need to be careful
2714 as tree nodes in SS may not be valid in different scope. */
2717 tmp1
= gfc_finish_block (&body
);
2718 /* If the WHERE construct is inside FORALL, fill the full temporary. */
2719 if (nested_forall_info
!= NULL
)
2721 forall_info
*forall_tmp
;
2724 /* Initialize the maskindexes. */
2725 forall_tmp
= nested_forall_info
;
2726 while (forall_tmp
!= NULL
)
2728 maskindex
= forall_tmp
->maskindex
;
2729 if (forall_tmp
->mask
)
2730 gfc_add_modify_expr (block
, maskindex
, gfc_index_zero_node
);
2731 forall_tmp
= forall_tmp
->next_nest
;
2734 tmp1
= gfc_trans_nested_forall_loop (nested_forall_info
, tmp1
, 1, 1);
2737 gfc_add_expr_to_block (block
, tmp1
);
2746 /* Translate an assignment statement in a WHERE statement or construct
2747 statement. The MASK expression is used to control which elements
2748 of EXPR1 shall be assigned. */
2751 gfc_trans_where_assign (gfc_expr
*expr1
, gfc_expr
*expr2
, tree mask
,
2752 tree count1
, tree count2
)
2757 gfc_ss
*lss_section
;
2764 tree index
, maskexpr
, tmp1
;
2767 /* TODO: handle this special case.
2768 Special case a single function returning an array. */
2769 if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->rank
> 0)
2771 tmp
= gfc_trans_arrayfunc_assign (expr1
, expr2
);
2777 /* Assignment of the form lhs = rhs. */
2778 gfc_start_block (&block
);
2780 gfc_init_se (&lse
, NULL
);
2781 gfc_init_se (&rse
, NULL
);
2784 lss
= gfc_walk_expr (expr1
);
2787 /* In each where-assign-stmt, the mask-expr and the variable being
2788 defined shall be arrays of the same shape. */
2789 gcc_assert (lss
!= gfc_ss_terminator
);
2791 /* The assignment needs scalarization. */
2794 /* Find a non-scalar SS from the lhs. */
2795 while (lss_section
!= gfc_ss_terminator
2796 && lss_section
->type
!= GFC_SS_SECTION
)
2797 lss_section
= lss_section
->next
;
2799 gcc_assert (lss_section
!= gfc_ss_terminator
);
2801 /* Initialize the scalarizer. */
2802 gfc_init_loopinfo (&loop
);
2805 rss
= gfc_walk_expr (expr2
);
2806 if (rss
== gfc_ss_terminator
)
2808 /* The rhs is scalar. Add a ss for the expression. */
2809 rss
= gfc_get_ss ();
2810 rss
->next
= gfc_ss_terminator
;
2811 rss
->type
= GFC_SS_SCALAR
;
2815 /* Associate the SS with the loop. */
2816 gfc_add_ss_to_loop (&loop
, lss
);
2817 gfc_add_ss_to_loop (&loop
, rss
);
2819 /* Calculate the bounds of the scalarization. */
2820 gfc_conv_ss_startstride (&loop
);
2822 /* Resolve any data dependencies in the statement. */
2823 gfc_conv_resolve_dependencies (&loop
, lss_section
, rss
);
2825 /* Setup the scalarizing loops. */
2826 gfc_conv_loop_setup (&loop
);
2828 /* Setup the gfc_se structures. */
2829 gfc_copy_loopinfo_to_se (&lse
, &loop
);
2830 gfc_copy_loopinfo_to_se (&rse
, &loop
);
2833 gfc_mark_ss_chain_used (rss
, 1);
2834 if (loop
.temp_ss
== NULL
)
2837 gfc_mark_ss_chain_used (lss
, 1);
2841 lse
.ss
= loop
.temp_ss
;
2842 gfc_mark_ss_chain_used (lss
, 3);
2843 gfc_mark_ss_chain_used (loop
.temp_ss
, 3);
2846 /* Start the scalarized loop body. */
2847 gfc_start_scalarized_body (&loop
, &body
);
2849 /* Translate the expression. */
2850 gfc_conv_expr (&rse
, expr2
);
2851 if (lss
!= gfc_ss_terminator
&& loop
.temp_ss
!= NULL
)
2853 gfc_conv_tmp_array_ref (&lse
);
2854 gfc_advance_se_ss_chain (&lse
);
2857 gfc_conv_expr (&lse
, expr1
);
2859 /* Form the mask expression according to the mask tree list. */
2863 maskexpr
= gfc_build_array_ref (tmp
, index
);
2867 tmp
= TREE_CHAIN (tmp
);
2870 tmp1
= gfc_build_array_ref (tmp
, index
);
2871 maskexpr
= build2 (TRUTH_AND_EXPR
, TREE_TYPE (tmp1
), maskexpr
, tmp1
);
2872 tmp
= TREE_CHAIN (tmp
);
2874 /* Use the scalar assignment as is. */
2875 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
.type
);
2876 tmp
= build3_v (COND_EXPR
, maskexpr
, tmp
, build_empty_stmt ());
2878 gfc_add_expr_to_block (&body
, tmp
);
2880 if (lss
== gfc_ss_terminator
)
2882 /* Increment count1. */
2883 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
2884 count1
, gfc_index_one_node
);
2885 gfc_add_modify_expr (&body
, count1
, tmp
);
2887 /* Use the scalar assignment as is. */
2888 gfc_add_block_to_block (&block
, &body
);
2892 gcc_assert (lse
.ss
== gfc_ss_terminator
2893 && rse
.ss
== gfc_ss_terminator
);
2895 if (loop
.temp_ss
!= NULL
)
2897 /* Increment count1 before finish the main body of a scalarized
2899 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
2900 count1
, gfc_index_one_node
);
2901 gfc_add_modify_expr (&body
, count1
, tmp
);
2902 gfc_trans_scalarized_loop_boundary (&loop
, &body
);
2904 /* We need to copy the temporary to the actual lhs. */
2905 gfc_init_se (&lse
, NULL
);
2906 gfc_init_se (&rse
, NULL
);
2907 gfc_copy_loopinfo_to_se (&lse
, &loop
);
2908 gfc_copy_loopinfo_to_se (&rse
, &loop
);
2910 rse
.ss
= loop
.temp_ss
;
2913 gfc_conv_tmp_array_ref (&rse
);
2914 gfc_advance_se_ss_chain (&rse
);
2915 gfc_conv_expr (&lse
, expr1
);
2917 gcc_assert (lse
.ss
== gfc_ss_terminator
2918 && rse
.ss
== gfc_ss_terminator
);
2920 /* Form the mask expression according to the mask tree list. */
2924 maskexpr
= gfc_build_array_ref (tmp
, index
);
2928 tmp
= TREE_CHAIN (tmp
);
2931 tmp1
= gfc_build_array_ref (tmp
, index
);
2932 maskexpr
= build2 (TRUTH_AND_EXPR
, TREE_TYPE (tmp1
),
2934 tmp
= TREE_CHAIN (tmp
);
2936 /* Use the scalar assignment as is. */
2937 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
.type
);
2938 tmp
= build3_v (COND_EXPR
, maskexpr
, tmp
, build_empty_stmt ());
2939 gfc_add_expr_to_block (&body
, tmp
);
2941 /* Increment count2. */
2942 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
2943 count2
, gfc_index_one_node
);
2944 gfc_add_modify_expr (&body
, count2
, tmp
);
2948 /* Increment count1. */
2949 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
2950 count1
, gfc_index_one_node
);
2951 gfc_add_modify_expr (&body
, count1
, tmp
);
2954 /* Generate the copying loops. */
2955 gfc_trans_scalarizing_loops (&loop
, &body
);
2957 /* Wrap the whole thing up. */
2958 gfc_add_block_to_block (&block
, &loop
.pre
);
2959 gfc_add_block_to_block (&block
, &loop
.post
);
2960 gfc_cleanup_loop (&loop
);
2963 return gfc_finish_block (&block
);
2967 /* Translate the WHERE construct or statement.
2968 This function can be called iteratively to translate the nested WHERE
2969 construct or statement.
2970 MASK is the control mask, and PMASK is the pending control mask.
2971 TEMP records the temporary address which must be freed later. */
2974 gfc_trans_where_2 (gfc_code
* code
, tree mask
, tree pmask
,
2975 forall_info
* nested_forall_info
, stmtblock_t
* block
,
2976 temporary_list
** temp
)
2982 tree tmp
, tmp1
, tmp2
;
2983 tree count1
, count2
;
2987 /* the WHERE statement or the WHERE construct statement. */
2988 cblock
= code
->block
;
2991 /* Has mask-expr. */
2994 /* Ensure that the WHERE mask be evaluated only once. */
2995 tmp2
= gfc_evaluate_where_mask (cblock
->expr
, nested_forall_info
,
2996 &tmp
, &tmp1
, temp
, block
);
2998 /* Set the control mask and the pending control mask. */
2999 /* It's a where-stmt. */
3005 /* It's a nested where-stmt. */
3006 else if (mask
&& pmask
== NULL
)
3009 /* Use the TREE_CHAIN to list the masks. */
3010 tmp2
= copy_list (mask
);
3011 pmask
= chainon (mask
, tmp1
);
3012 mask
= chainon (tmp2
, tmp
);
3014 /* It's a masked-elsewhere-stmt. */
3015 else if (mask
&& cblock
->expr
)
3018 tmp2
= copy_list (pmask
);
3021 tmp2
= chainon (tmp2
, tmp
);
3022 pmask
= chainon (mask
, tmp1
);
3026 /* It's a elsewhere-stmt. No mask-expr is present. */
3030 /* Get the assignment statement of a WHERE statement, or the first
3031 statement in where-body-construct of a WHERE construct. */
3032 cnext
= cblock
->next
;
3037 /* WHERE assignment statement. */
3039 expr1
= cnext
->expr
;
3040 expr2
= cnext
->expr2
;
3041 if (nested_forall_info
!= NULL
)
3046 nvar
= nested_forall_info
->nvar
;
3047 varexpr
= (gfc_expr
**)
3048 gfc_getmem (nvar
* sizeof (gfc_expr
*));
3049 need_temp
= gfc_check_dependency (expr1
, expr2
, varexpr
,
3052 gfc_trans_assign_need_temp (expr1
, expr2
, mask
,
3053 nested_forall_info
, block
);
3056 forall_info
*forall_tmp
;
3059 /* Variables to control maskexpr. */
3060 count1
= gfc_create_var (gfc_array_index_type
, "count1");
3061 count2
= gfc_create_var (gfc_array_index_type
, "count2");
3062 gfc_add_modify_expr (block
, count1
, gfc_index_zero_node
);
3063 gfc_add_modify_expr (block
, count2
, gfc_index_zero_node
);
3065 tmp
= gfc_trans_where_assign (expr1
, expr2
, mask
, count1
,
3068 /* Initialize the maskindexes. */
3069 forall_tmp
= nested_forall_info
;
3070 while (forall_tmp
!= NULL
)
3072 maskindex
= forall_tmp
->maskindex
;
3073 if (forall_tmp
->mask
)
3074 gfc_add_modify_expr (block
, maskindex
,
3075 gfc_index_zero_node
);
3076 forall_tmp
= forall_tmp
->next_nest
;
3079 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
,
3081 gfc_add_expr_to_block (block
, tmp
);
3086 /* Variables to control maskexpr. */
3087 count1
= gfc_create_var (gfc_array_index_type
, "count1");
3088 count2
= gfc_create_var (gfc_array_index_type
, "count2");
3089 gfc_add_modify_expr (block
, count1
, gfc_index_zero_node
);
3090 gfc_add_modify_expr (block
, count2
, gfc_index_zero_node
);
3092 tmp
= gfc_trans_where_assign (expr1
, expr2
, mask
, count1
,
3094 gfc_add_expr_to_block (block
, tmp
);
3099 /* WHERE or WHERE construct is part of a where-body-construct. */
3101 /* Ensure that MASK is not modified by next gfc_trans_where_2. */
3102 mask_copy
= copy_list (mask
);
3103 gfc_trans_where_2 (cnext
, mask_copy
, NULL
, nested_forall_info
,
3111 /* The next statement within the same where-body-construct. */
3112 cnext
= cnext
->next
;
3114 /* The next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt. */
3115 cblock
= cblock
->block
;
3120 /* As the WHERE or WHERE construct statement can be nested, we call
3121 gfc_trans_where_2 to do the translation, and pass the initial
3122 NULL values for both the control mask and the pending control mask. */
3125 gfc_trans_where (gfc_code
* code
)
3128 temporary_list
*temp
, *p
;
3132 gfc_start_block (&block
);
3135 gfc_trans_where_2 (code
, NULL
, NULL
, NULL
, &block
, &temp
);
3137 /* Add calls to free temporaries which were dynamically allocated. */
3140 args
= gfc_chainon_list (NULL_TREE
, temp
->temporary
);
3141 tmp
= gfc_build_function_call (gfor_fndecl_internal_free
, args
);
3142 gfc_add_expr_to_block (&block
, tmp
);
3148 return gfc_finish_block (&block
);
3152 /* CYCLE a DO loop. The label decl has already been created by
3153 gfc_trans_do(), it's in TREE_PURPOSE (backend_decl) of the gfc_code
3154 node at the head of the loop. We must mark the label as used. */
3157 gfc_trans_cycle (gfc_code
* code
)
3161 cycle_label
= TREE_PURPOSE (code
->ext
.whichloop
->backend_decl
);
3162 TREE_USED (cycle_label
) = 1;
3163 return build1_v (GOTO_EXPR
, cycle_label
);
3167 /* EXIT a DO loop. Similar to CYCLE, but now the label is in
3168 TREE_VALUE (backend_decl) of the gfc_code node at the head of the
3172 gfc_trans_exit (gfc_code
* code
)
3176 exit_label
= TREE_VALUE (code
->ext
.whichloop
->backend_decl
);
3177 TREE_USED (exit_label
) = 1;
3178 return build1_v (GOTO_EXPR
, exit_label
);
3182 /* Translate the ALLOCATE statement. */
3185 gfc_trans_allocate (gfc_code
* code
)
3198 if (!code
->ext
.alloc_list
)
3201 gfc_start_block (&block
);
3205 tree gfc_int4_type_node
= gfc_get_int_type (4);
3207 stat
= gfc_create_var (gfc_int4_type_node
, "stat");
3208 pstat
= gfc_build_addr_expr (NULL
, stat
);
3210 error_label
= gfc_build_label_decl (NULL_TREE
);
3211 TREE_USED (error_label
) = 1;
3215 pstat
= integer_zero_node
;
3216 stat
= error_label
= NULL_TREE
;
3220 for (al
= code
->ext
.alloc_list
; al
!= NULL
; al
= al
->next
)
3224 gfc_init_se (&se
, NULL
);
3225 gfc_start_block (&se
.pre
);
3227 se
.want_pointer
= 1;
3228 se
.descriptor_only
= 1;
3229 gfc_conv_expr (&se
, expr
);
3233 /* Find the last reference in the chain. */
3234 while (ref
&& ref
->next
!= NULL
)
3236 gcc_assert (ref
->type
!= REF_ARRAY
|| ref
->u
.ar
.type
== AR_ELEMENT
);
3240 if (ref
!= NULL
&& ref
->type
== REF_ARRAY
)
3243 gfc_array_allocate (&se
, ref
, pstat
);
3247 /* A scalar or derived type. */
3250 val
= gfc_create_var (ppvoid_type_node
, "ptr");
3251 tmp
= gfc_build_addr_expr (ppvoid_type_node
, se
.expr
);
3252 gfc_add_modify_expr (&se
.pre
, val
, tmp
);
3254 tmp
= TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (se
.expr
)));
3255 parm
= gfc_chainon_list (NULL_TREE
, val
);
3256 parm
= gfc_chainon_list (parm
, tmp
);
3257 parm
= gfc_chainon_list (parm
, pstat
);
3258 tmp
= gfc_build_function_call (gfor_fndecl_allocate
, parm
);
3259 gfc_add_expr_to_block (&se
.pre
, tmp
);
3263 tmp
= build1_v (GOTO_EXPR
, error_label
);
3265 build2 (NE_EXPR
, boolean_type_node
, stat
, integer_zero_node
);
3266 tmp
= build3_v (COND_EXPR
, parm
, tmp
, build_empty_stmt ());
3267 gfc_add_expr_to_block (&se
.pre
, tmp
);
3271 tmp
= gfc_finish_block (&se
.pre
);
3272 gfc_add_expr_to_block (&block
, tmp
);
3275 /* Assign the value to the status variable. */
3278 tmp
= build1_v (LABEL_EXPR
, error_label
);
3279 gfc_add_expr_to_block (&block
, tmp
);
3281 gfc_init_se (&se
, NULL
);
3282 gfc_conv_expr_lhs (&se
, code
->expr
);
3283 tmp
= convert (TREE_TYPE (se
.expr
), stat
);
3284 gfc_add_modify_expr (&block
, se
.expr
, tmp
);
3287 return gfc_finish_block (&block
);
3291 /* Translate a DEALLOCATE statement.
3292 There are two cases within the for loop:
3293 (1) deallocate(a1, a2, a3) is translated into the following sequence
3294 _gfortran_deallocate(a1, 0B)
3295 _gfortran_deallocate(a2, 0B)
3296 _gfortran_deallocate(a3, 0B)
3297 where the STAT= variable is passed a NULL pointer.
3298 (2) deallocate(a1, a2, a3, stat=i) is translated into the following
3300 _gfortran_deallocate(a1, &stat)
3301 astat = astat + stat
3302 _gfortran_deallocate(a2, &stat)
3303 astat = astat + stat
3304 _gfortran_deallocate(a3, &stat)
3305 astat = astat + stat
3306 In case (1), we simply return at the end of the for loop. In case (2)
3307 we set STAT= astat. */
3309 gfc_trans_deallocate (gfc_code
* code
)
3314 tree apstat
, astat
, parm
, pstat
, stat
, tmp
, type
, var
;
3317 gfc_start_block (&block
);
3319 /* Set up the optional STAT= */
3322 tree gfc_int4_type_node
= gfc_get_int_type (4);
3324 /* Variable used with the library call. */
3325 stat
= gfc_create_var (gfc_int4_type_node
, "stat");
3326 pstat
= gfc_build_addr_expr (NULL
, stat
);
3328 /* Running total of possible deallocation failures. */
3329 astat
= gfc_create_var (gfc_int4_type_node
, "astat");
3330 apstat
= gfc_build_addr_expr (NULL
, astat
);
3332 /* Initialize astat to 0. */
3333 gfc_add_modify_expr (&block
, astat
, build_int_cst (TREE_TYPE (astat
), 0));
3337 pstat
= apstat
= null_pointer_node
;
3338 stat
= astat
= NULL_TREE
;
3341 for (al
= code
->ext
.alloc_list
; al
!= NULL
; al
= al
->next
)
3344 gcc_assert (expr
->expr_type
== EXPR_VARIABLE
);
3346 gfc_init_se (&se
, NULL
);
3347 gfc_start_block (&se
.pre
);
3349 se
.want_pointer
= 1;
3350 se
.descriptor_only
= 1;
3351 gfc_conv_expr (&se
, expr
);
3353 if (expr
->symtree
->n
.sym
->attr
.dimension
)
3354 tmp
= gfc_array_deallocate (se
.expr
, pstat
);
3357 type
= build_pointer_type (TREE_TYPE (se
.expr
));
3358 var
= gfc_create_var (type
, "ptr");
3359 tmp
= gfc_build_addr_expr (type
, se
.expr
);
3360 gfc_add_modify_expr (&se
.pre
, var
, tmp
);
3362 parm
= gfc_chainon_list (NULL_TREE
, var
);
3363 parm
= gfc_chainon_list (parm
, pstat
);
3364 tmp
= gfc_build_function_call (gfor_fndecl_deallocate
, parm
);
3367 gfc_add_expr_to_block (&se
.pre
, tmp
);
3369 /* Keep track of the number of failed deallocations by adding stat
3370 of the last deallocation to the running total. */
3373 apstat
= build2 (PLUS_EXPR
, TREE_TYPE (stat
), astat
, stat
);
3374 gfc_add_modify_expr (&se
.pre
, astat
, apstat
);
3377 tmp
= gfc_finish_block (&se
.pre
);
3378 gfc_add_expr_to_block (&block
, tmp
);
3382 /* Assign the value to the status variable. */
3385 gfc_init_se (&se
, NULL
);
3386 gfc_conv_expr_lhs (&se
, code
->expr
);
3387 tmp
= convert (TREE_TYPE (se
.expr
), astat
);
3388 gfc_add_modify_expr (&block
, se
.expr
, tmp
);
3391 return gfc_finish_block (&block
);