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, 59 Temple Place - Suite 330, 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. */
1370 mask
= forall_tmp
->mask
;
1371 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 the loop counter. */
1390 tmp
= fold_build2 (MINUS_EXPR
, TREE_TYPE (var
), step
, start
);
1391 tmp
= fold_build2 (PLUS_EXPR
, TREE_TYPE (var
), end
, tmp
);
1392 tmp
= fold_build2 (TRUNC_DIV_EXPR
, TREE_TYPE (var
), tmp
, step
);
1393 gfc_add_modify_expr (&block
, count
, tmp
);
1395 /* The loop expression. */
1396 tmp
= build1_v (LOOP_EXPR
, body
);
1397 gfc_add_expr_to_block (&block
, tmp
);
1399 /* The exit label. */
1400 tmp
= build1_v (LABEL_EXPR
, exit_label
);
1401 gfc_add_expr_to_block (&block
, tmp
);
1403 body
= gfc_finish_block (&block
);
1410 /* Generate the body and loops according to MASK_FLAG and NEST_FLAG.
1411 if MASK_FLAG is nonzero, the body is controlled by maskes in forall
1412 nest, otherwise, the body is not controlled by maskes.
1413 if NEST_FLAG is nonzero, generate loops for nested forall, otherwise,
1414 only generate loops for the current forall level. */
1417 gfc_trans_nested_forall_loop (forall_info
* nested_forall_info
, tree body
,
1418 int mask_flag
, int nest_flag
)
1422 forall_info
*forall_tmp
;
1423 tree pmask
, mask
, maskindex
;
1425 forall_tmp
= nested_forall_info
;
1426 /* Generate loops for nested forall. */
1429 while (forall_tmp
->next_nest
!= NULL
)
1430 forall_tmp
= forall_tmp
->next_nest
;
1431 while (forall_tmp
!= NULL
)
1433 /* Generate body with masks' control. */
1436 pmask
= forall_tmp
->pmask
;
1437 mask
= forall_tmp
->mask
;
1438 maskindex
= forall_tmp
->maskindex
;
1442 /* If a mask was specified make the assignment conditional. */
1444 tmp
= gfc_build_indirect_ref (mask
);
1447 tmp
= gfc_build_array_ref (tmp
, maskindex
);
1449 body
= build3_v (COND_EXPR
, tmp
, body
, build_empty_stmt ());
1452 nvar
= forall_tmp
->nvar
;
1453 body
= gfc_trans_forall_loop (forall_tmp
, nvar
, body
, mask_flag
);
1454 forall_tmp
= forall_tmp
->outer
;
1459 nvar
= forall_tmp
->nvar
;
1460 body
= gfc_trans_forall_loop (forall_tmp
, nvar
, body
, mask_flag
);
1467 /* Allocate data for holding a temporary array. Returns either a local
1468 temporary array or a pointer variable. */
1471 gfc_do_allocate (tree bytesize
, tree size
, tree
* pdata
, stmtblock_t
* pblock
,
1479 if (INTEGER_CST_P (size
))
1481 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
, size
,
1482 gfc_index_one_node
);
1487 type
= build_range_type (gfc_array_index_type
, gfc_index_zero_node
, tmp
);
1488 type
= build_array_type (elem_type
, type
);
1489 if (gfc_can_put_var_on_stack (bytesize
))
1491 gcc_assert (INTEGER_CST_P (size
));
1492 tmpvar
= gfc_create_var (type
, "temp");
1497 tmpvar
= gfc_create_var (build_pointer_type (type
), "temp");
1498 *pdata
= convert (pvoid_type_node
, tmpvar
);
1500 args
= gfc_chainon_list (NULL_TREE
, bytesize
);
1501 if (gfc_index_integer_kind
== 4)
1502 tmp
= gfor_fndecl_internal_malloc
;
1503 else if (gfc_index_integer_kind
== 8)
1504 tmp
= gfor_fndecl_internal_malloc64
;
1507 tmp
= gfc_build_function_call (tmp
, args
);
1508 tmp
= convert (TREE_TYPE (tmpvar
), tmp
);
1509 gfc_add_modify_expr (pblock
, tmpvar
, tmp
);
1515 /* Generate codes to copy the temporary to the actual lhs. */
1518 generate_loop_for_temp_to_lhs (gfc_expr
*expr
, tree tmp1
, tree count3
,
1519 tree count1
, tree wheremask
)
1523 stmtblock_t block
, body
;
1529 lss
= gfc_walk_expr (expr
);
1531 if (lss
== gfc_ss_terminator
)
1533 gfc_start_block (&block
);
1535 gfc_init_se (&lse
, NULL
);
1537 /* Translate the expression. */
1538 gfc_conv_expr (&lse
, expr
);
1540 /* Form the expression for the temporary. */
1541 tmp
= gfc_build_array_ref (tmp1
, count1
);
1543 /* Use the scalar assignment as is. */
1544 gfc_add_block_to_block (&block
, &lse
.pre
);
1545 gfc_add_modify_expr (&block
, lse
.expr
, tmp
);
1546 gfc_add_block_to_block (&block
, &lse
.post
);
1548 /* Increment the count1. */
1549 tmp
= fold_build2 (PLUS_EXPR
, TREE_TYPE (count1
), count1
,
1550 gfc_index_one_node
);
1551 gfc_add_modify_expr (&block
, count1
, tmp
);
1553 tmp
= gfc_finish_block (&block
);
1557 gfc_start_block (&block
);
1559 gfc_init_loopinfo (&loop1
);
1560 gfc_init_se (&rse
, NULL
);
1561 gfc_init_se (&lse
, NULL
);
1563 /* Associate the lss with the loop. */
1564 gfc_add_ss_to_loop (&loop1
, lss
);
1566 /* Calculate the bounds of the scalarization. */
1567 gfc_conv_ss_startstride (&loop1
);
1568 /* Setup the scalarizing loops. */
1569 gfc_conv_loop_setup (&loop1
);
1571 gfc_mark_ss_chain_used (lss
, 1);
1573 /* Start the scalarized loop body. */
1574 gfc_start_scalarized_body (&loop1
, &body
);
1576 /* Setup the gfc_se structures. */
1577 gfc_copy_loopinfo_to_se (&lse
, &loop1
);
1580 /* Form the expression of the temporary. */
1581 if (lss
!= gfc_ss_terminator
)
1582 rse
.expr
= gfc_build_array_ref (tmp1
, count1
);
1583 /* Translate expr. */
1584 gfc_conv_expr (&lse
, expr
);
1586 /* Use the scalar assignment. */
1587 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
.type
);
1589 /* Form the mask expression according to the mask tree list. */
1592 wheremaskexpr
= gfc_build_array_ref (wheremask
, count3
);
1593 tmp2
= TREE_CHAIN (wheremask
);
1596 tmp1
= gfc_build_array_ref (tmp2
, count3
);
1597 wheremaskexpr
= build2 (TRUTH_AND_EXPR
, TREE_TYPE (tmp1
),
1598 wheremaskexpr
, tmp1
);
1599 tmp2
= TREE_CHAIN (tmp2
);
1601 tmp
= build3_v (COND_EXPR
, wheremaskexpr
, tmp
, build_empty_stmt ());
1604 gfc_add_expr_to_block (&body
, tmp
);
1606 /* Increment count1. */
1607 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
1608 count1
, gfc_index_one_node
);
1609 gfc_add_modify_expr (&body
, count1
, tmp
);
1611 /* Increment count3. */
1614 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
1615 count3
, gfc_index_one_node
);
1616 gfc_add_modify_expr (&body
, count3
, tmp
);
1619 /* Generate the copying loops. */
1620 gfc_trans_scalarizing_loops (&loop1
, &body
);
1621 gfc_add_block_to_block (&block
, &loop1
.pre
);
1622 gfc_add_block_to_block (&block
, &loop1
.post
);
1623 gfc_cleanup_loop (&loop1
);
1625 tmp
= gfc_finish_block (&block
);
1631 /* Generate codes to copy rhs to the temporary. TMP1 is the address of temporary
1632 LSS and RSS are formed in function compute_inner_temp_size(), and should
1636 generate_loop_for_rhs_to_temp (gfc_expr
*expr2
, tree tmp1
, tree count3
,
1637 tree count1
, gfc_ss
*lss
, gfc_ss
*rss
,
1640 stmtblock_t block
, body1
;
1647 gfc_start_block (&block
);
1649 gfc_init_se (&rse
, NULL
);
1650 gfc_init_se (&lse
, NULL
);
1652 if (lss
== gfc_ss_terminator
)
1654 gfc_init_block (&body1
);
1655 gfc_conv_expr (&rse
, expr2
);
1656 lse
.expr
= gfc_build_array_ref (tmp1
, count1
);
1660 /* Initialize the loop. */
1661 gfc_init_loopinfo (&loop
);
1663 /* We may need LSS to determine the shape of the expression. */
1664 gfc_add_ss_to_loop (&loop
, lss
);
1665 gfc_add_ss_to_loop (&loop
, rss
);
1667 gfc_conv_ss_startstride (&loop
);
1668 gfc_conv_loop_setup (&loop
);
1670 gfc_mark_ss_chain_used (rss
, 1);
1671 /* Start the loop body. */
1672 gfc_start_scalarized_body (&loop
, &body1
);
1674 /* Translate the expression. */
1675 gfc_copy_loopinfo_to_se (&rse
, &loop
);
1677 gfc_conv_expr (&rse
, expr2
);
1679 /* Form the expression of the temporary. */
1680 lse
.expr
= gfc_build_array_ref (tmp1
, count1
);
1683 /* Use the scalar assignment. */
1684 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr2
->ts
.type
);
1686 /* Form the mask expression according to the mask tree list. */
1689 wheremaskexpr
= gfc_build_array_ref (wheremask
, count3
);
1690 tmp2
= TREE_CHAIN (wheremask
);
1693 tmp1
= gfc_build_array_ref (tmp2
, count3
);
1694 wheremaskexpr
= build2 (TRUTH_AND_EXPR
, TREE_TYPE (tmp1
),
1695 wheremaskexpr
, tmp1
);
1696 tmp2
= TREE_CHAIN (tmp2
);
1698 tmp
= build3_v (COND_EXPR
, wheremaskexpr
, tmp
, build_empty_stmt ());
1701 gfc_add_expr_to_block (&body1
, tmp
);
1703 if (lss
== gfc_ss_terminator
)
1705 gfc_add_block_to_block (&block
, &body1
);
1707 /* Increment count1. */
1708 tmp
= fold_build2 (PLUS_EXPR
, TREE_TYPE (count1
), count1
,
1709 gfc_index_one_node
);
1710 gfc_add_modify_expr (&block
, count1
, tmp
);
1714 /* Increment count1. */
1715 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
1716 count1
, gfc_index_one_node
);
1717 gfc_add_modify_expr (&body1
, count1
, tmp
);
1719 /* Increment count3. */
1722 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
1723 count3
, gfc_index_one_node
);
1724 gfc_add_modify_expr (&body1
, count3
, tmp
);
1727 /* Generate the copying loops. */
1728 gfc_trans_scalarizing_loops (&loop
, &body1
);
1730 gfc_add_block_to_block (&block
, &loop
.pre
);
1731 gfc_add_block_to_block (&block
, &loop
.post
);
1733 gfc_cleanup_loop (&loop
);
1734 /* TODO: Reuse lss and rss when copying temp->lhs. Need to be careful
1735 as tree nodes in SS may not be valid in different scope. */
1738 tmp
= gfc_finish_block (&block
);
1743 /* Calculate the size of temporary needed in the assignment inside forall.
1744 LSS and RSS are filled in this function. */
1747 compute_inner_temp_size (gfc_expr
*expr1
, gfc_expr
*expr2
,
1748 stmtblock_t
* pblock
,
1749 gfc_ss
**lss
, gfc_ss
**rss
)
1756 *lss
= gfc_walk_expr (expr1
);
1759 size
= gfc_index_one_node
;
1760 if (*lss
!= gfc_ss_terminator
)
1762 gfc_init_loopinfo (&loop
);
1764 /* Walk the RHS of the expression. */
1765 *rss
= gfc_walk_expr (expr2
);
1766 if (*rss
== gfc_ss_terminator
)
1768 /* The rhs is scalar. Add a ss for the expression. */
1769 *rss
= gfc_get_ss ();
1770 (*rss
)->next
= gfc_ss_terminator
;
1771 (*rss
)->type
= GFC_SS_SCALAR
;
1772 (*rss
)->expr
= expr2
;
1775 /* Associate the SS with the loop. */
1776 gfc_add_ss_to_loop (&loop
, *lss
);
1777 /* We don't actually need to add the rhs at this point, but it might
1778 make guessing the loop bounds a bit easier. */
1779 gfc_add_ss_to_loop (&loop
, *rss
);
1781 /* We only want the shape of the expression, not rest of the junk
1782 generated by the scalarizer. */
1783 loop
.array_parameter
= 1;
1785 /* Calculate the bounds of the scalarization. */
1786 gfc_conv_ss_startstride (&loop
);
1787 gfc_conv_loop_setup (&loop
);
1789 /* Figure out how many elements we need. */
1790 for (i
= 0; i
< loop
.dimen
; i
++)
1792 tmp
= fold_build2 (MINUS_EXPR
, gfc_array_index_type
,
1793 gfc_index_one_node
, loop
.from
[i
]);
1794 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
1796 size
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, size
, tmp
);
1798 gfc_add_block_to_block (pblock
, &loop
.pre
);
1799 size
= gfc_evaluate_now (size
, pblock
);
1800 gfc_add_block_to_block (pblock
, &loop
.post
);
1802 /* TODO: write a function that cleans up a loopinfo without freeing
1803 the SS chains. Currently a NOP. */
1810 /* Calculate the overall iterator number of the nested forall construct. */
1813 compute_overall_iter_number (forall_info
*nested_forall_info
, tree inner_size
,
1814 stmtblock_t
*inner_size_body
, stmtblock_t
*block
)
1819 /* TODO: optimizing the computing process. */
1820 number
= gfc_create_var (gfc_array_index_type
, "num");
1821 gfc_add_modify_expr (block
, number
, gfc_index_zero_node
);
1823 gfc_start_block (&body
);
1824 if (inner_size_body
)
1825 gfc_add_block_to_block (&body
, inner_size_body
);
1826 if (nested_forall_info
)
1827 tmp
= build2 (PLUS_EXPR
, gfc_array_index_type
, number
,
1831 gfc_add_modify_expr (&body
, number
, tmp
);
1832 tmp
= gfc_finish_block (&body
);
1834 /* Generate loops. */
1835 if (nested_forall_info
!= NULL
)
1836 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, tmp
, 0, 1);
1838 gfc_add_expr_to_block (block
, tmp
);
1844 /* Allocate temporary for forall construct. SIZE is the size of temporary
1845 needed. PTEMP1 is returned for space free. */
1848 allocate_temp_for_forall_nest_1 (tree type
, tree size
, stmtblock_t
* block
,
1856 unit
= TYPE_SIZE_UNIT (type
);
1857 bytesize
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, size
, unit
);
1860 temp1
= gfc_do_allocate (bytesize
, size
, ptemp1
, block
, type
);
1863 tmp
= gfc_build_indirect_ref (temp1
);
1871 /* Allocate temporary for forall construct according to the information in
1872 nested_forall_info. INNER_SIZE is the size of temporary needed in the
1873 assignment inside forall. PTEMP1 is returned for space free. */
1876 allocate_temp_for_forall_nest (forall_info
* nested_forall_info
, tree type
,
1877 tree inner_size
, stmtblock_t
* inner_size_body
,
1878 stmtblock_t
* block
, tree
* ptemp1
)
1882 /* Calculate the total size of temporary needed in forall construct. */
1883 size
= compute_overall_iter_number (nested_forall_info
, inner_size
,
1884 inner_size_body
, block
);
1886 return allocate_temp_for_forall_nest_1 (type
, size
, block
, ptemp1
);
1890 /* Handle assignments inside forall which need temporary.
1892 forall (i=start:end:stride; maskexpr)
1895 (where e,f<i> are arbitrary expressions possibly involving i
1896 and there is a dependency between e<i> and f<i>)
1898 masktmp(:) = maskexpr(:)
1903 for (i = start; i <= end; i += stride)
1907 for (i = start; i <= end; i += stride)
1909 if (masktmp[maskindex++])
1910 tmp[count1++] = f<i>
1914 for (i = start; i <= end; i += stride)
1916 if (masktmp[maskindex++])
1917 e<i> = tmp[count1++]
1922 gfc_trans_assign_need_temp (gfc_expr
* expr1
, gfc_expr
* expr2
, tree wheremask
,
1923 forall_info
* nested_forall_info
,
1924 stmtblock_t
* block
)
1932 tree mask
, maskindex
;
1933 forall_info
*forall_tmp
;
1934 stmtblock_t inner_size_body
;
1936 /* Create vars. count1 is the current iterator number of the nested
1938 count1
= gfc_create_var (gfc_array_index_type
, "count1");
1940 /* Count is the wheremask index. */
1943 count
= gfc_create_var (gfc_array_index_type
, "count");
1944 gfc_add_modify_expr (block
, count
, gfc_index_zero_node
);
1949 /* Initialize count1. */
1950 gfc_add_modify_expr (block
, count1
, gfc_index_zero_node
);
1952 /* Calculate the size of temporary needed in the assignment. Return loop, lss
1953 and rss which are used in function generate_loop_for_rhs_to_temp(). */
1954 gfc_init_block (&inner_size_body
);
1955 inner_size
= compute_inner_temp_size (expr1
, expr2
, &inner_size_body
,
1958 /* The type of LHS. Used in function allocate_temp_for_forall_nest */
1959 type
= gfc_typenode_for_spec (&expr1
->ts
);
1961 /* Allocate temporary for nested forall construct according to the
1962 information in nested_forall_info and inner_size. */
1963 tmp1
= allocate_temp_for_forall_nest (nested_forall_info
, type
, inner_size
,
1964 &inner_size_body
, block
, &ptemp1
);
1966 /* Initialize the maskindexes. */
1967 forall_tmp
= nested_forall_info
;
1968 while (forall_tmp
!= NULL
)
1970 mask
= forall_tmp
->mask
;
1971 maskindex
= forall_tmp
->maskindex
;
1973 gfc_add_modify_expr (block
, maskindex
, gfc_index_zero_node
);
1974 forall_tmp
= forall_tmp
->next_nest
;
1977 /* Generate codes to copy rhs to the temporary . */
1978 tmp
= generate_loop_for_rhs_to_temp (expr2
, tmp1
, count
, count1
, lss
, rss
,
1981 /* Generate body and loops according to the information in
1982 nested_forall_info. */
1983 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, tmp
, 1, 1);
1984 gfc_add_expr_to_block (block
, tmp
);
1987 gfc_add_modify_expr (block
, count1
, gfc_index_zero_node
);
1989 /* Reset maskindexed. */
1990 forall_tmp
= nested_forall_info
;
1991 while (forall_tmp
!= NULL
)
1993 mask
= forall_tmp
->mask
;
1994 maskindex
= forall_tmp
->maskindex
;
1996 gfc_add_modify_expr (block
, maskindex
, gfc_index_zero_node
);
1997 forall_tmp
= forall_tmp
->next_nest
;
2002 gfc_add_modify_expr (block
, count
, gfc_index_zero_node
);
2004 /* Generate codes to copy the temporary to lhs. */
2005 tmp
= generate_loop_for_temp_to_lhs (expr1
, tmp1
, count
, count1
, wheremask
);
2007 /* Generate body and loops according to the information in
2008 nested_forall_info. */
2009 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, tmp
, 1, 1);
2010 gfc_add_expr_to_block (block
, tmp
);
2014 /* Free the temporary. */
2015 tmp
= gfc_chainon_list (NULL_TREE
, ptemp1
);
2016 tmp
= gfc_build_function_call (gfor_fndecl_internal_free
, tmp
);
2017 gfc_add_expr_to_block (block
, tmp
);
2022 /* Translate pointer assignment inside FORALL which need temporary. */
2025 gfc_trans_pointer_assign_need_temp (gfc_expr
* expr1
, gfc_expr
* expr2
,
2026 forall_info
* nested_forall_info
,
2027 stmtblock_t
* block
)
2041 tree tmp
, tmp1
, ptemp1
;
2042 tree mask
, maskindex
;
2043 forall_info
*forall_tmp
;
2045 count
= gfc_create_var (gfc_array_index_type
, "count");
2046 gfc_add_modify_expr (block
, count
, gfc_index_zero_node
);
2048 inner_size
= integer_one_node
;
2049 lss
= gfc_walk_expr (expr1
);
2050 rss
= gfc_walk_expr (expr2
);
2051 if (lss
== gfc_ss_terminator
)
2053 type
= gfc_typenode_for_spec (&expr1
->ts
);
2054 type
= build_pointer_type (type
);
2056 /* Allocate temporary for nested forall construct according to the
2057 information in nested_forall_info and inner_size. */
2058 tmp1
= allocate_temp_for_forall_nest (nested_forall_info
, type
,
2059 inner_size
, NULL
, block
, &ptemp1
);
2060 gfc_start_block (&body
);
2061 gfc_init_se (&lse
, NULL
);
2062 lse
.expr
= gfc_build_array_ref (tmp1
, count
);
2063 gfc_init_se (&rse
, NULL
);
2064 rse
.want_pointer
= 1;
2065 gfc_conv_expr (&rse
, expr2
);
2066 gfc_add_block_to_block (&body
, &rse
.pre
);
2067 gfc_add_modify_expr (&body
, lse
.expr
, rse
.expr
);
2068 gfc_add_block_to_block (&body
, &rse
.post
);
2070 /* Increment count. */
2071 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
2072 count
, gfc_index_one_node
);
2073 gfc_add_modify_expr (&body
, count
, tmp
);
2075 tmp
= gfc_finish_block (&body
);
2077 /* Initialize the maskindexes. */
2078 forall_tmp
= nested_forall_info
;
2079 while (forall_tmp
!= NULL
)
2081 mask
= forall_tmp
->mask
;
2082 maskindex
= forall_tmp
->maskindex
;
2084 gfc_add_modify_expr (block
, maskindex
, gfc_index_zero_node
);
2085 forall_tmp
= forall_tmp
->next_nest
;
2088 /* Generate body and loops according to the information in
2089 nested_forall_info. */
2090 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, tmp
, 1, 1);
2091 gfc_add_expr_to_block (block
, tmp
);
2094 gfc_add_modify_expr (block
, count
, gfc_index_zero_node
);
2096 /* Reset maskindexes. */
2097 forall_tmp
= nested_forall_info
;
2098 while (forall_tmp
!= NULL
)
2100 mask
= forall_tmp
->mask
;
2101 maskindex
= forall_tmp
->maskindex
;
2103 gfc_add_modify_expr (block
, maskindex
, gfc_index_zero_node
);
2104 forall_tmp
= forall_tmp
->next_nest
;
2106 gfc_start_block (&body
);
2107 gfc_init_se (&lse
, NULL
);
2108 gfc_init_se (&rse
, NULL
);
2109 rse
.expr
= gfc_build_array_ref (tmp1
, count
);
2110 lse
.want_pointer
= 1;
2111 gfc_conv_expr (&lse
, expr1
);
2112 gfc_add_block_to_block (&body
, &lse
.pre
);
2113 gfc_add_modify_expr (&body
, lse
.expr
, rse
.expr
);
2114 gfc_add_block_to_block (&body
, &lse
.post
);
2115 /* Increment count. */
2116 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
2117 count
, gfc_index_one_node
);
2118 gfc_add_modify_expr (&body
, count
, tmp
);
2119 tmp
= gfc_finish_block (&body
);
2121 /* Generate body and loops according to the information in
2122 nested_forall_info. */
2123 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, tmp
, 1, 1);
2124 gfc_add_expr_to_block (block
, tmp
);
2128 gfc_init_loopinfo (&loop
);
2130 /* Associate the SS with the loop. */
2131 gfc_add_ss_to_loop (&loop
, rss
);
2133 /* Setup the scalarizing loops and bounds. */
2134 gfc_conv_ss_startstride (&loop
);
2136 gfc_conv_loop_setup (&loop
);
2138 info
= &rss
->data
.info
;
2139 desc
= info
->descriptor
;
2141 /* Make a new descriptor. */
2142 parmtype
= gfc_get_element_type (TREE_TYPE (desc
));
2143 parmtype
= gfc_get_array_type_bounds (parmtype
, loop
.dimen
,
2144 loop
.from
, loop
.to
, 1);
2146 /* Allocate temporary for nested forall construct. */
2147 tmp1
= allocate_temp_for_forall_nest (nested_forall_info
, parmtype
,
2148 inner_size
, NULL
, block
, &ptemp1
);
2149 gfc_start_block (&body
);
2150 gfc_init_se (&lse
, NULL
);
2151 lse
.expr
= gfc_build_array_ref (tmp1
, count
);
2152 lse
.direct_byref
= 1;
2153 rss
= gfc_walk_expr (expr2
);
2154 gfc_conv_expr_descriptor (&lse
, expr2
, rss
);
2156 gfc_add_block_to_block (&body
, &lse
.pre
);
2157 gfc_add_block_to_block (&body
, &lse
.post
);
2159 /* Increment count. */
2160 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
2161 count
, gfc_index_one_node
);
2162 gfc_add_modify_expr (&body
, count
, tmp
);
2164 tmp
= gfc_finish_block (&body
);
2166 /* Initialize the maskindexes. */
2167 forall_tmp
= nested_forall_info
;
2168 while (forall_tmp
!= NULL
)
2170 mask
= forall_tmp
->mask
;
2171 maskindex
= forall_tmp
->maskindex
;
2173 gfc_add_modify_expr (block
, maskindex
, gfc_index_zero_node
);
2174 forall_tmp
= forall_tmp
->next_nest
;
2177 /* Generate body and loops according to the information in
2178 nested_forall_info. */
2179 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, tmp
, 1, 1);
2180 gfc_add_expr_to_block (block
, tmp
);
2183 gfc_add_modify_expr (block
, count
, gfc_index_zero_node
);
2185 /* Reset maskindexes. */
2186 forall_tmp
= nested_forall_info
;
2187 while (forall_tmp
!= NULL
)
2189 mask
= forall_tmp
->mask
;
2190 maskindex
= forall_tmp
->maskindex
;
2192 gfc_add_modify_expr (block
, maskindex
, gfc_index_zero_node
);
2193 forall_tmp
= forall_tmp
->next_nest
;
2195 parm
= gfc_build_array_ref (tmp1
, count
);
2196 lss
= gfc_walk_expr (expr1
);
2197 gfc_init_se (&lse
, NULL
);
2198 gfc_conv_expr_descriptor (&lse
, expr1
, lss
);
2199 gfc_add_modify_expr (&lse
.pre
, lse
.expr
, parm
);
2200 gfc_start_block (&body
);
2201 gfc_add_block_to_block (&body
, &lse
.pre
);
2202 gfc_add_block_to_block (&body
, &lse
.post
);
2204 /* Increment count. */
2205 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
2206 count
, gfc_index_one_node
);
2207 gfc_add_modify_expr (&body
, count
, tmp
);
2209 tmp
= gfc_finish_block (&body
);
2211 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, tmp
, 1, 1);
2212 gfc_add_expr_to_block (block
, tmp
);
2214 /* Free the temporary. */
2217 tmp
= gfc_chainon_list (NULL_TREE
, ptemp1
);
2218 tmp
= gfc_build_function_call (gfor_fndecl_internal_free
, tmp
);
2219 gfc_add_expr_to_block (block
, tmp
);
2224 /* FORALL and WHERE statements are really nasty, especially when you nest
2225 them. All the rhs of a forall assignment must be evaluated before the
2226 actual assignments are performed. Presumably this also applies to all the
2227 assignments in an inner where statement. */
2229 /* Generate code for a FORALL statement. Any temporaries are allocated as a
2230 linear array, relying on the fact that we process in the same order in all
2233 forall (i=start:end:stride; maskexpr)
2237 (where e,f,g,h<i> are arbitrary expressions possibly involving i)
2239 count = ((end + 1 - start) / stride)
2240 masktmp(:) = maskexpr(:)
2243 for (i = start; i <= end; i += stride)
2245 if (masktmp[maskindex++])
2249 for (i = start; i <= end; i += stride)
2251 if (masktmp[maskindex++])
2255 Note that this code only works when there are no dependencies.
2256 Forall loop with array assignments and data dependencies are a real pain,
2257 because the size of the temporary cannot always be determined before the
2258 loop is executed. This problem is compounded by the presence of nested
2263 gfc_trans_forall_1 (gfc_code
* code
, forall_info
* nested_forall_info
)
2285 gfc_forall_iterator
*fa
;
2288 gfc_saved_var
*saved_vars
;
2289 iter_info
*this_forall
, *iter_tmp
;
2290 forall_info
*info
, *forall_tmp
;
2291 temporary_list
*temp
;
2293 gfc_start_block (&block
);
2296 /* Count the FORALL index number. */
2297 for (fa
= code
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
2301 /* Allocate the space for var, start, end, step, varexpr. */
2302 var
= (tree
*) gfc_getmem (nvar
* sizeof (tree
));
2303 start
= (tree
*) gfc_getmem (nvar
* sizeof (tree
));
2304 end
= (tree
*) gfc_getmem (nvar
* sizeof (tree
));
2305 step
= (tree
*) gfc_getmem (nvar
* sizeof (tree
));
2306 varexpr
= (gfc_expr
**) gfc_getmem (nvar
* sizeof (gfc_expr
*));
2307 saved_vars
= (gfc_saved_var
*) gfc_getmem (nvar
* sizeof (gfc_saved_var
));
2309 /* Allocate the space for info. */
2310 info
= (forall_info
*) gfc_getmem (sizeof (forall_info
));
2312 for (fa
= code
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
2314 gfc_symbol
*sym
= fa
->var
->symtree
->n
.sym
;
2316 /* allocate space for this_forall. */
2317 this_forall
= (iter_info
*) gfc_getmem (sizeof (iter_info
));
2319 /* Create a temporary variable for the FORALL index. */
2320 tmp
= gfc_typenode_for_spec (&sym
->ts
);
2321 var
[n
] = gfc_create_var (tmp
, sym
->name
);
2322 gfc_shadow_sym (sym
, var
[n
], &saved_vars
[n
]);
2324 /* Record it in this_forall. */
2325 this_forall
->var
= var
[n
];
2327 /* Replace the index symbol's backend_decl with the temporary decl. */
2328 sym
->backend_decl
= var
[n
];
2330 /* Work out the start, end and stride for the loop. */
2331 gfc_init_se (&se
, NULL
);
2332 gfc_conv_expr_val (&se
, fa
->start
);
2333 /* Record it in this_forall. */
2334 this_forall
->start
= se
.expr
;
2335 gfc_add_block_to_block (&block
, &se
.pre
);
2338 gfc_init_se (&se
, NULL
);
2339 gfc_conv_expr_val (&se
, fa
->end
);
2340 /* Record it in this_forall. */
2341 this_forall
->end
= se
.expr
;
2342 gfc_make_safe_expr (&se
);
2343 gfc_add_block_to_block (&block
, &se
.pre
);
2346 gfc_init_se (&se
, NULL
);
2347 gfc_conv_expr_val (&se
, fa
->stride
);
2348 /* Record it in this_forall. */
2349 this_forall
->step
= se
.expr
;
2350 gfc_make_safe_expr (&se
);
2351 gfc_add_block_to_block (&block
, &se
.pre
);
2354 /* Set the NEXT field of this_forall to NULL. */
2355 this_forall
->next
= NULL
;
2356 /* Link this_forall to the info construct. */
2357 if (info
->this_loop
== NULL
)
2358 info
->this_loop
= this_forall
;
2361 iter_tmp
= info
->this_loop
;
2362 while (iter_tmp
->next
!= NULL
)
2363 iter_tmp
= iter_tmp
->next
;
2364 iter_tmp
->next
= this_forall
;
2371 /* Work out the number of elements in the mask array. */
2374 size
= gfc_index_one_node
;
2375 sizevar
= NULL_TREE
;
2377 for (n
= 0; n
< nvar
; n
++)
2379 if (lenvar
&& TREE_TYPE (lenvar
) != TREE_TYPE (start
[n
]))
2382 /* size = (end + step - start) / step. */
2383 tmp
= fold_build2 (MINUS_EXPR
, TREE_TYPE (start
[n
]),
2385 tmp
= fold_build2 (PLUS_EXPR
, TREE_TYPE (end
[n
]), end
[n
], tmp
);
2387 tmp
= fold_build2 (FLOOR_DIV_EXPR
, TREE_TYPE (tmp
), tmp
, step
[n
]);
2388 tmp
= convert (gfc_array_index_type
, tmp
);
2390 size
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, size
, tmp
);
2393 /* Record the nvar and size of current forall level. */
2397 /* Link the current forall level to nested_forall_info. */
2398 forall_tmp
= nested_forall_info
;
2399 if (forall_tmp
== NULL
)
2400 nested_forall_info
= info
;
2403 while (forall_tmp
->next_nest
!= NULL
)
2404 forall_tmp
= forall_tmp
->next_nest
;
2405 info
->outer
= forall_tmp
;
2406 forall_tmp
->next_nest
= info
;
2409 /* Copy the mask into a temporary variable if required.
2410 For now we assume a mask temporary is needed. */
2413 /* Allocate the mask temporary. */
2414 bytesize
= fold_build2 (MULT_EXPR
, gfc_array_index_type
, size
,
2415 TYPE_SIZE_UNIT (boolean_type_node
));
2417 mask
= gfc_do_allocate (bytesize
, size
, &pmask
, &block
, boolean_type_node
);
2419 maskindex
= gfc_create_var_np (gfc_array_index_type
, "mi");
2420 /* Record them in the info structure. */
2421 info
->pmask
= pmask
;
2423 info
->maskindex
= maskindex
;
2425 gfc_add_modify_expr (&block
, maskindex
, gfc_index_zero_node
);
2427 /* Start of mask assignment loop body. */
2428 gfc_start_block (&body
);
2430 /* Evaluate the mask expression. */
2431 gfc_init_se (&se
, NULL
);
2432 gfc_conv_expr_val (&se
, code
->expr
);
2433 gfc_add_block_to_block (&body
, &se
.pre
);
2435 /* Store the mask. */
2436 se
.expr
= convert (boolean_type_node
, se
.expr
);
2439 tmp
= gfc_build_indirect_ref (mask
);
2442 tmp
= gfc_build_array_ref (tmp
, maskindex
);
2443 gfc_add_modify_expr (&body
, tmp
, se
.expr
);
2445 /* Advance to the next mask element. */
2446 tmp
= build2 (PLUS_EXPR
, gfc_array_index_type
,
2447 maskindex
, gfc_index_one_node
);
2448 gfc_add_modify_expr (&body
, maskindex
, tmp
);
2450 /* Generate the loops. */
2451 tmp
= gfc_finish_block (&body
);
2452 tmp
= gfc_trans_nested_forall_loop (info
, tmp
, 0, 0);
2453 gfc_add_expr_to_block (&block
, tmp
);
2457 /* No mask was specified. */
2458 maskindex
= NULL_TREE
;
2459 mask
= pmask
= NULL_TREE
;
2462 c
= code
->block
->next
;
2464 /* TODO: loop merging in FORALL statements. */
2465 /* Now that we've got a copy of the mask, generate the assignment loops. */
2471 /* A scalar or array assignment. */
2472 need_temp
= gfc_check_dependency (c
->expr
, c
->expr2
, varexpr
, nvar
);
2473 /* Temporaries due to array assignment data dependencies introduce
2474 no end of problems. */
2476 gfc_trans_assign_need_temp (c
->expr
, c
->expr2
, NULL
,
2477 nested_forall_info
, &block
);
2480 /* Use the normal assignment copying routines. */
2481 assign
= gfc_trans_assignment (c
->expr
, c
->expr2
);
2483 /* Reset the mask index. */
2485 gfc_add_modify_expr (&block
, maskindex
, gfc_index_zero_node
);
2487 /* Generate body and loops. */
2488 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, assign
, 1, 1);
2489 gfc_add_expr_to_block (&block
, tmp
);
2496 /* Translate WHERE or WHERE construct nested in FORALL. */
2498 gfc_trans_where_2 (c
, NULL
, NULL
, nested_forall_info
, &block
, &temp
);
2505 /* Free the temporary. */
2506 args
= gfc_chainon_list (NULL_TREE
, temp
->temporary
);
2507 tmp
= gfc_build_function_call (gfor_fndecl_internal_free
, args
);
2508 gfc_add_expr_to_block (&block
, tmp
);
2517 /* Pointer assignment inside FORALL. */
2518 case EXEC_POINTER_ASSIGN
:
2519 need_temp
= gfc_check_dependency (c
->expr
, c
->expr2
, varexpr
, nvar
);
2521 gfc_trans_pointer_assign_need_temp (c
->expr
, c
->expr2
,
2522 nested_forall_info
, &block
);
2525 /* Use the normal assignment copying routines. */
2526 assign
= gfc_trans_pointer_assignment (c
->expr
, c
->expr2
);
2528 /* Reset the mask index. */
2530 gfc_add_modify_expr (&block
, maskindex
, gfc_index_zero_node
);
2532 /* Generate body and loops. */
2533 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, assign
,
2535 gfc_add_expr_to_block (&block
, tmp
);
2540 tmp
= gfc_trans_forall_1 (c
, nested_forall_info
);
2541 gfc_add_expr_to_block (&block
, tmp
);
2551 /* Restore the original index variables. */
2552 for (fa
= code
->ext
.forall_iterator
, n
= 0; fa
; fa
= fa
->next
, n
++)
2553 gfc_restore_sym (fa
->var
->symtree
->n
.sym
, &saved_vars
[n
]);
2555 /* Free the space for var, start, end, step, varexpr. */
2561 gfc_free (saved_vars
);
2565 /* Free the temporary for the mask. */
2566 tmp
= gfc_chainon_list (NULL_TREE
, pmask
);
2567 tmp
= gfc_build_function_call (gfor_fndecl_internal_free
, tmp
);
2568 gfc_add_expr_to_block (&block
, tmp
);
2571 pushdecl (maskindex
);
2573 return gfc_finish_block (&block
);
2577 /* Translate the FORALL statement or construct. */
2579 tree
gfc_trans_forall (gfc_code
* code
)
2581 return gfc_trans_forall_1 (code
, NULL
);
2585 /* Evaluate the WHERE mask expression, copy its value to a temporary.
2586 If the WHERE construct is nested in FORALL, compute the overall temporary
2587 needed by the WHERE mask expression multiplied by the iterator number of
2589 ME is the WHERE mask expression.
2590 MASK is the temporary which value is mask's value.
2591 NMASK is another temporary which value is !mask.
2592 TEMP records the temporary's address allocated in this function in order to
2593 free them outside this function.
2594 MASK, NMASK and TEMP are all OUT arguments. */
2597 gfc_evaluate_where_mask (gfc_expr
* me
, forall_info
* nested_forall_info
,
2598 tree
* mask
, tree
* nmask
, temporary_list
** temp
,
2599 stmtblock_t
* block
)
2604 tree ptemp1
, ntmp
, ptemp2
;
2605 tree inner_size
, size
;
2606 stmtblock_t body
, body1
, inner_size_body
;
2611 gfc_init_loopinfo (&loop
);
2613 /* Calculate the size of temporary needed by the mask-expr. */
2614 gfc_init_block (&inner_size_body
);
2615 inner_size
= compute_inner_temp_size (me
, me
, &inner_size_body
, &lss
, &rss
);
2617 /* Calculate the total size of temporary needed. */
2618 size
= compute_overall_iter_number (nested_forall_info
, inner_size
,
2619 &inner_size_body
, block
);
2621 /* Allocate temporary for where mask. */
2622 tmp
= allocate_temp_for_forall_nest_1 (boolean_type_node
, size
, block
,
2624 /* Record the temporary address in order to free it later. */
2627 temporary_list
*tempo
;
2628 tempo
= (temporary_list
*) gfc_getmem (sizeof (temporary_list
));
2629 tempo
->temporary
= ptemp1
;
2630 tempo
->next
= *temp
;
2634 /* Allocate temporary for !mask. */
2635 ntmp
= allocate_temp_for_forall_nest_1 (boolean_type_node
, size
, block
,
2637 /* Record the temporary in order to free it later. */
2640 temporary_list
*tempo
;
2641 tempo
= (temporary_list
*) gfc_getmem (sizeof (temporary_list
));
2642 tempo
->temporary
= ptemp2
;
2643 tempo
->next
= *temp
;
2647 /* Variable to index the temporary. */
2648 count
= gfc_create_var (gfc_array_index_type
, "count");
2649 /* Initialize count. */
2650 gfc_add_modify_expr (block
, count
, gfc_index_zero_node
);
2652 gfc_start_block (&body
);
2654 gfc_init_se (&rse
, NULL
);
2655 gfc_init_se (&lse
, NULL
);
2657 if (lss
== gfc_ss_terminator
)
2659 gfc_init_block (&body1
);
2663 /* Initialize the loop. */
2664 gfc_init_loopinfo (&loop
);
2666 /* We may need LSS to determine the shape of the expression. */
2667 gfc_add_ss_to_loop (&loop
, lss
);
2668 gfc_add_ss_to_loop (&loop
, rss
);
2670 gfc_conv_ss_startstride (&loop
);
2671 gfc_conv_loop_setup (&loop
);
2673 gfc_mark_ss_chain_used (rss
, 1);
2674 /* Start the loop body. */
2675 gfc_start_scalarized_body (&loop
, &body1
);
2677 /* Translate the expression. */
2678 gfc_copy_loopinfo_to_se (&rse
, &loop
);
2680 gfc_conv_expr (&rse
, me
);
2682 /* Form the expression of the temporary. */
2683 lse
.expr
= gfc_build_array_ref (tmp
, count
);
2684 tmpexpr
= gfc_build_array_ref (ntmp
, count
);
2686 /* Use the scalar assignment to fill temporary TMP. */
2687 tmp1
= gfc_trans_scalar_assign (&lse
, &rse
, me
->ts
.type
);
2688 gfc_add_expr_to_block (&body1
, tmp1
);
2690 /* Fill temporary NTMP. */
2691 tmp1
= build1 (TRUTH_NOT_EXPR
, TREE_TYPE (lse
.expr
), lse
.expr
);
2692 gfc_add_modify_expr (&body1
, tmpexpr
, tmp1
);
2694 if (lss
== gfc_ss_terminator
)
2696 gfc_add_block_to_block (&body
, &body1
);
2700 /* Increment count. */
2701 tmp1
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
, count
,
2702 gfc_index_one_node
);
2703 gfc_add_modify_expr (&body1
, count
, tmp1
);
2705 /* Generate the copying loops. */
2706 gfc_trans_scalarizing_loops (&loop
, &body1
);
2708 gfc_add_block_to_block (&body
, &loop
.pre
);
2709 gfc_add_block_to_block (&body
, &loop
.post
);
2711 gfc_cleanup_loop (&loop
);
2712 /* TODO: Reuse lss and rss when copying temp->lhs. Need to be careful
2713 as tree nodes in SS may not be valid in different scope. */
2716 tmp1
= gfc_finish_block (&body
);
2717 /* If the WHERE construct is inside FORALL, fill the full temporary. */
2718 if (nested_forall_info
!= NULL
)
2720 forall_info
*forall_tmp
;
2723 /* Initialize the maskindexes. */
2724 forall_tmp
= nested_forall_info
;
2725 while (forall_tmp
!= NULL
)
2727 maskindex
= forall_tmp
->maskindex
;
2728 if (forall_tmp
->mask
)
2729 gfc_add_modify_expr (block
, maskindex
, gfc_index_zero_node
);
2730 forall_tmp
= forall_tmp
->next_nest
;
2733 tmp1
= gfc_trans_nested_forall_loop (nested_forall_info
, tmp1
, 1, 1);
2736 gfc_add_expr_to_block (block
, tmp1
);
2745 /* Translate an assignment statement in a WHERE statement or construct
2746 statement. The MASK expression is used to control which elements
2747 of EXPR1 shall be assigned. */
2750 gfc_trans_where_assign (gfc_expr
*expr1
, gfc_expr
*expr2
, tree mask
,
2751 tree count1
, tree count2
)
2756 gfc_ss
*lss_section
;
2763 tree index
, maskexpr
, tmp1
;
2766 /* TODO: handle this special case.
2767 Special case a single function returning an array. */
2768 if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->rank
> 0)
2770 tmp
= gfc_trans_arrayfunc_assign (expr1
, expr2
);
2776 /* Assignment of the form lhs = rhs. */
2777 gfc_start_block (&block
);
2779 gfc_init_se (&lse
, NULL
);
2780 gfc_init_se (&rse
, NULL
);
2783 lss
= gfc_walk_expr (expr1
);
2786 /* In each where-assign-stmt, the mask-expr and the variable being
2787 defined shall be arrays of the same shape. */
2788 gcc_assert (lss
!= gfc_ss_terminator
);
2790 /* The assignment needs scalarization. */
2793 /* Find a non-scalar SS from the lhs. */
2794 while (lss_section
!= gfc_ss_terminator
2795 && lss_section
->type
!= GFC_SS_SECTION
)
2796 lss_section
= lss_section
->next
;
2798 gcc_assert (lss_section
!= gfc_ss_terminator
);
2800 /* Initialize the scalarizer. */
2801 gfc_init_loopinfo (&loop
);
2804 rss
= gfc_walk_expr (expr2
);
2805 if (rss
== gfc_ss_terminator
)
2807 /* The rhs is scalar. Add a ss for the expression. */
2808 rss
= gfc_get_ss ();
2809 rss
->next
= gfc_ss_terminator
;
2810 rss
->type
= GFC_SS_SCALAR
;
2814 /* Associate the SS with the loop. */
2815 gfc_add_ss_to_loop (&loop
, lss
);
2816 gfc_add_ss_to_loop (&loop
, rss
);
2818 /* Calculate the bounds of the scalarization. */
2819 gfc_conv_ss_startstride (&loop
);
2821 /* Resolve any data dependencies in the statement. */
2822 gfc_conv_resolve_dependencies (&loop
, lss_section
, rss
);
2824 /* Setup the scalarizing loops. */
2825 gfc_conv_loop_setup (&loop
);
2827 /* Setup the gfc_se structures. */
2828 gfc_copy_loopinfo_to_se (&lse
, &loop
);
2829 gfc_copy_loopinfo_to_se (&rse
, &loop
);
2832 gfc_mark_ss_chain_used (rss
, 1);
2833 if (loop
.temp_ss
== NULL
)
2836 gfc_mark_ss_chain_used (lss
, 1);
2840 lse
.ss
= loop
.temp_ss
;
2841 gfc_mark_ss_chain_used (lss
, 3);
2842 gfc_mark_ss_chain_used (loop
.temp_ss
, 3);
2845 /* Start the scalarized loop body. */
2846 gfc_start_scalarized_body (&loop
, &body
);
2848 /* Translate the expression. */
2849 gfc_conv_expr (&rse
, expr2
);
2850 if (lss
!= gfc_ss_terminator
&& loop
.temp_ss
!= NULL
)
2852 gfc_conv_tmp_array_ref (&lse
);
2853 gfc_advance_se_ss_chain (&lse
);
2856 gfc_conv_expr (&lse
, expr1
);
2858 /* Form the mask expression according to the mask tree list. */
2862 maskexpr
= gfc_build_array_ref (tmp
, index
);
2866 tmp
= TREE_CHAIN (tmp
);
2869 tmp1
= gfc_build_array_ref (tmp
, index
);
2870 maskexpr
= build2 (TRUTH_AND_EXPR
, TREE_TYPE (tmp1
), maskexpr
, tmp1
);
2871 tmp
= TREE_CHAIN (tmp
);
2873 /* Use the scalar assignment as is. */
2874 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
.type
);
2875 tmp
= build3_v (COND_EXPR
, maskexpr
, tmp
, build_empty_stmt ());
2877 gfc_add_expr_to_block (&body
, tmp
);
2879 if (lss
== gfc_ss_terminator
)
2881 /* Increment count1. */
2882 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
2883 count1
, gfc_index_one_node
);
2884 gfc_add_modify_expr (&body
, count1
, tmp
);
2886 /* Use the scalar assignment as is. */
2887 gfc_add_block_to_block (&block
, &body
);
2891 gcc_assert (lse
.ss
== gfc_ss_terminator
2892 && rse
.ss
== gfc_ss_terminator
);
2894 if (loop
.temp_ss
!= NULL
)
2896 /* Increment count1 before finish the main body of a scalarized
2898 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
2899 count1
, gfc_index_one_node
);
2900 gfc_add_modify_expr (&body
, count1
, tmp
);
2901 gfc_trans_scalarized_loop_boundary (&loop
, &body
);
2903 /* We need to copy the temporary to the actual lhs. */
2904 gfc_init_se (&lse
, NULL
);
2905 gfc_init_se (&rse
, NULL
);
2906 gfc_copy_loopinfo_to_se (&lse
, &loop
);
2907 gfc_copy_loopinfo_to_se (&rse
, &loop
);
2909 rse
.ss
= loop
.temp_ss
;
2912 gfc_conv_tmp_array_ref (&rse
);
2913 gfc_advance_se_ss_chain (&rse
);
2914 gfc_conv_expr (&lse
, expr1
);
2916 gcc_assert (lse
.ss
== gfc_ss_terminator
2917 && rse
.ss
== gfc_ss_terminator
);
2919 /* Form the mask expression according to the mask tree list. */
2923 maskexpr
= gfc_build_array_ref (tmp
, index
);
2927 tmp
= TREE_CHAIN (tmp
);
2930 tmp1
= gfc_build_array_ref (tmp
, index
);
2931 maskexpr
= build2 (TRUTH_AND_EXPR
, TREE_TYPE (tmp1
),
2933 tmp
= TREE_CHAIN (tmp
);
2935 /* Use the scalar assignment as is. */
2936 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
.type
);
2937 tmp
= build3_v (COND_EXPR
, maskexpr
, tmp
, build_empty_stmt ());
2938 gfc_add_expr_to_block (&body
, tmp
);
2940 /* Increment count2. */
2941 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
2942 count2
, gfc_index_one_node
);
2943 gfc_add_modify_expr (&body
, count2
, tmp
);
2947 /* Increment count1. */
2948 tmp
= fold_build2 (PLUS_EXPR
, gfc_array_index_type
,
2949 count1
, gfc_index_one_node
);
2950 gfc_add_modify_expr (&body
, count1
, tmp
);
2953 /* Generate the copying loops. */
2954 gfc_trans_scalarizing_loops (&loop
, &body
);
2956 /* Wrap the whole thing up. */
2957 gfc_add_block_to_block (&block
, &loop
.pre
);
2958 gfc_add_block_to_block (&block
, &loop
.post
);
2959 gfc_cleanup_loop (&loop
);
2962 return gfc_finish_block (&block
);
2966 /* Translate the WHERE construct or statement.
2967 This function can be called iteratively to translate the nested WHERE
2968 construct or statement.
2969 MASK is the control mask, and PMASK is the pending control mask.
2970 TEMP records the temporary address which must be freed later. */
2973 gfc_trans_where_2 (gfc_code
* code
, tree mask
, tree pmask
,
2974 forall_info
* nested_forall_info
, stmtblock_t
* block
,
2975 temporary_list
** temp
)
2981 tree tmp
, tmp1
, tmp2
;
2982 tree count1
, count2
;
2986 /* the WHERE statement or the WHERE construct statement. */
2987 cblock
= code
->block
;
2990 /* Has mask-expr. */
2993 /* Ensure that the WHERE mask be evaluated only once. */
2994 tmp2
= gfc_evaluate_where_mask (cblock
->expr
, nested_forall_info
,
2995 &tmp
, &tmp1
, temp
, block
);
2997 /* Set the control mask and the pending control mask. */
2998 /* It's a where-stmt. */
3004 /* It's a nested where-stmt. */
3005 else if (mask
&& pmask
== NULL
)
3008 /* Use the TREE_CHAIN to list the masks. */
3009 tmp2
= copy_list (mask
);
3010 pmask
= chainon (mask
, tmp1
);
3011 mask
= chainon (tmp2
, tmp
);
3013 /* It's a masked-elsewhere-stmt. */
3014 else if (mask
&& cblock
->expr
)
3017 tmp2
= copy_list (pmask
);
3020 tmp2
= chainon (tmp2
, tmp
);
3021 pmask
= chainon (mask
, tmp1
);
3025 /* It's a elsewhere-stmt. No mask-expr is present. */
3029 /* Get the assignment statement of a WHERE statement, or the first
3030 statement in where-body-construct of a WHERE construct. */
3031 cnext
= cblock
->next
;
3036 /* WHERE assignment statement. */
3038 expr1
= cnext
->expr
;
3039 expr2
= cnext
->expr2
;
3040 if (nested_forall_info
!= NULL
)
3045 nvar
= nested_forall_info
->nvar
;
3046 varexpr
= (gfc_expr
**)
3047 gfc_getmem (nvar
* sizeof (gfc_expr
*));
3048 need_temp
= gfc_check_dependency (expr1
, expr2
, varexpr
,
3051 gfc_trans_assign_need_temp (expr1
, expr2
, mask
,
3052 nested_forall_info
, block
);
3055 forall_info
*forall_tmp
;
3058 /* Variables to control maskexpr. */
3059 count1
= gfc_create_var (gfc_array_index_type
, "count1");
3060 count2
= gfc_create_var (gfc_array_index_type
, "count2");
3061 gfc_add_modify_expr (block
, count1
, gfc_index_zero_node
);
3062 gfc_add_modify_expr (block
, count2
, gfc_index_zero_node
);
3064 tmp
= gfc_trans_where_assign (expr1
, expr2
, mask
, count1
,
3067 /* Initialize the maskindexes. */
3068 forall_tmp
= nested_forall_info
;
3069 while (forall_tmp
!= NULL
)
3071 maskindex
= forall_tmp
->maskindex
;
3072 if (forall_tmp
->mask
)
3073 gfc_add_modify_expr (block
, maskindex
,
3074 gfc_index_zero_node
);
3075 forall_tmp
= forall_tmp
->next_nest
;
3078 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
,
3080 gfc_add_expr_to_block (block
, tmp
);
3085 /* Variables to control maskexpr. */
3086 count1
= gfc_create_var (gfc_array_index_type
, "count1");
3087 count2
= gfc_create_var (gfc_array_index_type
, "count2");
3088 gfc_add_modify_expr (block
, count1
, gfc_index_zero_node
);
3089 gfc_add_modify_expr (block
, count2
, gfc_index_zero_node
);
3091 tmp
= gfc_trans_where_assign (expr1
, expr2
, mask
, count1
,
3093 gfc_add_expr_to_block (block
, tmp
);
3098 /* WHERE or WHERE construct is part of a where-body-construct. */
3100 /* Ensure that MASK is not modified by next gfc_trans_where_2. */
3101 mask_copy
= copy_list (mask
);
3102 gfc_trans_where_2 (cnext
, mask_copy
, NULL
, nested_forall_info
,
3110 /* The next statement within the same where-body-construct. */
3111 cnext
= cnext
->next
;
3113 /* The next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt. */
3114 cblock
= cblock
->block
;
3119 /* As the WHERE or WHERE construct statement can be nested, we call
3120 gfc_trans_where_2 to do the translation, and pass the initial
3121 NULL values for both the control mask and the pending control mask. */
3124 gfc_trans_where (gfc_code
* code
)
3127 temporary_list
*temp
, *p
;
3131 gfc_start_block (&block
);
3134 gfc_trans_where_2 (code
, NULL
, NULL
, NULL
, &block
, &temp
);
3136 /* Add calls to free temporaries which were dynamically allocated. */
3139 args
= gfc_chainon_list (NULL_TREE
, temp
->temporary
);
3140 tmp
= gfc_build_function_call (gfor_fndecl_internal_free
, args
);
3141 gfc_add_expr_to_block (&block
, tmp
);
3147 return gfc_finish_block (&block
);
3151 /* CYCLE a DO loop. The label decl has already been created by
3152 gfc_trans_do(), it's in TREE_PURPOSE (backend_decl) of the gfc_code
3153 node at the head of the loop. We must mark the label as used. */
3156 gfc_trans_cycle (gfc_code
* code
)
3160 cycle_label
= TREE_PURPOSE (code
->ext
.whichloop
->backend_decl
);
3161 TREE_USED (cycle_label
) = 1;
3162 return build1_v (GOTO_EXPR
, cycle_label
);
3166 /* EXIT a DO loop. Similar to CYCLE, but now the label is in
3167 TREE_VALUE (backend_decl) of the gfc_code node at the head of the
3171 gfc_trans_exit (gfc_code
* code
)
3175 exit_label
= TREE_VALUE (code
->ext
.whichloop
->backend_decl
);
3176 TREE_USED (exit_label
) = 1;
3177 return build1_v (GOTO_EXPR
, exit_label
);
3181 /* Translate the ALLOCATE statement. */
3184 gfc_trans_allocate (gfc_code
* code
)
3197 if (!code
->ext
.alloc_list
)
3200 gfc_start_block (&block
);
3204 tree gfc_int4_type_node
= gfc_get_int_type (4);
3206 stat
= gfc_create_var (gfc_int4_type_node
, "stat");
3207 pstat
= gfc_build_addr_expr (NULL
, stat
);
3209 error_label
= gfc_build_label_decl (NULL_TREE
);
3210 TREE_USED (error_label
) = 1;
3214 pstat
= integer_zero_node
;
3215 stat
= error_label
= NULL_TREE
;
3219 for (al
= code
->ext
.alloc_list
; al
!= NULL
; al
= al
->next
)
3223 gfc_init_se (&se
, NULL
);
3224 gfc_start_block (&se
.pre
);
3226 se
.want_pointer
= 1;
3227 se
.descriptor_only
= 1;
3228 gfc_conv_expr (&se
, expr
);
3232 /* Find the last reference in the chain. */
3233 while (ref
&& ref
->next
!= NULL
)
3235 gcc_assert (ref
->type
!= REF_ARRAY
|| ref
->u
.ar
.type
== AR_ELEMENT
);
3239 if (ref
!= NULL
&& ref
->type
== REF_ARRAY
)
3242 gfc_array_allocate (&se
, ref
, pstat
);
3246 /* A scalar or derived type. */
3249 val
= gfc_create_var (ppvoid_type_node
, "ptr");
3250 tmp
= gfc_build_addr_expr (ppvoid_type_node
, se
.expr
);
3251 gfc_add_modify_expr (&se
.pre
, val
, tmp
);
3253 tmp
= TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (se
.expr
)));
3254 parm
= gfc_chainon_list (NULL_TREE
, val
);
3255 parm
= gfc_chainon_list (parm
, tmp
);
3256 parm
= gfc_chainon_list (parm
, pstat
);
3257 tmp
= gfc_build_function_call (gfor_fndecl_allocate
, parm
);
3258 gfc_add_expr_to_block (&se
.pre
, tmp
);
3262 tmp
= build1_v (GOTO_EXPR
, error_label
);
3264 build2 (NE_EXPR
, boolean_type_node
, stat
, integer_zero_node
);
3265 tmp
= build3_v (COND_EXPR
, parm
, tmp
, build_empty_stmt ());
3266 gfc_add_expr_to_block (&se
.pre
, tmp
);
3270 tmp
= gfc_finish_block (&se
.pre
);
3271 gfc_add_expr_to_block (&block
, tmp
);
3274 /* Assign the value to the status variable. */
3277 tmp
= build1_v (LABEL_EXPR
, error_label
);
3278 gfc_add_expr_to_block (&block
, tmp
);
3280 gfc_init_se (&se
, NULL
);
3281 gfc_conv_expr_lhs (&se
, code
->expr
);
3282 tmp
= convert (TREE_TYPE (se
.expr
), stat
);
3283 gfc_add_modify_expr (&block
, se
.expr
, tmp
);
3286 return gfc_finish_block (&block
);
3290 /* Translate a DEALLOCATE statement.
3291 There are two cases within the for loop:
3292 (1) deallocate(a1, a2, a3) is translated into the following sequence
3293 _gfortran_deallocate(a1, 0B)
3294 _gfortran_deallocate(a2, 0B)
3295 _gfortran_deallocate(a3, 0B)
3296 where the STAT= variable is passed a NULL pointer.
3297 (2) deallocate(a1, a2, a3, stat=i) is translated into the following
3299 _gfortran_deallocate(a1, &stat)
3300 astat = astat + stat
3301 _gfortran_deallocate(a2, &stat)
3302 astat = astat + stat
3303 _gfortran_deallocate(a3, &stat)
3304 astat = astat + stat
3305 In case (1), we simply return at the end of the for loop. In case (2)
3306 we set STAT= astat. */
3308 gfc_trans_deallocate (gfc_code
* code
)
3313 tree apstat
, astat
, parm
, pstat
, stat
, tmp
, type
, var
;
3316 gfc_start_block (&block
);
3318 /* Set up the optional STAT= */
3321 tree gfc_int4_type_node
= gfc_get_int_type (4);
3323 /* Variable used with the library call. */
3324 stat
= gfc_create_var (gfc_int4_type_node
, "stat");
3325 pstat
= gfc_build_addr_expr (NULL
, stat
);
3327 /* Running total of possible deallocation failures. */
3328 astat
= gfc_create_var (gfc_int4_type_node
, "astat");
3329 apstat
= gfc_build_addr_expr (NULL
, astat
);
3331 /* Initialize astat to 0. */
3332 gfc_add_modify_expr (&block
, astat
, build_int_cst (TREE_TYPE (astat
), 0));
3336 pstat
= apstat
= null_pointer_node
;
3337 stat
= astat
= NULL_TREE
;
3340 for (al
= code
->ext
.alloc_list
; al
!= NULL
; al
= al
->next
)
3343 gcc_assert (expr
->expr_type
== EXPR_VARIABLE
);
3345 gfc_init_se (&se
, NULL
);
3346 gfc_start_block (&se
.pre
);
3348 se
.want_pointer
= 1;
3349 se
.descriptor_only
= 1;
3350 gfc_conv_expr (&se
, expr
);
3352 if (expr
->symtree
->n
.sym
->attr
.dimension
)
3353 tmp
= gfc_array_deallocate (se
.expr
, pstat
);
3356 type
= build_pointer_type (TREE_TYPE (se
.expr
));
3357 var
= gfc_create_var (type
, "ptr");
3358 tmp
= gfc_build_addr_expr (type
, se
.expr
);
3359 gfc_add_modify_expr (&se
.pre
, var
, tmp
);
3361 parm
= gfc_chainon_list (NULL_TREE
, var
);
3362 parm
= gfc_chainon_list (parm
, pstat
);
3363 tmp
= gfc_build_function_call (gfor_fndecl_deallocate
, parm
);
3366 gfc_add_expr_to_block (&se
.pre
, tmp
);
3368 /* Keep track of the number of failed deallocations by adding stat
3369 of the last deallocation to the running total. */
3372 apstat
= build2 (PLUS_EXPR
, TREE_TYPE (stat
), astat
, stat
);
3373 gfc_add_modify_expr (&se
.pre
, astat
, apstat
);
3376 tmp
= gfc_finish_block (&se
.pre
);
3377 gfc_add_expr_to_block (&block
, tmp
);
3381 /* Assign the value to the status variable. */
3384 gfc_init_se (&se
, NULL
);
3385 gfc_conv_expr_lhs (&se
, code
->expr
);
3386 tmp
= convert (TREE_TYPE (se
.expr
), astat
);
3387 gfc_add_modify_expr (&block
, se
.expr
, tmp
);
3390 return gfc_finish_block (&block
);