1 /* Statement translation -- generate GCC trees from gfc_code.
2 Copyright (C) 2002, 2003, 2004 Free Software Foundation, Inc.
3 Contributed by Paul Brook <paul@nowt.org>
4 and Steven Bosscher <s.bosscher@student.tudelft.nl>
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 2, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING. If not, write to the Free
20 Software Foundation, 59 Temple Place - Suite 330, Boston, MA
26 #include "coretypes.h"
28 #include "tree-gimple.h"
36 #include "trans-stmt.h"
37 #include "trans-types.h"
38 #include "trans-array.h"
39 #include "trans-const.h"
42 int has_alternate_specifier
;
44 typedef struct iter_info
50 struct iter_info
*next
;
54 typedef struct temporary_list
57 struct temporary_list
*next
;
61 typedef struct forall_info
69 struct forall_info
*outer
;
70 struct forall_info
*next_nest
;
74 static void gfc_trans_where_2 (gfc_code
*, tree
, tree
, forall_info
*,
75 stmtblock_t
*, temporary_list
**temp
);
77 /* Translate a F95 label number to a LABEL_EXPR. */
80 gfc_trans_label_here (gfc_code
* code
)
82 return build1_v (LABEL_EXPR
, gfc_get_label_decl (code
->here
));
85 /* Translate a label assignment statement. */
87 gfc_trans_label_assign (gfc_code
* code
)
97 /* Start a new block. */
98 gfc_init_se (&se
, NULL
);
99 gfc_start_block (&se
.pre
);
100 gfc_conv_expr (&se
, code
->expr
);
101 len
= GFC_DECL_STRING_LEN (se
.expr
);
102 addr
= GFC_DECL_ASSIGN_ADDR (se
.expr
);
104 label_tree
= gfc_get_label_decl (code
->label
);
106 if (code
->label
->defined
== ST_LABEL_TARGET
)
108 label_tree
= gfc_build_addr_expr (pvoid_type_node
, label_tree
);
109 len_tree
= integer_minus_one_node
;
113 label_str
= code
->label
->format
->value
.character
.string
;
114 label_len
= code
->label
->format
->value
.character
.length
;
115 len_tree
= build_int_cst (NULL_TREE
, label_len
);
116 label_tree
= gfc_build_string_const (label_len
+ 1, label_str
);
117 label_tree
= gfc_build_addr_expr (pchar_type_node
, label_tree
);
120 gfc_add_modify_expr (&se
.pre
, len
, len_tree
);
121 gfc_add_modify_expr (&se
.pre
, addr
, label_tree
);
123 return gfc_finish_block (&se
.pre
);
126 /* Translate a GOTO statement. */
129 gfc_trans_goto (gfc_code
* code
)
139 if (code
->label
!= NULL
)
140 return build1_v (GOTO_EXPR
, gfc_get_label_decl (code
->label
));
143 gfc_init_se (&se
, NULL
);
144 gfc_start_block (&se
.pre
);
145 gfc_conv_expr (&se
, code
->expr
);
147 gfc_build_cstring_const ("Assigned label is not a target label");
148 tmp
= GFC_DECL_STRING_LEN (se
.expr
);
149 tmp
= build2 (NE_EXPR
, boolean_type_node
, tmp
, integer_minus_one_node
);
150 gfc_trans_runtime_check (tmp
, assign_error
, &se
.pre
);
152 assigned_goto
= GFC_DECL_ASSIGN_ADDR (se
.expr
);
153 target
= build1 (GOTO_EXPR
, void_type_node
, assigned_goto
);
158 gfc_add_expr_to_block (&se
.pre
, target
);
159 return gfc_finish_block (&se
.pre
);
162 /* Check the label list. */
163 range_error
= gfc_build_cstring_const ("Assigned label is not in the list");
167 tmp
= gfc_get_label_decl (code
->label
);
168 tmp
= gfc_build_addr_expr (pvoid_type_node
, tmp
);
169 tmp
= build2 (EQ_EXPR
, boolean_type_node
, tmp
, assigned_goto
);
170 tmp
= build3_v (COND_EXPR
, tmp
, target
, build_empty_stmt ());
171 gfc_add_expr_to_block (&se
.pre
, tmp
);
174 while (code
!= NULL
);
175 gfc_trans_runtime_check (boolean_true_node
, range_error
, &se
.pre
);
176 return gfc_finish_block (&se
.pre
);
180 /* Translate an ENTRY statement. Just adds a label for this entry point. */
182 gfc_trans_entry (gfc_code
* code
)
184 return build1_v (LABEL_EXPR
, code
->ext
.entry
->label
);
188 /* Translate the CALL statement. Builds a call to an F95 subroutine. */
191 gfc_trans_call (gfc_code
* code
)
195 /* A CALL starts a new block because the actual arguments may have to
196 be evaluated first. */
197 gfc_init_se (&se
, NULL
);
198 gfc_start_block (&se
.pre
);
200 gcc_assert (code
->resolved_sym
);
201 has_alternate_specifier
= 0;
203 /* Translate the call. */
204 gfc_conv_function_call (&se
, code
->resolved_sym
, code
->ext
.actual
);
206 /* A subroutine without side-effect, by definition, does nothing! */
207 TREE_SIDE_EFFECTS (se
.expr
) = 1;
209 /* Chain the pieces together and return the block. */
210 if (has_alternate_specifier
)
212 gfc_code
*select_code
;
214 select_code
= code
->next
;
215 gcc_assert(select_code
->op
== EXEC_SELECT
);
216 sym
= select_code
->expr
->symtree
->n
.sym
;
217 se
.expr
= convert (gfc_typenode_for_spec (&sym
->ts
), se
.expr
);
218 gfc_add_modify_expr (&se
.pre
, sym
->backend_decl
, se
.expr
);
221 gfc_add_expr_to_block (&se
.pre
, se
.expr
);
223 gfc_add_block_to_block (&se
.pre
, &se
.post
);
224 return gfc_finish_block (&se
.pre
);
228 /* Translate the RETURN statement. */
231 gfc_trans_return (gfc_code
* code ATTRIBUTE_UNUSED
)
239 /* if code->expr is not NULL, this return statement must appear
240 in a subroutine and current_fake_result_decl has already
243 result
= gfc_get_fake_result_decl (NULL
);
246 gfc_warning ("An alternate return at %L without a * dummy argument",
248 return build1_v (GOTO_EXPR
, gfc_get_return_label ());
251 /* Start a new block for this statement. */
252 gfc_init_se (&se
, NULL
);
253 gfc_start_block (&se
.pre
);
255 gfc_conv_expr (&se
, code
->expr
);
257 tmp
= build2 (MODIFY_EXPR
, TREE_TYPE (result
), result
, se
.expr
);
258 gfc_add_expr_to_block (&se
.pre
, tmp
);
260 tmp
= build1_v (GOTO_EXPR
, gfc_get_return_label ());
261 gfc_add_expr_to_block (&se
.pre
, tmp
);
262 gfc_add_block_to_block (&se
.pre
, &se
.post
);
263 return gfc_finish_block (&se
.pre
);
266 return build1_v (GOTO_EXPR
, gfc_get_return_label ());
270 /* Translate the PAUSE statement. We have to translate this statement
271 to a runtime library call. */
274 gfc_trans_pause (gfc_code
* code
)
276 tree gfc_int4_type_node
= gfc_get_int_type (4);
282 /* Start a new block for this statement. */
283 gfc_init_se (&se
, NULL
);
284 gfc_start_block (&se
.pre
);
287 if (code
->expr
== NULL
)
289 tmp
= build_int_cst (gfc_int4_type_node
, code
->ext
.stop_code
);
290 args
= gfc_chainon_list (NULL_TREE
, tmp
);
291 fndecl
= gfor_fndecl_pause_numeric
;
295 gfc_conv_expr_reference (&se
, code
->expr
);
296 args
= gfc_chainon_list (NULL_TREE
, se
.expr
);
297 args
= gfc_chainon_list (args
, se
.string_length
);
298 fndecl
= gfor_fndecl_pause_string
;
301 tmp
= gfc_build_function_call (fndecl
, args
);
302 gfc_add_expr_to_block (&se
.pre
, tmp
);
304 gfc_add_block_to_block (&se
.pre
, &se
.post
);
306 return gfc_finish_block (&se
.pre
);
310 /* Translate the STOP statement. We have to translate this statement
311 to a runtime library call. */
314 gfc_trans_stop (gfc_code
* code
)
316 tree gfc_int4_type_node
= gfc_get_int_type (4);
322 /* Start a new block for this statement. */
323 gfc_init_se (&se
, NULL
);
324 gfc_start_block (&se
.pre
);
327 if (code
->expr
== NULL
)
329 tmp
= build_int_cst (gfc_int4_type_node
, code
->ext
.stop_code
);
330 args
= gfc_chainon_list (NULL_TREE
, tmp
);
331 fndecl
= gfor_fndecl_stop_numeric
;
335 gfc_conv_expr_reference (&se
, code
->expr
);
336 args
= gfc_chainon_list (NULL_TREE
, se
.expr
);
337 args
= gfc_chainon_list (args
, se
.string_length
);
338 fndecl
= gfor_fndecl_stop_string
;
341 tmp
= gfc_build_function_call (fndecl
, args
);
342 gfc_add_expr_to_block (&se
.pre
, tmp
);
344 gfc_add_block_to_block (&se
.pre
, &se
.post
);
346 return gfc_finish_block (&se
.pre
);
350 /* Generate GENERIC for the IF construct. This function also deals with
351 the simple IF statement, because the front end translates the IF
352 statement into an IF construct.
384 where COND_S is the simplified version of the predicate. PRE_COND_S
385 are the pre side-effects produced by the translation of the
387 We need to build the chain recursively otherwise we run into
388 problems with folding incomplete statements. */
391 gfc_trans_if_1 (gfc_code
* code
)
396 /* Check for an unconditional ELSE clause. */
398 return gfc_trans_code (code
->next
);
400 /* Initialize a statement builder for each block. Puts in NULL_TREEs. */
401 gfc_init_se (&if_se
, NULL
);
402 gfc_start_block (&if_se
.pre
);
404 /* Calculate the IF condition expression. */
405 gfc_conv_expr_val (&if_se
, code
->expr
);
407 /* Translate the THEN clause. */
408 stmt
= gfc_trans_code (code
->next
);
410 /* Translate the ELSE clause. */
412 elsestmt
= gfc_trans_if_1 (code
->block
);
414 elsestmt
= build_empty_stmt ();
416 /* Build the condition expression and add it to the condition block. */
417 stmt
= build3_v (COND_EXPR
, if_se
.expr
, stmt
, elsestmt
);
419 gfc_add_expr_to_block (&if_se
.pre
, stmt
);
421 /* Finish off this statement. */
422 return gfc_finish_block (&if_se
.pre
);
426 gfc_trans_if (gfc_code
* code
)
428 /* Ignore the top EXEC_IF, it only announces an IF construct. The
429 actual code we must translate is in code->block. */
431 return gfc_trans_if_1 (code
->block
);
435 /* Translage an arithmetic IF expression.
437 IF (cond) label1, label2, label3 translates to
451 gfc_trans_arithmetic_if (gfc_code
* code
)
459 /* Start a new block. */
460 gfc_init_se (&se
, NULL
);
461 gfc_start_block (&se
.pre
);
463 /* Pre-evaluate COND. */
464 gfc_conv_expr_val (&se
, code
->expr
);
466 /* Build something to compare with. */
467 zero
= gfc_build_const (TREE_TYPE (se
.expr
), integer_zero_node
);
469 /* If (cond < 0) take branch1 else take branch2.
470 First build jumps to the COND .LT. 0 and the COND .EQ. 0 cases. */
471 branch1
= build1_v (GOTO_EXPR
, gfc_get_label_decl (code
->label
));
472 branch2
= build1_v (GOTO_EXPR
, gfc_get_label_decl (code
->label2
));
474 tmp
= build2 (LT_EXPR
, boolean_type_node
, se
.expr
, zero
);
475 branch1
= build3_v (COND_EXPR
, tmp
, branch1
, branch2
);
477 /* if (cond <= 0) take branch1 else take branch2. */
478 branch2
= build1_v (GOTO_EXPR
, gfc_get_label_decl (code
->label3
));
479 tmp
= build2 (LE_EXPR
, boolean_type_node
, se
.expr
, zero
);
480 branch1
= build3_v (COND_EXPR
, tmp
, branch1
, branch2
);
482 /* Append the COND_EXPR to the evaluation of COND, and return. */
483 gfc_add_expr_to_block (&se
.pre
, branch1
);
484 return gfc_finish_block (&se
.pre
);
488 /* Translate the simple DO construct. This is where the loop variable has
489 integer type and step +-1. We can't use this in the general case
490 because integer overflow and floating point errors could give incorrect
492 We translate a do loop from:
494 DO dovar = from, to, step
500 [Evaluate loop bounds and step]
502 if ((step > 0) ? (dovar <= to) : (dovar => to))
508 cond = (dovar == to);
510 if (cond) goto end_label;
515 This helps the optimizers by avoiding the extra induction variable
516 used in the general case. */
519 gfc_trans_simple_do (gfc_code
* code
, stmtblock_t
*pblock
, tree dovar
,
520 tree from
, tree to
, tree step
)
529 type
= TREE_TYPE (dovar
);
531 /* Initialize the DO variable: dovar = from. */
532 gfc_add_modify_expr (pblock
, dovar
, from
);
534 /* Cycle and exit statements are implemented with gotos. */
535 cycle_label
= gfc_build_label_decl (NULL_TREE
);
536 exit_label
= gfc_build_label_decl (NULL_TREE
);
538 /* Put the labels where they can be found later. See gfc_trans_do(). */
539 code
->block
->backend_decl
= tree_cons (cycle_label
, exit_label
, NULL
);
542 gfc_start_block (&body
);
544 /* Main loop body. */
545 tmp
= gfc_trans_code (code
->block
->next
);
546 gfc_add_expr_to_block (&body
, tmp
);
548 /* Label for cycle statements (if needed). */
549 if (TREE_USED (cycle_label
))
551 tmp
= build1_v (LABEL_EXPR
, cycle_label
);
552 gfc_add_expr_to_block (&body
, tmp
);
555 /* Evaluate the loop condition. */
556 cond
= build2 (EQ_EXPR
, boolean_type_node
, dovar
, to
);
557 cond
= gfc_evaluate_now (cond
, &body
);
559 /* Increment the loop variable. */
560 tmp
= build2 (PLUS_EXPR
, type
, dovar
, step
);
561 gfc_add_modify_expr (&body
, dovar
, tmp
);
564 tmp
= build1_v (GOTO_EXPR
, exit_label
);
565 TREE_USED (exit_label
) = 1;
566 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt ());
567 gfc_add_expr_to_block (&body
, tmp
);
569 /* Finish the loop body. */
570 tmp
= gfc_finish_block (&body
);
571 tmp
= build1_v (LOOP_EXPR
, tmp
);
573 /* Only execute the loop if the number of iterations is positive. */
574 if (tree_int_cst_sgn (step
) > 0)
575 cond
= fold (build2 (LE_EXPR
, boolean_type_node
, dovar
, to
));
577 cond
= fold (build2 (GE_EXPR
, boolean_type_node
, dovar
, to
));
578 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt ());
579 gfc_add_expr_to_block (pblock
, tmp
);
581 /* Add the exit label. */
582 tmp
= build1_v (LABEL_EXPR
, exit_label
);
583 gfc_add_expr_to_block (pblock
, tmp
);
585 return gfc_finish_block (pblock
);
588 /* Translate the DO construct. This obviously is one of the most
589 important ones to get right with any compiler, but especially
592 We special case some loop forms as described in gfc_trans_simple_do.
593 For other cases we implement them with a separate loop count,
594 as described in the standard.
596 We translate a do loop from:
598 DO dovar = from, to, step
604 [evaluate loop bounds and step]
605 count = to + step - from;
613 if (count <=0) goto exit_label;
617 TODO: Large loop counts
618 The code above assumes the loop count fits into a signed integer kind,
619 i.e. Does not work for loop counts > 2^31 for integer(kind=4) variables
620 We must support the full range. */
623 gfc_trans_do (gfc_code
* code
)
640 gfc_start_block (&block
);
642 /* Evaluate all the expressions in the iterator. */
643 gfc_init_se (&se
, NULL
);
644 gfc_conv_expr_lhs (&se
, code
->ext
.iterator
->var
);
645 gfc_add_block_to_block (&block
, &se
.pre
);
647 type
= TREE_TYPE (dovar
);
649 gfc_init_se (&se
, NULL
);
650 gfc_conv_expr_val (&se
, code
->ext
.iterator
->start
);
651 gfc_add_block_to_block (&block
, &se
.pre
);
652 from
= gfc_evaluate_now (se
.expr
, &block
);
654 gfc_init_se (&se
, NULL
);
655 gfc_conv_expr_val (&se
, code
->ext
.iterator
->end
);
656 gfc_add_block_to_block (&block
, &se
.pre
);
657 to
= gfc_evaluate_now (se
.expr
, &block
);
659 gfc_init_se (&se
, NULL
);
660 gfc_conv_expr_val (&se
, code
->ext
.iterator
->step
);
661 gfc_add_block_to_block (&block
, &se
.pre
);
662 step
= gfc_evaluate_now (se
.expr
, &block
);
664 /* Special case simple loops. */
665 if (TREE_CODE (type
) == INTEGER_TYPE
666 && (integer_onep (step
)
667 || tree_int_cst_equal (step
, integer_minus_one_node
)))
668 return gfc_trans_simple_do (code
, &block
, dovar
, from
, to
, step
);
670 /* Initialize loop count. This code is executed before we enter the
671 loop body. We generate: count = (to + step - from) / step. */
673 tmp
= fold (build2 (MINUS_EXPR
, type
, step
, from
));
674 tmp
= fold (build2 (PLUS_EXPR
, type
, to
, tmp
));
675 if (TREE_CODE (type
) == INTEGER_TYPE
)
677 tmp
= fold (build2 (TRUNC_DIV_EXPR
, type
, tmp
, step
));
678 count
= gfc_create_var (type
, "count");
682 /* TODO: We could use the same width as the real type.
683 This would probably cause more problems that it solves
684 when we implement "long double" types. */
685 tmp
= fold (build2 (RDIV_EXPR
, type
, tmp
, step
));
686 tmp
= fold (build1 (FIX_TRUNC_EXPR
, gfc_array_index_type
, tmp
));
687 count
= gfc_create_var (gfc_array_index_type
, "count");
689 gfc_add_modify_expr (&block
, count
, tmp
);
691 count_one
= convert (TREE_TYPE (count
), integer_one_node
);
693 /* Initialize the DO variable: dovar = from. */
694 gfc_add_modify_expr (&block
, dovar
, from
);
697 gfc_start_block (&body
);
699 /* Cycle and exit statements are implemented with gotos. */
700 cycle_label
= gfc_build_label_decl (NULL_TREE
);
701 exit_label
= gfc_build_label_decl (NULL_TREE
);
703 /* Start with the loop condition. Loop until count <= 0. */
704 cond
= build2 (LE_EXPR
, boolean_type_node
, count
,
705 convert (TREE_TYPE (count
), integer_zero_node
));
706 tmp
= build1_v (GOTO_EXPR
, exit_label
);
707 TREE_USED (exit_label
) = 1;
708 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt ());
709 gfc_add_expr_to_block (&body
, tmp
);
711 /* Put these labels where they can be found later. We put the
712 labels in a TREE_LIST node (because TREE_CHAIN is already
713 used). cycle_label goes in TREE_PURPOSE (backend_decl), exit
714 label in TREE_VALUE (backend_decl). */
716 code
->block
->backend_decl
= tree_cons (cycle_label
, exit_label
, NULL
);
718 /* Main loop body. */
719 tmp
= gfc_trans_code (code
->block
->next
);
720 gfc_add_expr_to_block (&body
, tmp
);
722 /* Label for cycle statements (if needed). */
723 if (TREE_USED (cycle_label
))
725 tmp
= build1_v (LABEL_EXPR
, cycle_label
);
726 gfc_add_expr_to_block (&body
, tmp
);
729 /* Increment the loop variable. */
730 tmp
= build2 (PLUS_EXPR
, type
, dovar
, step
);
731 gfc_add_modify_expr (&body
, dovar
, tmp
);
733 /* Decrement the loop count. */
734 tmp
= build2 (MINUS_EXPR
, TREE_TYPE (count
), count
, count_one
);
735 gfc_add_modify_expr (&body
, count
, tmp
);
737 /* End of loop body. */
738 tmp
= gfc_finish_block (&body
);
740 /* The for loop itself. */
741 tmp
= build1_v (LOOP_EXPR
, tmp
);
742 gfc_add_expr_to_block (&block
, tmp
);
744 /* Add the exit label. */
745 tmp
= build1_v (LABEL_EXPR
, exit_label
);
746 gfc_add_expr_to_block (&block
, tmp
);
748 return gfc_finish_block (&block
);
752 /* Translate the DO WHILE construct.
765 if (! cond) goto exit_label;
771 Because the evaluation of the exit condition `cond' may have side
772 effects, we can't do much for empty loop bodies. The backend optimizers
773 should be smart enough to eliminate any dead loops. */
776 gfc_trans_do_while (gfc_code
* code
)
784 /* Everything we build here is part of the loop body. */
785 gfc_start_block (&block
);
787 /* Cycle and exit statements are implemented with gotos. */
788 cycle_label
= gfc_build_label_decl (NULL_TREE
);
789 exit_label
= gfc_build_label_decl (NULL_TREE
);
791 /* Put the labels where they can be found later. See gfc_trans_do(). */
792 code
->block
->backend_decl
= tree_cons (cycle_label
, exit_label
, NULL
);
794 /* Create a GIMPLE version of the exit condition. */
795 gfc_init_se (&cond
, NULL
);
796 gfc_conv_expr_val (&cond
, code
->expr
);
797 gfc_add_block_to_block (&block
, &cond
.pre
);
798 cond
.expr
= fold (build1 (TRUTH_NOT_EXPR
, boolean_type_node
, cond
.expr
));
800 /* Build "IF (! cond) GOTO exit_label". */
801 tmp
= build1_v (GOTO_EXPR
, exit_label
);
802 TREE_USED (exit_label
) = 1;
803 tmp
= build3_v (COND_EXPR
, cond
.expr
, tmp
, build_empty_stmt ());
804 gfc_add_expr_to_block (&block
, tmp
);
806 /* The main body of the loop. */
807 tmp
= gfc_trans_code (code
->block
->next
);
808 gfc_add_expr_to_block (&block
, tmp
);
810 /* Label for cycle statements (if needed). */
811 if (TREE_USED (cycle_label
))
813 tmp
= build1_v (LABEL_EXPR
, cycle_label
);
814 gfc_add_expr_to_block (&block
, tmp
);
817 /* End of loop body. */
818 tmp
= gfc_finish_block (&block
);
820 gfc_init_block (&block
);
821 /* Build the loop. */
822 tmp
= build1_v (LOOP_EXPR
, tmp
);
823 gfc_add_expr_to_block (&block
, tmp
);
825 /* Add the exit label. */
826 tmp
= build1_v (LABEL_EXPR
, exit_label
);
827 gfc_add_expr_to_block (&block
, tmp
);
829 return gfc_finish_block (&block
);
833 /* Translate the SELECT CASE construct for INTEGER case expressions,
834 without killing all potential optimizations. The problem is that
835 Fortran allows unbounded cases, but the back-end does not, so we
836 need to intercept those before we enter the equivalent SWITCH_EXPR
839 For example, we translate this,
842 CASE (:100,101,105:115)
852 to the GENERIC equivalent,
856 case (minimum value for typeof(expr) ... 100:
862 case 200 ... (maximum value for typeof(expr):
879 gfc_trans_integer_select (gfc_code
* code
)
889 gfc_start_block (&block
);
891 /* Calculate the switch expression. */
892 gfc_init_se (&se
, NULL
);
893 gfc_conv_expr_val (&se
, code
->expr
);
894 gfc_add_block_to_block (&block
, &se
.pre
);
896 end_label
= gfc_build_label_decl (NULL_TREE
);
898 gfc_init_block (&body
);
900 for (c
= code
->block
; c
; c
= c
->block
)
902 for (cp
= c
->ext
.case_list
; cp
; cp
= cp
->next
)
907 /* Assume it's the default case. */
908 low
= high
= NULL_TREE
;
912 low
= gfc_conv_constant_to_tree (cp
->low
);
914 /* If there's only a lower bound, set the high bound to the
915 maximum value of the case expression. */
917 high
= TYPE_MAX_VALUE (TREE_TYPE (se
.expr
));
922 /* Three cases are possible here:
924 1) There is no lower bound, e.g. CASE (:N).
925 2) There is a lower bound .NE. high bound, that is
926 a case range, e.g. CASE (N:M) where M>N (we make
927 sure that M>N during type resolution).
928 3) There is a lower bound, and it has the same value
929 as the high bound, e.g. CASE (N:N). This is our
930 internal representation of CASE(N).
932 In the first and second case, we need to set a value for
933 high. In the thirth case, we don't because the GCC middle
934 end represents a single case value by just letting high be
935 a NULL_TREE. We can't do that because we need to be able
936 to represent unbounded cases. */
940 && mpz_cmp (cp
->low
->value
.integer
,
941 cp
->high
->value
.integer
) != 0))
942 high
= gfc_conv_constant_to_tree (cp
->high
);
944 /* Unbounded case. */
946 low
= TYPE_MIN_VALUE (TREE_TYPE (se
.expr
));
950 label
= build_decl (LABEL_DECL
, NULL_TREE
, NULL_TREE
);
951 DECL_CONTEXT (label
) = current_function_decl
;
953 /* Add this case label.
954 Add parameter 'label', make it match GCC backend. */
955 tmp
= build3 (CASE_LABEL_EXPR
, void_type_node
, low
, high
, label
);
956 gfc_add_expr_to_block (&body
, tmp
);
959 /* Add the statements for this case. */
960 tmp
= gfc_trans_code (c
->next
);
961 gfc_add_expr_to_block (&body
, tmp
);
963 /* Break to the end of the construct. */
964 tmp
= build1_v (GOTO_EXPR
, end_label
);
965 gfc_add_expr_to_block (&body
, tmp
);
968 tmp
= gfc_finish_block (&body
);
969 tmp
= build3_v (SWITCH_EXPR
, se
.expr
, tmp
, NULL_TREE
);
970 gfc_add_expr_to_block (&block
, tmp
);
972 tmp
= build1_v (LABEL_EXPR
, end_label
);
973 gfc_add_expr_to_block (&block
, tmp
);
975 return gfc_finish_block (&block
);
979 /* Translate the SELECT CASE construct for LOGICAL case expressions.
981 There are only two cases possible here, even though the standard
982 does allow three cases in a LOGICAL SELECT CASE construct: .TRUE.,
983 .FALSE., and DEFAULT.
985 We never generate more than two blocks here. Instead, we always
986 try to eliminate the DEFAULT case. This way, we can translate this
987 kind of SELECT construct to a simple
991 expression in GENERIC. */
994 gfc_trans_logical_select (gfc_code
* code
)
1002 /* Assume we don't have any cases at all. */
1005 /* Now see which ones we actually do have. We can have at most two
1006 cases in a single case list: one for .TRUE. and one for .FALSE.
1007 The default case is always separate. If the cases for .TRUE. and
1008 .FALSE. are in the same case list, the block for that case list
1009 always executed, and we don't generate code a COND_EXPR. */
1010 for (c
= code
->block
; c
; c
= c
->block
)
1012 for (cp
= c
->ext
.case_list
; cp
; cp
= cp
->next
)
1016 if (cp
->low
->value
.logical
== 0) /* .FALSE. */
1018 else /* if (cp->value.logical != 0), thus .TRUE. */
1026 /* Start a new block. */
1027 gfc_start_block (&block
);
1029 /* Calculate the switch expression. We always need to do this
1030 because it may have side effects. */
1031 gfc_init_se (&se
, NULL
);
1032 gfc_conv_expr_val (&se
, code
->expr
);
1033 gfc_add_block_to_block (&block
, &se
.pre
);
1035 if (t
== f
&& t
!= NULL
)
1037 /* Cases for .TRUE. and .FALSE. are in the same block. Just
1038 translate the code for these cases, append it to the current
1040 gfc_add_expr_to_block (&block
, gfc_trans_code (t
->next
));
1044 tree true_tree
, false_tree
;
1046 true_tree
= build_empty_stmt ();
1047 false_tree
= build_empty_stmt ();
1049 /* If we have a case for .TRUE. and for .FALSE., discard the default case.
1050 Otherwise, if .TRUE. or .FALSE. is missing and there is a default case,
1051 make the missing case the default case. */
1052 if (t
!= NULL
&& f
!= NULL
)
1062 /* Translate the code for each of these blocks, and append it to
1063 the current block. */
1065 true_tree
= gfc_trans_code (t
->next
);
1068 false_tree
= gfc_trans_code (f
->next
);
1070 gfc_add_expr_to_block (&block
, build3_v (COND_EXPR
, se
.expr
,
1071 true_tree
, false_tree
));
1074 return gfc_finish_block (&block
);
1078 /* Translate the SELECT CASE construct for CHARACTER case expressions.
1079 Instead of generating compares and jumps, it is far simpler to
1080 generate a data structure describing the cases in order and call a
1081 library subroutine that locates the right case.
1082 This is particularly true because this is the only case where we
1083 might have to dispose of a temporary.
1084 The library subroutine returns a pointer to jump to or NULL if no
1085 branches are to be taken. */
1088 gfc_trans_character_select (gfc_code
*code
)
1090 tree init
, node
, end_label
, tmp
, type
, args
, *labels
;
1091 stmtblock_t block
, body
;
1097 static tree select_struct
;
1098 static tree ss_string1
, ss_string1_len
;
1099 static tree ss_string2
, ss_string2_len
;
1100 static tree ss_target
;
1102 if (select_struct
== NULL
)
1104 tree gfc_int4_type_node
= gfc_get_int_type (4);
1106 select_struct
= make_node (RECORD_TYPE
);
1107 TYPE_NAME (select_struct
) = get_identifier ("_jump_struct");
1110 #define ADD_FIELD(NAME, TYPE) \
1111 ss_##NAME = gfc_add_field_to_struct \
1112 (&(TYPE_FIELDS (select_struct)), select_struct, \
1113 get_identifier (stringize(NAME)), TYPE)
1115 ADD_FIELD (string1
, pchar_type_node
);
1116 ADD_FIELD (string1_len
, gfc_int4_type_node
);
1118 ADD_FIELD (string2
, pchar_type_node
);
1119 ADD_FIELD (string2_len
, gfc_int4_type_node
);
1121 ADD_FIELD (target
, pvoid_type_node
);
1124 gfc_finish_type (select_struct
);
1127 cp
= code
->block
->ext
.case_list
;
1128 while (cp
->left
!= NULL
)
1132 for (d
= cp
; d
; d
= d
->right
)
1136 labels
= gfc_getmem (n
* sizeof (tree
));
1140 for(i
= 0; i
< n
; i
++)
1142 labels
[i
] = gfc_build_label_decl (NULL_TREE
);
1143 TREE_USED (labels
[i
]) = 1;
1144 /* TODO: The gimplifier should do this for us, but it has
1145 inadequacies when dealing with static initializers. */
1146 FORCED_LABEL (labels
[i
]) = 1;
1149 end_label
= gfc_build_label_decl (NULL_TREE
);
1151 /* Generate the body */
1152 gfc_start_block (&block
);
1153 gfc_init_block (&body
);
1155 for (c
= code
->block
; c
; c
= c
->block
)
1157 for (d
= c
->ext
.case_list
; d
; d
= d
->next
)
1159 tmp
= build1_v (LABEL_EXPR
, labels
[d
->n
]);
1160 gfc_add_expr_to_block (&body
, tmp
);
1163 tmp
= gfc_trans_code (c
->next
);
1164 gfc_add_expr_to_block (&body
, tmp
);
1166 tmp
= build1_v (GOTO_EXPR
, end_label
);
1167 gfc_add_expr_to_block (&body
, tmp
);
1170 /* Generate the structure describing the branches */
1174 for(d
= cp
; d
; d
= d
->right
, i
++)
1178 gfc_init_se (&se
, NULL
);
1182 node
= tree_cons (ss_string1
, null_pointer_node
, node
);
1183 node
= tree_cons (ss_string1_len
, integer_zero_node
, node
);
1187 gfc_conv_expr_reference (&se
, d
->low
);
1189 node
= tree_cons (ss_string1
, se
.expr
, node
);
1190 node
= tree_cons (ss_string1_len
, se
.string_length
, node
);
1193 if (d
->high
== NULL
)
1195 node
= tree_cons (ss_string2
, null_pointer_node
, node
);
1196 node
= tree_cons (ss_string2_len
, integer_zero_node
, node
);
1200 gfc_init_se (&se
, NULL
);
1201 gfc_conv_expr_reference (&se
, d
->high
);
1203 node
= tree_cons (ss_string2
, se
.expr
, node
);
1204 node
= tree_cons (ss_string2_len
, se
.string_length
, node
);
1207 tmp
= gfc_build_addr_expr (pvoid_type_node
, labels
[i
]);
1208 node
= tree_cons (ss_target
, tmp
, node
);
1210 tmp
= build1 (CONSTRUCTOR
, select_struct
, nreverse (node
));
1211 init
= tree_cons (NULL_TREE
, tmp
, init
);
1214 type
= build_array_type (select_struct
, build_index_type
1215 (build_int_cst (NULL_TREE
, n
- 1)));
1217 init
= build1 (CONSTRUCTOR
, type
, nreverse(init
));
1218 TREE_CONSTANT (init
) = 1;
1219 TREE_INVARIANT (init
) = 1;
1220 TREE_STATIC (init
) = 1;
1221 /* Create a static variable to hold the jump table. */
1222 tmp
= gfc_create_var (type
, "jumptable");
1223 TREE_CONSTANT (tmp
) = 1;
1224 TREE_INVARIANT (tmp
) = 1;
1225 TREE_STATIC (tmp
) = 1;
1226 DECL_INITIAL (tmp
) = init
;
1229 /* Build an argument list for the library call */
1230 init
= gfc_build_addr_expr (pvoid_type_node
, init
);
1231 args
= gfc_chainon_list (NULL_TREE
, init
);
1233 tmp
= build_int_cst (NULL_TREE
, n
);
1234 args
= gfc_chainon_list (args
, tmp
);
1236 tmp
= gfc_build_addr_expr (pvoid_type_node
, end_label
);
1237 args
= gfc_chainon_list (args
, tmp
);
1239 gfc_init_se (&se
, NULL
);
1240 gfc_conv_expr_reference (&se
, code
->expr
);
1242 args
= gfc_chainon_list (args
, se
.expr
);
1243 args
= gfc_chainon_list (args
, se
.string_length
);
1245 gfc_add_block_to_block (&block
, &se
.pre
);
1247 tmp
= gfc_build_function_call (gfor_fndecl_select_string
, args
);
1248 tmp
= build1 (GOTO_EXPR
, void_type_node
, tmp
);
1249 gfc_add_expr_to_block (&block
, tmp
);
1251 tmp
= gfc_finish_block (&body
);
1252 gfc_add_expr_to_block (&block
, tmp
);
1253 tmp
= build1_v (LABEL_EXPR
, end_label
);
1254 gfc_add_expr_to_block (&block
, tmp
);
1259 return gfc_finish_block (&block
);
1263 /* Translate the three variants of the SELECT CASE construct.
1265 SELECT CASEs with INTEGER case expressions can be translated to an
1266 equivalent GENERIC switch statement, and for LOGICAL case
1267 expressions we build one or two if-else compares.
1269 SELECT CASEs with CHARACTER case expressions are a whole different
1270 story, because they don't exist in GENERIC. So we sort them and
1271 do a binary search at runtime.
1273 Fortran has no BREAK statement, and it does not allow jumps from
1274 one case block to another. That makes things a lot easier for
1278 gfc_trans_select (gfc_code
* code
)
1280 gcc_assert (code
&& code
->expr
);
1282 /* Empty SELECT constructs are legal. */
1283 if (code
->block
== NULL
)
1284 return build_empty_stmt ();
1286 /* Select the correct translation function. */
1287 switch (code
->expr
->ts
.type
)
1289 case BT_LOGICAL
: return gfc_trans_logical_select (code
);
1290 case BT_INTEGER
: return gfc_trans_integer_select (code
);
1291 case BT_CHARACTER
: return gfc_trans_character_select (code
);
1293 gfc_internal_error ("gfc_trans_select(): Bad type for case expr.");
1299 /* Generate the loops for a FORALL block. The normal loop format:
1300 count = (end - start + step) / step
1313 gfc_trans_forall_loop (forall_info
*forall_tmp
, int nvar
, tree body
, int mask_flag
)
1321 tree var
, start
, end
, step
, mask
, maskindex
;
1324 iter
= forall_tmp
->this_loop
;
1325 for (n
= 0; n
< nvar
; n
++)
1328 start
= iter
->start
;
1332 exit_label
= gfc_build_label_decl (NULL_TREE
);
1333 TREE_USED (exit_label
) = 1;
1335 /* The loop counter. */
1336 count
= gfc_create_var (TREE_TYPE (var
), "count");
1338 /* The body of the loop. */
1339 gfc_init_block (&block
);
1341 /* The exit condition. */
1342 cond
= build2 (LE_EXPR
, boolean_type_node
, count
, integer_zero_node
);
1343 tmp
= build1_v (GOTO_EXPR
, exit_label
);
1344 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt ());
1345 gfc_add_expr_to_block (&block
, tmp
);
1347 /* The main loop body. */
1348 gfc_add_expr_to_block (&block
, body
);
1350 /* Increment the loop variable. */
1351 tmp
= build2 (PLUS_EXPR
, TREE_TYPE (var
), var
, step
);
1352 gfc_add_modify_expr (&block
, var
, tmp
);
1354 /* Advance to the next mask element. */
1357 mask
= forall_tmp
->mask
;
1358 maskindex
= forall_tmp
->maskindex
;
1361 tmp
= build2 (PLUS_EXPR
, gfc_array_index_type
,
1362 maskindex
, gfc_index_one_node
);
1363 gfc_add_modify_expr (&block
, maskindex
, tmp
);
1366 /* Decrement the loop counter. */
1367 tmp
= build2 (MINUS_EXPR
, TREE_TYPE (var
), count
, gfc_index_one_node
);
1368 gfc_add_modify_expr (&block
, count
, tmp
);
1370 body
= gfc_finish_block (&block
);
1372 /* Loop var initialization. */
1373 gfc_init_block (&block
);
1374 gfc_add_modify_expr (&block
, var
, start
);
1376 /* Initialize the loop counter. */
1377 tmp
= fold (build2 (MINUS_EXPR
, TREE_TYPE (var
), step
, start
));
1378 tmp
= fold (build2 (PLUS_EXPR
, TREE_TYPE (var
), end
, tmp
));
1379 tmp
= fold (build2 (TRUNC_DIV_EXPR
, TREE_TYPE (var
), tmp
, step
));
1380 gfc_add_modify_expr (&block
, count
, tmp
);
1382 /* The loop expression. */
1383 tmp
= build1_v (LOOP_EXPR
, body
);
1384 gfc_add_expr_to_block (&block
, tmp
);
1386 /* The exit label. */
1387 tmp
= build1_v (LABEL_EXPR
, exit_label
);
1388 gfc_add_expr_to_block (&block
, tmp
);
1390 body
= gfc_finish_block (&block
);
1397 /* Generate the body and loops according to MASK_FLAG and NEST_FLAG.
1398 if MASK_FLAG is nonzero, the body is controlled by maskes in forall
1399 nest, otherwise, the body is not controlled by maskes.
1400 if NEST_FLAG is nonzero, generate loops for nested forall, otherwise,
1401 only generate loops for the current forall level. */
1404 gfc_trans_nested_forall_loop (forall_info
* nested_forall_info
, tree body
,
1405 int mask_flag
, int nest_flag
)
1409 forall_info
*forall_tmp
;
1410 tree pmask
, mask
, maskindex
;
1412 forall_tmp
= nested_forall_info
;
1413 /* Generate loops for nested forall. */
1416 while (forall_tmp
->next_nest
!= NULL
)
1417 forall_tmp
= forall_tmp
->next_nest
;
1418 while (forall_tmp
!= NULL
)
1420 /* Generate body with masks' control. */
1423 pmask
= forall_tmp
->pmask
;
1424 mask
= forall_tmp
->mask
;
1425 maskindex
= forall_tmp
->maskindex
;
1429 /* If a mask was specified make the assignment conditional. */
1431 tmp
= gfc_build_indirect_ref (mask
);
1434 tmp
= gfc_build_array_ref (tmp
, maskindex
);
1436 body
= build3_v (COND_EXPR
, tmp
, body
, build_empty_stmt ());
1439 nvar
= forall_tmp
->nvar
;
1440 body
= gfc_trans_forall_loop (forall_tmp
, nvar
, body
, mask_flag
);
1441 forall_tmp
= forall_tmp
->outer
;
1446 nvar
= forall_tmp
->nvar
;
1447 body
= gfc_trans_forall_loop (forall_tmp
, nvar
, body
, mask_flag
);
1454 /* Allocate data for holding a temporary array. Returns either a local
1455 temporary array or a pointer variable. */
1458 gfc_do_allocate (tree bytesize
, tree size
, tree
* pdata
, stmtblock_t
* pblock
,
1466 if (INTEGER_CST_P (size
))
1468 tmp
= fold (build2 (MINUS_EXPR
, gfc_array_index_type
, size
,
1469 gfc_index_one_node
));
1474 type
= build_range_type (gfc_array_index_type
, gfc_index_zero_node
, tmp
);
1475 type
= build_array_type (elem_type
, type
);
1476 if (gfc_can_put_var_on_stack (bytesize
))
1478 gcc_assert (INTEGER_CST_P (size
));
1479 tmpvar
= gfc_create_var (type
, "temp");
1484 tmpvar
= gfc_create_var (build_pointer_type (type
), "temp");
1485 *pdata
= convert (pvoid_type_node
, tmpvar
);
1487 args
= gfc_chainon_list (NULL_TREE
, bytesize
);
1488 if (gfc_index_integer_kind
== 4)
1489 tmp
= gfor_fndecl_internal_malloc
;
1490 else if (gfc_index_integer_kind
== 8)
1491 tmp
= gfor_fndecl_internal_malloc64
;
1494 tmp
= gfc_build_function_call (tmp
, args
);
1495 tmp
= convert (TREE_TYPE (tmpvar
), tmp
);
1496 gfc_add_modify_expr (pblock
, tmpvar
, tmp
);
1502 /* Generate codes to copy the temporary to the actual lhs. */
1505 generate_loop_for_temp_to_lhs (gfc_expr
*expr
, tree tmp1
, tree size
,
1506 tree count3
, tree count1
, tree count2
, tree wheremask
)
1510 stmtblock_t block
, body
;
1517 lss
= gfc_walk_expr (expr
);
1519 if (lss
== gfc_ss_terminator
)
1521 gfc_start_block (&block
);
1523 gfc_init_se (&lse
, NULL
);
1525 /* Translate the expression. */
1526 gfc_conv_expr (&lse
, expr
);
1528 /* Form the expression for the temporary. */
1529 tmp
= gfc_build_array_ref (tmp1
, count1
);
1531 /* Use the scalar assignment as is. */
1532 gfc_add_block_to_block (&block
, &lse
.pre
);
1533 gfc_add_modify_expr (&block
, lse
.expr
, tmp
);
1534 gfc_add_block_to_block (&block
, &lse
.post
);
1536 /* Increment the count1. */
1537 tmp
= fold (build2 (PLUS_EXPR
, TREE_TYPE (count1
), count1
, size
));
1538 gfc_add_modify_expr (&block
, count1
, tmp
);
1539 tmp
= gfc_finish_block (&block
);
1543 gfc_start_block (&block
);
1545 gfc_init_loopinfo (&loop1
);
1546 gfc_init_se (&rse
, NULL
);
1547 gfc_init_se (&lse
, NULL
);
1549 /* Associate the lss with the loop. */
1550 gfc_add_ss_to_loop (&loop1
, lss
);
1552 /* Calculate the bounds of the scalarization. */
1553 gfc_conv_ss_startstride (&loop1
);
1554 /* Setup the scalarizing loops. */
1555 gfc_conv_loop_setup (&loop1
);
1557 gfc_mark_ss_chain_used (lss
, 1);
1558 /* Initialize count2. */
1559 gfc_add_modify_expr (&block
, count2
, gfc_index_zero_node
);
1561 /* Start the scalarized loop body. */
1562 gfc_start_scalarized_body (&loop1
, &body
);
1564 /* Setup the gfc_se structures. */
1565 gfc_copy_loopinfo_to_se (&lse
, &loop1
);
1568 /* Form the expression of the temporary. */
1569 if (lss
!= gfc_ss_terminator
)
1571 index
= fold (build2 (PLUS_EXPR
, gfc_array_index_type
,
1573 rse
.expr
= gfc_build_array_ref (tmp1
, index
);
1575 /* Translate expr. */
1576 gfc_conv_expr (&lse
, expr
);
1578 /* Use the scalar assignment. */
1579 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
.type
);
1581 /* Form the mask expression according to the mask tree list. */
1586 wheremaskexpr
= gfc_build_array_ref (tmp2
, count3
);
1587 tmp2
= TREE_CHAIN (tmp2
);
1590 tmp1
= gfc_build_array_ref (tmp2
, count3
);
1591 wheremaskexpr
= build2 (TRUTH_AND_EXPR
, TREE_TYPE (tmp1
),
1592 wheremaskexpr
, tmp1
);
1593 tmp2
= TREE_CHAIN (tmp2
);
1595 tmp
= build3_v (COND_EXPR
, wheremaskexpr
, tmp
, build_empty_stmt ());
1598 gfc_add_expr_to_block (&body
, tmp
);
1600 /* Increment count2. */
1601 tmp
= fold (build2 (PLUS_EXPR
, gfc_array_index_type
,
1602 count2
, gfc_index_one_node
));
1603 gfc_add_modify_expr (&body
, count2
, tmp
);
1605 /* Increment count3. */
1608 tmp
= fold (build2 (PLUS_EXPR
, gfc_array_index_type
,
1609 count3
, gfc_index_one_node
));
1610 gfc_add_modify_expr (&body
, count3
, tmp
);
1613 /* Generate the copying loops. */
1614 gfc_trans_scalarizing_loops (&loop1
, &body
);
1615 gfc_add_block_to_block (&block
, &loop1
.pre
);
1616 gfc_add_block_to_block (&block
, &loop1
.post
);
1617 gfc_cleanup_loop (&loop1
);
1619 /* Increment count1. */
1620 tmp
= fold (build2 (PLUS_EXPR
, TREE_TYPE (count1
), count1
, size
));
1621 gfc_add_modify_expr (&block
, count1
, tmp
);
1622 tmp
= gfc_finish_block (&block
);
1628 /* Generate codes to copy rhs to the temporary. TMP1 is the address of temporary
1629 LSS and RSS are formed in function compute_inner_temp_size(), and should
1633 generate_loop_for_rhs_to_temp (gfc_expr
*expr2
, tree tmp1
, tree size
,
1634 tree count3
, tree count1
, tree count2
,
1635 gfc_ss
*lss
, gfc_ss
*rss
, tree wheremask
)
1637 stmtblock_t block
, body1
;
1641 tree tmp
, tmp2
, index
;
1644 gfc_start_block (&block
);
1646 gfc_init_se (&rse
, NULL
);
1647 gfc_init_se (&lse
, NULL
);
1649 if (lss
== gfc_ss_terminator
)
1651 gfc_init_block (&body1
);
1652 gfc_conv_expr (&rse
, expr2
);
1653 lse
.expr
= gfc_build_array_ref (tmp1
, count1
);
1657 /* Initialize count2. */
1658 gfc_add_modify_expr (&block
, count2
, gfc_index_zero_node
);
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 index
= fold (build2 (PLUS_EXPR
, gfc_array_index_type
, count1
, count2
));
1681 lse
.expr
= gfc_build_array_ref (tmp1
, index
);
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. */
1692 wheremaskexpr
= gfc_build_array_ref (tmp2
, count3
);
1693 tmp2
= TREE_CHAIN (tmp2
);
1696 tmp1
= gfc_build_array_ref (tmp2
, count3
);
1697 wheremaskexpr
= build2 (TRUTH_AND_EXPR
, TREE_TYPE (tmp1
),
1698 wheremaskexpr
, tmp1
);
1699 tmp2
= TREE_CHAIN (tmp2
);
1701 tmp
= build3_v (COND_EXPR
, wheremaskexpr
, tmp
, build_empty_stmt ());
1704 gfc_add_expr_to_block (&body1
, tmp
);
1706 if (lss
== gfc_ss_terminator
)
1708 gfc_add_block_to_block (&block
, &body1
);
1712 /* Increment count2. */
1713 tmp
= fold (build2 (PLUS_EXPR
, gfc_array_index_type
,
1714 count2
, gfc_index_one_node
));
1715 gfc_add_modify_expr (&body1
, count2
, tmp
);
1717 /* Increment count3. */
1720 tmp
= fold (build2 (PLUS_EXPR
, gfc_array_index_type
,
1721 count3
, gfc_index_one_node
));
1722 gfc_add_modify_expr (&body1
, count3
, tmp
);
1725 /* Generate the copying loops. */
1726 gfc_trans_scalarizing_loops (&loop
, &body1
);
1728 gfc_add_block_to_block (&block
, &loop
.pre
);
1729 gfc_add_block_to_block (&block
, &loop
.post
);
1731 gfc_cleanup_loop (&loop
);
1732 /* TODO: Reuse lss and rss when copying temp->lhs. Need to be careful
1733 as tree nodes in SS may not be valid in different scope. */
1735 /* Increment count1. */
1736 tmp
= fold (build2 (PLUS_EXPR
, TREE_TYPE (count1
), count1
, size
));
1737 gfc_add_modify_expr (&block
, count1
, tmp
);
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
,
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 (nested_forall_info
)
1826 tmp
= build2 (PLUS_EXPR
, gfc_array_index_type
, number
,
1830 gfc_add_modify_expr (&body
, number
, tmp
);
1831 tmp
= gfc_finish_block (&body
);
1833 /* Generate loops. */
1834 if (nested_forall_info
!= NULL
)
1835 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, tmp
, 0, 1);
1837 gfc_add_expr_to_block (block
, tmp
);
1843 /* Allocate temporary for forall construct according to the information in
1844 nested_forall_info. INNER_SIZE is the size of temporary needed in the
1845 assignment inside forall. PTEMP1 is returned for space free. */
1848 allocate_temp_for_forall_nest (forall_info
* nested_forall_info
, tree type
,
1849 tree inner_size
, stmtblock_t
* block
,
1855 tree bytesize
, size
;
1857 /* Calculate the total size of temporary needed in forall construct. */
1858 size
= compute_overall_iter_number (nested_forall_info
, inner_size
, block
);
1860 unit
= TYPE_SIZE_UNIT (type
);
1861 bytesize
= fold (build2 (MULT_EXPR
, gfc_array_index_type
, size
, unit
));
1864 temp1
= gfc_do_allocate (bytesize
, size
, ptemp1
, block
, type
);
1867 tmp
= gfc_build_indirect_ref (temp1
);
1875 /* Handle assignments inside forall which need temporary. */
1877 gfc_trans_assign_need_temp (gfc_expr
* expr1
, gfc_expr
* expr2
, tree wheremask
,
1878 forall_info
* nested_forall_info
,
1879 stmtblock_t
* block
)
1884 tree count
, count1
, count2
;
1887 tree mask
, maskindex
;
1888 forall_info
*forall_tmp
;
1890 /* Create vars. count1 is the current iterator number of the nested forall.
1891 count2 is the current iterator number of the inner loops needed in the
1893 count1
= gfc_create_var (gfc_array_index_type
, "count1");
1894 count2
= gfc_create_var (gfc_array_index_type
, "count2");
1896 /* Count is the wheremask index. */
1899 count
= gfc_create_var (gfc_array_index_type
, "count");
1900 gfc_add_modify_expr (block
, count
, gfc_index_zero_node
);
1905 /* Initialize count1. */
1906 gfc_add_modify_expr (block
, count1
, gfc_index_zero_node
);
1908 /* Calculate the size of temporary needed in the assignment. Return loop, lss
1909 and rss which are used in function generate_loop_for_rhs_to_temp(). */
1910 inner_size
= compute_inner_temp_size (expr1
, expr2
, block
, &lss
, &rss
);
1912 /* The type of LHS. Used in function allocate_temp_for_forall_nest */
1913 type
= gfc_typenode_for_spec (&expr1
->ts
);
1915 /* Allocate temporary for nested forall construct according to the
1916 information in nested_forall_info and inner_size. */
1917 tmp1
= allocate_temp_for_forall_nest (nested_forall_info
, type
,
1918 inner_size
, block
, &ptemp1
);
1920 /* Initialize the maskindexes. */
1921 forall_tmp
= nested_forall_info
;
1922 while (forall_tmp
!= NULL
)
1924 mask
= forall_tmp
->mask
;
1925 maskindex
= forall_tmp
->maskindex
;
1927 gfc_add_modify_expr (block
, maskindex
, gfc_index_zero_node
);
1928 forall_tmp
= forall_tmp
->next_nest
;
1931 /* Generate codes to copy rhs to the temporary . */
1932 tmp
= generate_loop_for_rhs_to_temp (expr2
, tmp1
, inner_size
, count
,
1933 count1
, count2
, lss
, rss
, wheremask
);
1935 /* Generate body and loops according to the information in
1936 nested_forall_info. */
1937 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, tmp
, 1, 1);
1938 gfc_add_expr_to_block (block
, tmp
);
1941 gfc_add_modify_expr (block
, count1
, gfc_index_zero_node
);
1943 /* Reset maskindexed. */
1944 forall_tmp
= nested_forall_info
;
1945 while (forall_tmp
!= NULL
)
1947 mask
= forall_tmp
->mask
;
1948 maskindex
= forall_tmp
->maskindex
;
1950 gfc_add_modify_expr (block
, maskindex
, gfc_index_zero_node
);
1951 forall_tmp
= forall_tmp
->next_nest
;
1956 gfc_add_modify_expr (block
, count
, gfc_index_zero_node
);
1958 /* Generate codes to copy the temporary to lhs. */
1959 tmp
= generate_loop_for_temp_to_lhs (expr1
, tmp1
, inner_size
, count
,
1960 count1
, count2
, wheremask
);
1962 /* Generate body and loops according to the information in
1963 nested_forall_info. */
1964 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, tmp
, 1, 1);
1965 gfc_add_expr_to_block (block
, tmp
);
1969 /* Free the temporary. */
1970 tmp
= gfc_chainon_list (NULL_TREE
, ptemp1
);
1971 tmp
= gfc_build_function_call (gfor_fndecl_internal_free
, tmp
);
1972 gfc_add_expr_to_block (block
, tmp
);
1977 /* Translate pointer assignment inside FORALL which need temporary. */
1980 gfc_trans_pointer_assign_need_temp (gfc_expr
* expr1
, gfc_expr
* expr2
,
1981 forall_info
* nested_forall_info
,
1982 stmtblock_t
* block
)
1996 tree tmp
, tmp1
, ptemp1
;
1997 tree mask
, maskindex
;
1998 forall_info
*forall_tmp
;
2000 count
= gfc_create_var (gfc_array_index_type
, "count");
2001 gfc_add_modify_expr (block
, count
, gfc_index_zero_node
);
2003 inner_size
= integer_one_node
;
2004 lss
= gfc_walk_expr (expr1
);
2005 rss
= gfc_walk_expr (expr2
);
2006 if (lss
== gfc_ss_terminator
)
2008 type
= gfc_typenode_for_spec (&expr1
->ts
);
2009 type
= build_pointer_type (type
);
2011 /* Allocate temporary for nested forall construct according to the
2012 information in nested_forall_info and inner_size. */
2013 tmp1
= allocate_temp_for_forall_nest (nested_forall_info
,
2014 type
, inner_size
, block
, &ptemp1
);
2015 gfc_start_block (&body
);
2016 gfc_init_se (&lse
, NULL
);
2017 lse
.expr
= gfc_build_array_ref (tmp1
, count
);
2018 gfc_init_se (&rse
, NULL
);
2019 rse
.want_pointer
= 1;
2020 gfc_conv_expr (&rse
, expr2
);
2021 gfc_add_block_to_block (&body
, &rse
.pre
);
2022 gfc_add_modify_expr (&body
, lse
.expr
, rse
.expr
);
2023 gfc_add_block_to_block (&body
, &rse
.post
);
2025 /* Increment count. */
2026 tmp
= fold (build2 (PLUS_EXPR
, gfc_array_index_type
,
2027 count
, gfc_index_one_node
));
2028 gfc_add_modify_expr (&body
, count
, tmp
);
2030 tmp
= gfc_finish_block (&body
);
2032 /* Initialize the maskindexes. */
2033 forall_tmp
= nested_forall_info
;
2034 while (forall_tmp
!= NULL
)
2036 mask
= forall_tmp
->mask
;
2037 maskindex
= forall_tmp
->maskindex
;
2039 gfc_add_modify_expr (block
, maskindex
, gfc_index_zero_node
);
2040 forall_tmp
= forall_tmp
->next_nest
;
2043 /* Generate body and loops according to the information in
2044 nested_forall_info. */
2045 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, tmp
, 1, 1);
2046 gfc_add_expr_to_block (block
, tmp
);
2049 gfc_add_modify_expr (block
, count
, gfc_index_zero_node
);
2051 /* Reset maskindexes. */
2052 forall_tmp
= nested_forall_info
;
2053 while (forall_tmp
!= NULL
)
2055 mask
= forall_tmp
->mask
;
2056 maskindex
= forall_tmp
->maskindex
;
2058 gfc_add_modify_expr (block
, maskindex
, gfc_index_zero_node
);
2059 forall_tmp
= forall_tmp
->next_nest
;
2061 gfc_start_block (&body
);
2062 gfc_init_se (&lse
, NULL
);
2063 gfc_init_se (&rse
, NULL
);
2064 rse
.expr
= gfc_build_array_ref (tmp1
, count
);
2065 lse
.want_pointer
= 1;
2066 gfc_conv_expr (&lse
, expr1
);
2067 gfc_add_block_to_block (&body
, &lse
.pre
);
2068 gfc_add_modify_expr (&body
, lse
.expr
, rse
.expr
);
2069 gfc_add_block_to_block (&body
, &lse
.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
);
2074 tmp
= gfc_finish_block (&body
);
2076 /* Generate body and loops according to the information in
2077 nested_forall_info. */
2078 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, tmp
, 1, 1);
2079 gfc_add_expr_to_block (block
, tmp
);
2083 gfc_init_loopinfo (&loop
);
2085 /* Associate the SS with the loop. */
2086 gfc_add_ss_to_loop (&loop
, rss
);
2088 /* Setup the scalarizing loops and bounds. */
2089 gfc_conv_ss_startstride (&loop
);
2091 gfc_conv_loop_setup (&loop
);
2093 info
= &rss
->data
.info
;
2094 desc
= info
->descriptor
;
2096 /* Make a new descriptor. */
2097 parmtype
= gfc_get_element_type (TREE_TYPE (desc
));
2098 parmtype
= gfc_get_array_type_bounds (parmtype
, loop
.dimen
,
2099 loop
.from
, loop
.to
, 1);
2101 /* Allocate temporary for nested forall construct. */
2102 tmp1
= allocate_temp_for_forall_nest (nested_forall_info
, parmtype
,
2103 inner_size
, block
, &ptemp1
);
2104 gfc_start_block (&body
);
2105 gfc_init_se (&lse
, NULL
);
2106 lse
.expr
= gfc_build_array_ref (tmp1
, count
);
2107 lse
.direct_byref
= 1;
2108 rss
= gfc_walk_expr (expr2
);
2109 gfc_conv_expr_descriptor (&lse
, expr2
, rss
);
2111 gfc_add_block_to_block (&body
, &lse
.pre
);
2112 gfc_add_block_to_block (&body
, &lse
.post
);
2114 /* Increment count. */
2115 tmp
= fold (build2 (PLUS_EXPR
, gfc_array_index_type
,
2116 count
, gfc_index_one_node
));
2117 gfc_add_modify_expr (&body
, count
, tmp
);
2119 tmp
= gfc_finish_block (&body
);
2121 /* Initialize the maskindexes. */
2122 forall_tmp
= nested_forall_info
;
2123 while (forall_tmp
!= NULL
)
2125 mask
= forall_tmp
->mask
;
2126 maskindex
= forall_tmp
->maskindex
;
2128 gfc_add_modify_expr (block
, maskindex
, gfc_index_zero_node
);
2129 forall_tmp
= forall_tmp
->next_nest
;
2132 /* Generate body and loops according to the information in
2133 nested_forall_info. */
2134 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, tmp
, 1, 1);
2135 gfc_add_expr_to_block (block
, tmp
);
2138 gfc_add_modify_expr (block
, count
, gfc_index_zero_node
);
2140 /* Reset maskindexes. */
2141 forall_tmp
= nested_forall_info
;
2142 while (forall_tmp
!= NULL
)
2144 mask
= forall_tmp
->mask
;
2145 maskindex
= forall_tmp
->maskindex
;
2147 gfc_add_modify_expr (block
, maskindex
, gfc_index_zero_node
);
2148 forall_tmp
= forall_tmp
->next_nest
;
2150 parm
= gfc_build_array_ref (tmp1
, count
);
2151 lss
= gfc_walk_expr (expr1
);
2152 gfc_init_se (&lse
, NULL
);
2153 gfc_conv_expr_descriptor (&lse
, expr1
, lss
);
2154 gfc_add_modify_expr (&lse
.pre
, lse
.expr
, parm
);
2155 gfc_start_block (&body
);
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 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, tmp
, 1, 1);
2167 gfc_add_expr_to_block (block
, tmp
);
2169 /* Free the temporary. */
2172 tmp
= gfc_chainon_list (NULL_TREE
, ptemp1
);
2173 tmp
= gfc_build_function_call (gfor_fndecl_internal_free
, tmp
);
2174 gfc_add_expr_to_block (block
, tmp
);
2179 /* FORALL and WHERE statements are really nasty, especially when you nest
2180 them. All the rhs of a forall assignment must be evaluated before the
2181 actual assignments are performed. Presumably this also applies to all the
2182 assignments in an inner where statement. */
2184 /* Generate code for a FORALL statement. Any temporaries are allocated as a
2185 linear array, relying on the fact that we process in the same order in all
2188 forall (i=start:end:stride; maskexpr)
2192 (where e,f,g,h<i> are arbitary expressions possibly involving i)
2194 count = ((end + 1 - start) / staride)
2195 masktmp(:) = maskexpr(:)
2198 for (i = start; i <= end; i += stride)
2200 if (masktmp[maskindex++])
2204 for (i = start; i <= end; i += stride)
2206 if (masktmp[maskindex++])
2210 Note that this code only works when there are no dependencies.
2211 Forall loop with array assignments and data dependencies are a real pain,
2212 because the size of the temporary cannot always be determined before the
2213 loop is executed. This problem is compounded by the presence of nested
2218 gfc_trans_forall_1 (gfc_code
* code
, forall_info
* nested_forall_info
)
2240 gfc_forall_iterator
*fa
;
2243 gfc_saved_var
*saved_vars
;
2244 iter_info
*this_forall
, *iter_tmp
;
2245 forall_info
*info
, *forall_tmp
;
2246 temporary_list
*temp
;
2248 gfc_start_block (&block
);
2251 /* Count the FORALL index number. */
2252 for (fa
= code
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
2256 /* Allocate the space for var, start, end, step, varexpr. */
2257 var
= (tree
*) gfc_getmem (nvar
* sizeof (tree
));
2258 start
= (tree
*) gfc_getmem (nvar
* sizeof (tree
));
2259 end
= (tree
*) gfc_getmem (nvar
* sizeof (tree
));
2260 step
= (tree
*) gfc_getmem (nvar
* sizeof (tree
));
2261 varexpr
= (gfc_expr
**) gfc_getmem (nvar
* sizeof (gfc_expr
*));
2262 saved_vars
= (gfc_saved_var
*) gfc_getmem (nvar
* sizeof (gfc_saved_var
));
2264 /* Allocate the space for info. */
2265 info
= (forall_info
*) gfc_getmem (sizeof (forall_info
));
2267 for (fa
= code
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
2269 gfc_symbol
*sym
= fa
->var
->symtree
->n
.sym
;
2271 /* allocate space for this_forall. */
2272 this_forall
= (iter_info
*) gfc_getmem (sizeof (iter_info
));
2274 /* Create a temporary variable for the FORALL index. */
2275 tmp
= gfc_typenode_for_spec (&sym
->ts
);
2276 var
[n
] = gfc_create_var (tmp
, sym
->name
);
2277 gfc_shadow_sym (sym
, var
[n
], &saved_vars
[n
]);
2279 /* Record it in this_forall. */
2280 this_forall
->var
= var
[n
];
2282 /* Replace the index symbol's backend_decl with the temporary decl. */
2283 sym
->backend_decl
= var
[n
];
2285 /* Work out the start, end and stride for the loop. */
2286 gfc_init_se (&se
, NULL
);
2287 gfc_conv_expr_val (&se
, fa
->start
);
2288 /* Record it in this_forall. */
2289 this_forall
->start
= se
.expr
;
2290 gfc_add_block_to_block (&block
, &se
.pre
);
2293 gfc_init_se (&se
, NULL
);
2294 gfc_conv_expr_val (&se
, fa
->end
);
2295 /* Record it in this_forall. */
2296 this_forall
->end
= se
.expr
;
2297 gfc_make_safe_expr (&se
);
2298 gfc_add_block_to_block (&block
, &se
.pre
);
2301 gfc_init_se (&se
, NULL
);
2302 gfc_conv_expr_val (&se
, fa
->stride
);
2303 /* Record it in this_forall. */
2304 this_forall
->step
= se
.expr
;
2305 gfc_make_safe_expr (&se
);
2306 gfc_add_block_to_block (&block
, &se
.pre
);
2309 /* Set the NEXT field of this_forall to NULL. */
2310 this_forall
->next
= NULL
;
2311 /* Link this_forall to the info construct. */
2312 if (info
->this_loop
== NULL
)
2313 info
->this_loop
= this_forall
;
2316 iter_tmp
= info
->this_loop
;
2317 while (iter_tmp
->next
!= NULL
)
2318 iter_tmp
= iter_tmp
->next
;
2319 iter_tmp
->next
= this_forall
;
2326 /* Work out the number of elements in the mask array. */
2329 size
= gfc_index_one_node
;
2330 sizevar
= NULL_TREE
;
2332 for (n
= 0; n
< nvar
; n
++)
2334 if (lenvar
&& TREE_TYPE (lenvar
) != TREE_TYPE (start
[n
]))
2337 /* size = (end + step - start) / step. */
2338 tmp
= fold (build2 (MINUS_EXPR
, TREE_TYPE (start
[n
]),
2339 step
[n
], start
[n
]));
2340 tmp
= fold (build2 (PLUS_EXPR
, TREE_TYPE (end
[n
]), end
[n
], tmp
));
2342 tmp
= fold (build2 (FLOOR_DIV_EXPR
, TREE_TYPE (tmp
), tmp
, step
[n
]));
2343 tmp
= convert (gfc_array_index_type
, tmp
);
2345 size
= fold (build2 (MULT_EXPR
, gfc_array_index_type
, size
, tmp
));
2348 /* Record the nvar and size of current forall level. */
2352 /* Link the current forall level to nested_forall_info. */
2353 forall_tmp
= nested_forall_info
;
2354 if (forall_tmp
== NULL
)
2355 nested_forall_info
= info
;
2358 while (forall_tmp
->next_nest
!= NULL
)
2359 forall_tmp
= forall_tmp
->next_nest
;
2360 info
->outer
= forall_tmp
;
2361 forall_tmp
->next_nest
= info
;
2364 /* Copy the mask into a temporary variable if required.
2365 For now we assume a mask temporary is needed. */
2368 /* Allocate the mask temporary. */
2369 bytesize
= fold (build2 (MULT_EXPR
, gfc_array_index_type
, size
,
2370 TYPE_SIZE_UNIT (boolean_type_node
)));
2372 mask
= gfc_do_allocate (bytesize
, size
, &pmask
, &block
, boolean_type_node
);
2374 maskindex
= gfc_create_var_np (gfc_array_index_type
, "mi");
2375 /* Record them in the info structure. */
2376 info
->pmask
= pmask
;
2378 info
->maskindex
= maskindex
;
2380 gfc_add_modify_expr (&block
, maskindex
, gfc_index_zero_node
);
2382 /* Start of mask assignment loop body. */
2383 gfc_start_block (&body
);
2385 /* Evaluate the mask expression. */
2386 gfc_init_se (&se
, NULL
);
2387 gfc_conv_expr_val (&se
, code
->expr
);
2388 gfc_add_block_to_block (&body
, &se
.pre
);
2390 /* Store the mask. */
2391 se
.expr
= convert (boolean_type_node
, se
.expr
);
2394 tmp
= gfc_build_indirect_ref (mask
);
2397 tmp
= gfc_build_array_ref (tmp
, maskindex
);
2398 gfc_add_modify_expr (&body
, tmp
, se
.expr
);
2400 /* Advance to the next mask element. */
2401 tmp
= build2 (PLUS_EXPR
, gfc_array_index_type
,
2402 maskindex
, gfc_index_one_node
);
2403 gfc_add_modify_expr (&body
, maskindex
, tmp
);
2405 /* Generate the loops. */
2406 tmp
= gfc_finish_block (&body
);
2407 tmp
= gfc_trans_nested_forall_loop (info
, tmp
, 0, 0);
2408 gfc_add_expr_to_block (&block
, tmp
);
2412 /* No mask was specified. */
2413 maskindex
= NULL_TREE
;
2414 mask
= pmask
= NULL_TREE
;
2417 c
= code
->block
->next
;
2419 /* TODO: loop merging in FORALL statements. */
2420 /* Now that we've got a copy of the mask, generate the assignment loops. */
2426 /* A scalar or array assignment. */
2427 need_temp
= gfc_check_dependency (c
->expr
, c
->expr2
, varexpr
, nvar
);
2428 /* Teporaries due to array assignment data dependencies introduce
2429 no end of problems. */
2431 gfc_trans_assign_need_temp (c
->expr
, c
->expr2
, NULL
,
2432 nested_forall_info
, &block
);
2435 /* Use the normal assignment copying routines. */
2436 assign
= gfc_trans_assignment (c
->expr
, c
->expr2
);
2438 /* Reset the mask index. */
2440 gfc_add_modify_expr (&block
, maskindex
, gfc_index_zero_node
);
2442 /* Generate body and loops. */
2443 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, assign
, 1, 1);
2444 gfc_add_expr_to_block (&block
, tmp
);
2451 /* Translate WHERE or WHERE construct nested in FORALL. */
2453 gfc_trans_where_2 (c
, NULL
, NULL
, nested_forall_info
, &block
, &temp
);
2460 /* Free the temporary. */
2461 args
= gfc_chainon_list (NULL_TREE
, temp
->temporary
);
2462 tmp
= gfc_build_function_call (gfor_fndecl_internal_free
, args
);
2463 gfc_add_expr_to_block (&block
, tmp
);
2472 /* Pointer assignment inside FORALL. */
2473 case EXEC_POINTER_ASSIGN
:
2474 need_temp
= gfc_check_dependency (c
->expr
, c
->expr2
, varexpr
, nvar
);
2476 gfc_trans_pointer_assign_need_temp (c
->expr
, c
->expr2
,
2477 nested_forall_info
, &block
);
2480 /* Use the normal assignment copying routines. */
2481 assign
= gfc_trans_pointer_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
,
2490 gfc_add_expr_to_block (&block
, tmp
);
2495 tmp
= gfc_trans_forall_1 (c
, nested_forall_info
);
2496 gfc_add_expr_to_block (&block
, tmp
);
2506 /* Restore the original index variables. */
2507 for (fa
= code
->ext
.forall_iterator
, n
= 0; fa
; fa
= fa
->next
, n
++)
2508 gfc_restore_sym (fa
->var
->symtree
->n
.sym
, &saved_vars
[n
]);
2510 /* Free the space for var, start, end, step, varexpr. */
2516 gfc_free (saved_vars
);
2520 /* Free the temporary for the mask. */
2521 tmp
= gfc_chainon_list (NULL_TREE
, pmask
);
2522 tmp
= gfc_build_function_call (gfor_fndecl_internal_free
, tmp
);
2523 gfc_add_expr_to_block (&block
, tmp
);
2526 pushdecl (maskindex
);
2528 return gfc_finish_block (&block
);
2532 /* Translate the FORALL statement or construct. */
2534 tree
gfc_trans_forall (gfc_code
* code
)
2536 return gfc_trans_forall_1 (code
, NULL
);
2540 /* Evaluate the WHERE mask expression, copy its value to a temporary.
2541 If the WHERE construct is nested in FORALL, compute the overall temporary
2542 needed by the WHERE mask expression multiplied by the iterator number of
2544 ME is the WHERE mask expression.
2545 MASK is the temporary which value is mask's value.
2546 NMASK is another temporary which value is !mask.
2547 TEMP records the temporary's address allocated in this function in order to
2548 free them outside this function.
2549 MASK, NMASK and TEMP are all OUT arguments. */
2552 gfc_evaluate_where_mask (gfc_expr
* me
, forall_info
* nested_forall_info
,
2553 tree
* mask
, tree
* nmask
, temporary_list
** temp
,
2554 stmtblock_t
* block
)
2559 tree ptemp1
, ntmp
, ptemp2
;
2561 stmtblock_t body
, body1
;
2566 gfc_init_loopinfo (&loop
);
2568 /* Calculate the size of temporary needed by the mask-expr. */
2569 inner_size
= compute_inner_temp_size (me
, me
, block
, &lss
, &rss
);
2571 /* Allocate temporary for where mask. */
2572 tmp
= allocate_temp_for_forall_nest (nested_forall_info
, boolean_type_node
,
2573 inner_size
, block
, &ptemp1
);
2574 /* Record the temporary address in order to free it later. */
2577 temporary_list
*tempo
;
2578 tempo
= (temporary_list
*) gfc_getmem (sizeof (temporary_list
));
2579 tempo
->temporary
= ptemp1
;
2580 tempo
->next
= *temp
;
2584 /* Allocate temporary for !mask. */
2585 ntmp
= allocate_temp_for_forall_nest (nested_forall_info
, boolean_type_node
,
2586 inner_size
, block
, &ptemp2
);
2587 /* Record the temporary in order to free it later. */
2590 temporary_list
*tempo
;
2591 tempo
= (temporary_list
*) gfc_getmem (sizeof (temporary_list
));
2592 tempo
->temporary
= ptemp2
;
2593 tempo
->next
= *temp
;
2597 /* Variable to index the temporary. */
2598 count
= gfc_create_var (gfc_array_index_type
, "count");
2599 /* Initialize count. */
2600 gfc_add_modify_expr (block
, count
, gfc_index_zero_node
);
2602 gfc_start_block (&body
);
2604 gfc_init_se (&rse
, NULL
);
2605 gfc_init_se (&lse
, NULL
);
2607 if (lss
== gfc_ss_terminator
)
2609 gfc_init_block (&body1
);
2613 /* Initialize the loop. */
2614 gfc_init_loopinfo (&loop
);
2616 /* We may need LSS to determine the shape of the expression. */
2617 gfc_add_ss_to_loop (&loop
, lss
);
2618 gfc_add_ss_to_loop (&loop
, rss
);
2620 gfc_conv_ss_startstride (&loop
);
2621 gfc_conv_loop_setup (&loop
);
2623 gfc_mark_ss_chain_used (rss
, 1);
2624 /* Start the loop body. */
2625 gfc_start_scalarized_body (&loop
, &body1
);
2627 /* Translate the expression. */
2628 gfc_copy_loopinfo_to_se (&rse
, &loop
);
2630 gfc_conv_expr (&rse
, me
);
2632 /* Form the expression of the temporary. */
2633 lse
.expr
= gfc_build_array_ref (tmp
, count
);
2634 tmpexpr
= gfc_build_array_ref (ntmp
, count
);
2636 /* Use the scalar assignment to fill temporary TMP. */
2637 tmp1
= gfc_trans_scalar_assign (&lse
, &rse
, me
->ts
.type
);
2638 gfc_add_expr_to_block (&body1
, tmp1
);
2640 /* Fill temporary NTMP. */
2641 tmp1
= build1 (TRUTH_NOT_EXPR
, TREE_TYPE (lse
.expr
), lse
.expr
);
2642 gfc_add_modify_expr (&body1
, tmpexpr
, tmp1
);
2644 if (lss
== gfc_ss_terminator
)
2646 gfc_add_block_to_block (&body
, &body1
);
2650 /* Increment count. */
2651 tmp1
= fold (build2 (PLUS_EXPR
, gfc_array_index_type
, count
,
2652 gfc_index_one_node
));
2653 gfc_add_modify_expr (&body1
, count
, tmp1
);
2655 /* Generate the copying loops. */
2656 gfc_trans_scalarizing_loops (&loop
, &body1
);
2658 gfc_add_block_to_block (&body
, &loop
.pre
);
2659 gfc_add_block_to_block (&body
, &loop
.post
);
2661 gfc_cleanup_loop (&loop
);
2662 /* TODO: Reuse lss and rss when copying temp->lhs. Need to be careful
2663 as tree nodes in SS may not be valid in different scope. */
2666 tmp1
= gfc_finish_block (&body
);
2667 /* If the WHERE construct is inside FORALL, fill the full temporary. */
2668 if (nested_forall_info
!= NULL
)
2669 tmp1
= gfc_trans_nested_forall_loop (nested_forall_info
, tmp1
, 1, 1);
2672 gfc_add_expr_to_block (block
, tmp1
);
2681 /* Translate an assignment statement in a WHERE statement or construct
2682 statement. The MASK expression is used to control which elements
2683 of EXPR1 shall be assigned. */
2686 gfc_trans_where_assign (gfc_expr
*expr1
, gfc_expr
*expr2
, tree mask
,
2687 tree count1
, tree count2
)
2692 gfc_ss
*lss_section
;
2699 tree index
, maskexpr
, tmp1
;
2702 /* TODO: handle this special case.
2703 Special case a single function returning an array. */
2704 if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->rank
> 0)
2706 tmp
= gfc_trans_arrayfunc_assign (expr1
, expr2
);
2712 /* Assignment of the form lhs = rhs. */
2713 gfc_start_block (&block
);
2715 gfc_init_se (&lse
, NULL
);
2716 gfc_init_se (&rse
, NULL
);
2719 lss
= gfc_walk_expr (expr1
);
2722 /* In each where-assign-stmt, the mask-expr and the variable being
2723 defined shall be arrays of the same shape. */
2724 gcc_assert (lss
!= gfc_ss_terminator
);
2726 /* The assignment needs scalarization. */
2729 /* Find a non-scalar SS from the lhs. */
2730 while (lss_section
!= gfc_ss_terminator
2731 && lss_section
->type
!= GFC_SS_SECTION
)
2732 lss_section
= lss_section
->next
;
2734 gcc_assert (lss_section
!= gfc_ss_terminator
);
2736 /* Initialize the scalarizer. */
2737 gfc_init_loopinfo (&loop
);
2740 rss
= gfc_walk_expr (expr2
);
2741 if (rss
== gfc_ss_terminator
)
2743 /* The rhs is scalar. Add a ss for the expression. */
2744 rss
= gfc_get_ss ();
2745 rss
->next
= gfc_ss_terminator
;
2746 rss
->type
= GFC_SS_SCALAR
;
2750 /* Associate the SS with the loop. */
2751 gfc_add_ss_to_loop (&loop
, lss
);
2752 gfc_add_ss_to_loop (&loop
, rss
);
2754 /* Calculate the bounds of the scalarization. */
2755 gfc_conv_ss_startstride (&loop
);
2757 /* Resolve any data dependencies in the statement. */
2758 gfc_conv_resolve_dependencies (&loop
, lss_section
, rss
);
2760 /* Setup the scalarizing loops. */
2761 gfc_conv_loop_setup (&loop
);
2763 /* Setup the gfc_se structures. */
2764 gfc_copy_loopinfo_to_se (&lse
, &loop
);
2765 gfc_copy_loopinfo_to_se (&rse
, &loop
);
2768 gfc_mark_ss_chain_used (rss
, 1);
2769 if (loop
.temp_ss
== NULL
)
2772 gfc_mark_ss_chain_used (lss
, 1);
2776 lse
.ss
= loop
.temp_ss
;
2777 gfc_mark_ss_chain_used (lss
, 3);
2778 gfc_mark_ss_chain_used (loop
.temp_ss
, 3);
2781 /* Start the scalarized loop body. */
2782 gfc_start_scalarized_body (&loop
, &body
);
2784 /* Translate the expression. */
2785 gfc_conv_expr (&rse
, expr2
);
2786 if (lss
!= gfc_ss_terminator
&& loop
.temp_ss
!= NULL
)
2788 gfc_conv_tmp_array_ref (&lse
);
2789 gfc_advance_se_ss_chain (&lse
);
2792 gfc_conv_expr (&lse
, expr1
);
2794 /* Form the mask expression according to the mask tree list. */
2798 maskexpr
= gfc_build_array_ref (tmp
, index
);
2802 tmp
= TREE_CHAIN (tmp
);
2805 tmp1
= gfc_build_array_ref (tmp
, index
);
2806 maskexpr
= build2 (TRUTH_AND_EXPR
, TREE_TYPE (tmp1
), maskexpr
, tmp1
);
2807 tmp
= TREE_CHAIN (tmp
);
2809 /* Use the scalar assignment as is. */
2810 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
.type
);
2811 tmp
= build3_v (COND_EXPR
, maskexpr
, tmp
, build_empty_stmt ());
2813 gfc_add_expr_to_block (&body
, tmp
);
2815 if (lss
== gfc_ss_terminator
)
2817 /* Increment count1. */
2818 tmp
= fold (build2 (PLUS_EXPR
, gfc_array_index_type
,
2819 count1
, gfc_index_one_node
));
2820 gfc_add_modify_expr (&body
, count1
, tmp
);
2822 /* Use the scalar assignment as is. */
2823 gfc_add_block_to_block (&block
, &body
);
2827 gcc_assert (lse
.ss
== gfc_ss_terminator
2828 && rse
.ss
== gfc_ss_terminator
);
2830 if (loop
.temp_ss
!= NULL
)
2832 /* Increment count1 before finish the main body of a scalarized
2834 tmp
= fold (build2 (PLUS_EXPR
, gfc_array_index_type
,
2835 count1
, gfc_index_one_node
));
2836 gfc_add_modify_expr (&body
, count1
, tmp
);
2837 gfc_trans_scalarized_loop_boundary (&loop
, &body
);
2839 /* We need to copy the temporary to the actual lhs. */
2840 gfc_init_se (&lse
, NULL
);
2841 gfc_init_se (&rse
, NULL
);
2842 gfc_copy_loopinfo_to_se (&lse
, &loop
);
2843 gfc_copy_loopinfo_to_se (&rse
, &loop
);
2845 rse
.ss
= loop
.temp_ss
;
2848 gfc_conv_tmp_array_ref (&rse
);
2849 gfc_advance_se_ss_chain (&rse
);
2850 gfc_conv_expr (&lse
, expr1
);
2852 gcc_assert (lse
.ss
== gfc_ss_terminator
2853 && rse
.ss
== gfc_ss_terminator
);
2855 /* Form the mask expression according to the mask tree list. */
2859 maskexpr
= gfc_build_array_ref (tmp
, index
);
2863 tmp
= TREE_CHAIN (tmp
);
2866 tmp1
= gfc_build_array_ref (tmp
, index
);
2867 maskexpr
= build2 (TRUTH_AND_EXPR
, TREE_TYPE (tmp1
),
2869 tmp
= TREE_CHAIN (tmp
);
2871 /* Use the scalar assignment as is. */
2872 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
.type
);
2873 tmp
= build3_v (COND_EXPR
, maskexpr
, tmp
, build_empty_stmt ());
2874 gfc_add_expr_to_block (&body
, tmp
);
2876 /* Increment count2. */
2877 tmp
= fold (build2 (PLUS_EXPR
, gfc_array_index_type
,
2878 count2
, gfc_index_one_node
));
2879 gfc_add_modify_expr (&body
, count2
, tmp
);
2883 /* Increment count1. */
2884 tmp
= fold (build2 (PLUS_EXPR
, gfc_array_index_type
,
2885 count1
, gfc_index_one_node
));
2886 gfc_add_modify_expr (&body
, count1
, tmp
);
2889 /* Generate the copying loops. */
2890 gfc_trans_scalarizing_loops (&loop
, &body
);
2892 /* Wrap the whole thing up. */
2893 gfc_add_block_to_block (&block
, &loop
.pre
);
2894 gfc_add_block_to_block (&block
, &loop
.post
);
2895 gfc_cleanup_loop (&loop
);
2898 return gfc_finish_block (&block
);
2902 /* Translate the WHERE construct or statement.
2903 This fuction can be called iteratively to translate the nested WHERE
2904 construct or statement.
2905 MASK is the control mask, and PMASK is the pending control mask.
2906 TEMP records the temporary address which must be freed later. */
2909 gfc_trans_where_2 (gfc_code
* code
, tree mask
, tree pmask
,
2910 forall_info
* nested_forall_info
, stmtblock_t
* block
,
2911 temporary_list
** temp
)
2917 tree tmp
, tmp1
, tmp2
;
2918 tree count1
, count2
;
2922 /* the WHERE statement or the WHERE construct statement. */
2923 cblock
= code
->block
;
2926 /* Has mask-expr. */
2929 /* Ensure that the WHERE mask be evaluated only once. */
2930 tmp2
= gfc_evaluate_where_mask (cblock
->expr
, nested_forall_info
,
2931 &tmp
, &tmp1
, temp
, block
);
2933 /* Set the control mask and the pending control mask. */
2934 /* It's a where-stmt. */
2940 /* It's a nested where-stmt. */
2941 else if (mask
&& pmask
== NULL
)
2944 /* Use the TREE_CHAIN to list the masks. */
2945 tmp2
= copy_list (mask
);
2946 pmask
= chainon (mask
, tmp1
);
2947 mask
= chainon (tmp2
, tmp
);
2949 /* It's a masked-elsewhere-stmt. */
2950 else if (mask
&& cblock
->expr
)
2953 tmp2
= copy_list (pmask
);
2956 tmp2
= chainon (tmp2
, tmp
);
2957 pmask
= chainon (mask
, tmp1
);
2961 /* It's a elsewhere-stmt. No mask-expr is present. */
2965 /* Get the assignment statement of a WHERE statement, or the first
2966 statement in where-body-construct of a WHERE construct. */
2967 cnext
= cblock
->next
;
2972 /* WHERE assignment statement. */
2974 expr1
= cnext
->expr
;
2975 expr2
= cnext
->expr2
;
2976 if (nested_forall_info
!= NULL
)
2981 nvar
= nested_forall_info
->nvar
;
2982 varexpr
= (gfc_expr
**)
2983 gfc_getmem (nvar
* sizeof (gfc_expr
*));
2984 need_temp
= gfc_check_dependency (expr1
, expr2
, varexpr
,
2987 gfc_trans_assign_need_temp (expr1
, expr2
, mask
,
2988 nested_forall_info
, block
);
2991 /* Variables to control maskexpr. */
2992 count1
= gfc_create_var (gfc_array_index_type
, "count1");
2993 count2
= gfc_create_var (gfc_array_index_type
, "count2");
2994 gfc_add_modify_expr (block
, count1
, gfc_index_zero_node
);
2995 gfc_add_modify_expr (block
, count2
, gfc_index_zero_node
);
2997 tmp
= gfc_trans_where_assign (expr1
, expr2
, mask
, count1
,
2999 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
,
3001 gfc_add_expr_to_block (block
, tmp
);
3006 /* Variables to control maskexpr. */
3007 count1
= gfc_create_var (gfc_array_index_type
, "count1");
3008 count2
= gfc_create_var (gfc_array_index_type
, "count2");
3009 gfc_add_modify_expr (block
, count1
, gfc_index_zero_node
);
3010 gfc_add_modify_expr (block
, count2
, gfc_index_zero_node
);
3012 tmp
= gfc_trans_where_assign (expr1
, expr2
, mask
, count1
,
3014 gfc_add_expr_to_block (block
, tmp
);
3019 /* WHERE or WHERE construct is part of a where-body-construct. */
3021 /* Ensure that MASK is not modified by next gfc_trans_where_2. */
3022 mask_copy
= copy_list (mask
);
3023 gfc_trans_where_2 (cnext
, mask_copy
, NULL
, nested_forall_info
,
3031 /* The next statement within the same where-body-construct. */
3032 cnext
= cnext
->next
;
3034 /* The next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt. */
3035 cblock
= cblock
->block
;
3040 /* As the WHERE or WHERE construct statement can be nested, we call
3041 gfc_trans_where_2 to do the translation, and pass the initial
3042 NULL values for both the control mask and the pending control mask. */
3045 gfc_trans_where (gfc_code
* code
)
3048 temporary_list
*temp
, *p
;
3052 gfc_start_block (&block
);
3055 gfc_trans_where_2 (code
, NULL
, NULL
, NULL
, &block
, &temp
);
3057 /* Add calls to free temporaries which were dynamically allocated. */
3060 args
= gfc_chainon_list (NULL_TREE
, temp
->temporary
);
3061 tmp
= gfc_build_function_call (gfor_fndecl_internal_free
, args
);
3062 gfc_add_expr_to_block (&block
, tmp
);
3068 return gfc_finish_block (&block
);
3072 /* CYCLE a DO loop. The label decl has already been created by
3073 gfc_trans_do(), it's in TREE_PURPOSE (backend_decl) of the gfc_code
3074 node at the head of the loop. We must mark the label as used. */
3077 gfc_trans_cycle (gfc_code
* code
)
3081 cycle_label
= TREE_PURPOSE (code
->ext
.whichloop
->backend_decl
);
3082 TREE_USED (cycle_label
) = 1;
3083 return build1_v (GOTO_EXPR
, cycle_label
);
3087 /* EXIT a DO loop. Similair to CYCLE, but now the label is in
3088 TREE_VALUE (backend_decl) of the gfc_code node at the head of the
3092 gfc_trans_exit (gfc_code
* code
)
3096 exit_label
= TREE_VALUE (code
->ext
.whichloop
->backend_decl
);
3097 TREE_USED (exit_label
) = 1;
3098 return build1_v (GOTO_EXPR
, exit_label
);
3102 /* Translate the ALLOCATE statement. */
3105 gfc_trans_allocate (gfc_code
* code
)
3118 if (!code
->ext
.alloc_list
)
3121 gfc_start_block (&block
);
3125 tree gfc_int4_type_node
= gfc_get_int_type (4);
3127 stat
= gfc_create_var (gfc_int4_type_node
, "stat");
3128 pstat
= gfc_build_addr_expr (NULL
, stat
);
3130 error_label
= gfc_build_label_decl (NULL_TREE
);
3131 TREE_USED (error_label
) = 1;
3135 pstat
= integer_zero_node
;
3136 stat
= error_label
= NULL_TREE
;
3140 for (al
= code
->ext
.alloc_list
; al
!= NULL
; al
= al
->next
)
3144 gfc_init_se (&se
, NULL
);
3145 gfc_start_block (&se
.pre
);
3147 se
.want_pointer
= 1;
3148 se
.descriptor_only
= 1;
3149 gfc_conv_expr (&se
, expr
);
3153 /* Find the last reference in the chain. */
3154 while (ref
&& ref
->next
!= NULL
)
3156 gcc_assert (ref
->type
!= REF_ARRAY
|| ref
->u
.ar
.type
== AR_ELEMENT
);
3160 if (ref
!= NULL
&& ref
->type
== REF_ARRAY
)
3163 gfc_array_allocate (&se
, ref
, pstat
);
3167 /* A scalar or derived type. */
3170 val
= gfc_create_var (ppvoid_type_node
, "ptr");
3171 tmp
= gfc_build_addr_expr (ppvoid_type_node
, se
.expr
);
3172 gfc_add_modify_expr (&se
.pre
, val
, tmp
);
3174 tmp
= TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (se
.expr
)));
3175 parm
= gfc_chainon_list (NULL_TREE
, val
);
3176 parm
= gfc_chainon_list (parm
, tmp
);
3177 parm
= gfc_chainon_list (parm
, pstat
);
3178 tmp
= gfc_build_function_call (gfor_fndecl_allocate
, parm
);
3179 gfc_add_expr_to_block (&se
.pre
, tmp
);
3183 tmp
= build1_v (GOTO_EXPR
, error_label
);
3185 build2 (NE_EXPR
, boolean_type_node
, stat
, integer_zero_node
);
3186 tmp
= build3_v (COND_EXPR
, parm
, tmp
, build_empty_stmt ());
3187 gfc_add_expr_to_block (&se
.pre
, tmp
);
3191 tmp
= gfc_finish_block (&se
.pre
);
3192 gfc_add_expr_to_block (&block
, tmp
);
3195 /* Assign the value to the status variable. */
3198 tmp
= build1_v (LABEL_EXPR
, error_label
);
3199 gfc_add_expr_to_block (&block
, tmp
);
3201 gfc_init_se (&se
, NULL
);
3202 gfc_conv_expr_lhs (&se
, code
->expr
);
3203 tmp
= convert (TREE_TYPE (se
.expr
), stat
);
3204 gfc_add_modify_expr (&block
, se
.expr
, tmp
);
3207 return gfc_finish_block (&block
);
3212 gfc_trans_deallocate (gfc_code
* code
)
3222 gfc_start_block (&block
);
3224 for (al
= code
->ext
.alloc_list
; al
!= NULL
; al
= al
->next
)
3227 gcc_assert (expr
->expr_type
== EXPR_VARIABLE
);
3229 gfc_init_se (&se
, NULL
);
3230 gfc_start_block (&se
.pre
);
3232 se
.want_pointer
= 1;
3233 se
.descriptor_only
= 1;
3234 gfc_conv_expr (&se
, expr
);
3236 if (expr
->symtree
->n
.sym
->attr
.dimension
)
3238 tmp
= gfc_array_deallocate (se
.expr
);
3239 gfc_add_expr_to_block (&se
.pre
, tmp
);
3243 type
= build_pointer_type (TREE_TYPE (se
.expr
));
3244 var
= gfc_create_var (type
, "ptr");
3245 tmp
= gfc_build_addr_expr (type
, se
.expr
);
3246 gfc_add_modify_expr (&se
.pre
, var
, tmp
);
3248 tmp
= gfc_chainon_list (NULL_TREE
, var
);
3249 tmp
= gfc_chainon_list (tmp
, integer_zero_node
);
3250 tmp
= gfc_build_function_call (gfor_fndecl_deallocate
, tmp
);
3251 gfc_add_expr_to_block (&se
.pre
, tmp
);
3253 tmp
= gfc_finish_block (&se
.pre
);
3254 gfc_add_expr_to_block (&block
, tmp
);
3257 return gfc_finish_block (&block
);