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.
621 TODO: Real type do variables. */
624 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_type (&se
, code
->ext
.iterator
->start
, type
);
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_type (&se
, code
->ext
.iterator
->end
, type
);
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_type (&se
, code
->ext
.iterator
->step
, type
);
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 tmp
= fold (build2 (TRUNC_DIV_EXPR
, type
, tmp
, step
));
677 count
= gfc_create_var (type
, "count");
678 gfc_add_modify_expr (&block
, count
, tmp
);
680 /* Initialize the DO variable: dovar = from. */
681 gfc_add_modify_expr (&block
, dovar
, from
);
684 gfc_start_block (&body
);
686 /* Cycle and exit statements are implemented with gotos. */
687 cycle_label
= gfc_build_label_decl (NULL_TREE
);
688 exit_label
= gfc_build_label_decl (NULL_TREE
);
690 /* Start with the loop condition. Loop until count <= 0. */
691 cond
= build2 (LE_EXPR
, boolean_type_node
, count
, integer_zero_node
);
692 tmp
= build1_v (GOTO_EXPR
, exit_label
);
693 TREE_USED (exit_label
) = 1;
694 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt ());
695 gfc_add_expr_to_block (&body
, tmp
);
697 /* Put these labels where they can be found later. We put the
698 labels in a TREE_LIST node (because TREE_CHAIN is already
699 used). cycle_label goes in TREE_PURPOSE (backend_decl), exit
700 label in TREE_VALUE (backend_decl). */
702 code
->block
->backend_decl
= tree_cons (cycle_label
, exit_label
, NULL
);
704 /* Main loop body. */
705 tmp
= gfc_trans_code (code
->block
->next
);
706 gfc_add_expr_to_block (&body
, tmp
);
708 /* Label for cycle statements (if needed). */
709 if (TREE_USED (cycle_label
))
711 tmp
= build1_v (LABEL_EXPR
, cycle_label
);
712 gfc_add_expr_to_block (&body
, tmp
);
715 /* Increment the loop variable. */
716 tmp
= build2 (PLUS_EXPR
, type
, dovar
, step
);
717 gfc_add_modify_expr (&body
, dovar
, tmp
);
719 /* Decrement the loop count. */
720 tmp
= build2 (MINUS_EXPR
, type
, count
, gfc_index_one_node
);
721 gfc_add_modify_expr (&body
, count
, tmp
);
723 /* End of loop body. */
724 tmp
= gfc_finish_block (&body
);
726 /* The for loop itself. */
727 tmp
= build1_v (LOOP_EXPR
, tmp
);
728 gfc_add_expr_to_block (&block
, tmp
);
730 /* Add the exit label. */
731 tmp
= build1_v (LABEL_EXPR
, exit_label
);
732 gfc_add_expr_to_block (&block
, tmp
);
734 return gfc_finish_block (&block
);
738 /* Translate the DO WHILE construct.
751 if (! cond) goto exit_label;
757 Because the evaluation of the exit condition `cond' may have side
758 effects, we can't do much for empty loop bodies. The backend optimizers
759 should be smart enough to eliminate any dead loops. */
762 gfc_trans_do_while (gfc_code
* code
)
770 /* Everything we build here is part of the loop body. */
771 gfc_start_block (&block
);
773 /* Cycle and exit statements are implemented with gotos. */
774 cycle_label
= gfc_build_label_decl (NULL_TREE
);
775 exit_label
= gfc_build_label_decl (NULL_TREE
);
777 /* Put the labels where they can be found later. See gfc_trans_do(). */
778 code
->block
->backend_decl
= tree_cons (cycle_label
, exit_label
, NULL
);
780 /* Create a GIMPLE version of the exit condition. */
781 gfc_init_se (&cond
, NULL
);
782 gfc_conv_expr_val (&cond
, code
->expr
);
783 gfc_add_block_to_block (&block
, &cond
.pre
);
784 cond
.expr
= fold (build1 (TRUTH_NOT_EXPR
, boolean_type_node
, cond
.expr
));
786 /* Build "IF (! cond) GOTO exit_label". */
787 tmp
= build1_v (GOTO_EXPR
, exit_label
);
788 TREE_USED (exit_label
) = 1;
789 tmp
= build3_v (COND_EXPR
, cond
.expr
, tmp
, build_empty_stmt ());
790 gfc_add_expr_to_block (&block
, tmp
);
792 /* The main body of the loop. */
793 tmp
= gfc_trans_code (code
->block
->next
);
794 gfc_add_expr_to_block (&block
, tmp
);
796 /* Label for cycle statements (if needed). */
797 if (TREE_USED (cycle_label
))
799 tmp
= build1_v (LABEL_EXPR
, cycle_label
);
800 gfc_add_expr_to_block (&block
, tmp
);
803 /* End of loop body. */
804 tmp
= gfc_finish_block (&block
);
806 gfc_init_block (&block
);
807 /* Build the loop. */
808 tmp
= build1_v (LOOP_EXPR
, tmp
);
809 gfc_add_expr_to_block (&block
, tmp
);
811 /* Add the exit label. */
812 tmp
= build1_v (LABEL_EXPR
, exit_label
);
813 gfc_add_expr_to_block (&block
, tmp
);
815 return gfc_finish_block (&block
);
819 /* Translate the SELECT CASE construct for INTEGER case expressions,
820 without killing all potential optimizations. The problem is that
821 Fortran allows unbounded cases, but the back-end does not, so we
822 need to intercept those before we enter the equivalent SWITCH_EXPR
825 For example, we translate this,
828 CASE (:100,101,105:115)
838 to the GENERIC equivalent,
842 case (minimum value for typeof(expr) ... 100:
848 case 200 ... (maximum value for typeof(expr):
865 gfc_trans_integer_select (gfc_code
* code
)
875 gfc_start_block (&block
);
877 /* Calculate the switch expression. */
878 gfc_init_se (&se
, NULL
);
879 gfc_conv_expr_val (&se
, code
->expr
);
880 gfc_add_block_to_block (&block
, &se
.pre
);
882 end_label
= gfc_build_label_decl (NULL_TREE
);
884 gfc_init_block (&body
);
886 for (c
= code
->block
; c
; c
= c
->block
)
888 for (cp
= c
->ext
.case_list
; cp
; cp
= cp
->next
)
893 /* Assume it's the default case. */
894 low
= high
= NULL_TREE
;
898 low
= gfc_conv_constant_to_tree (cp
->low
);
900 /* If there's only a lower bound, set the high bound to the
901 maximum value of the case expression. */
903 high
= TYPE_MAX_VALUE (TREE_TYPE (se
.expr
));
908 /* Three cases are possible here:
910 1) There is no lower bound, e.g. CASE (:N).
911 2) There is a lower bound .NE. high bound, that is
912 a case range, e.g. CASE (N:M) where M>N (we make
913 sure that M>N during type resolution).
914 3) There is a lower bound, and it has the same value
915 as the high bound, e.g. CASE (N:N). This is our
916 internal representation of CASE(N).
918 In the first and second case, we need to set a value for
919 high. In the thirth case, we don't because the GCC middle
920 end represents a single case value by just letting high be
921 a NULL_TREE. We can't do that because we need to be able
922 to represent unbounded cases. */
926 && mpz_cmp (cp
->low
->value
.integer
,
927 cp
->high
->value
.integer
) != 0))
928 high
= gfc_conv_constant_to_tree (cp
->high
);
930 /* Unbounded case. */
932 low
= TYPE_MIN_VALUE (TREE_TYPE (se
.expr
));
936 label
= build_decl (LABEL_DECL
, NULL_TREE
, NULL_TREE
);
937 DECL_CONTEXT (label
) = current_function_decl
;
939 /* Add this case label.
940 Add parameter 'label', make it match GCC backend. */
941 tmp
= build3 (CASE_LABEL_EXPR
, void_type_node
, low
, high
, label
);
942 gfc_add_expr_to_block (&body
, tmp
);
945 /* Add the statements for this case. */
946 tmp
= gfc_trans_code (c
->next
);
947 gfc_add_expr_to_block (&body
, tmp
);
949 /* Break to the end of the construct. */
950 tmp
= build1_v (GOTO_EXPR
, end_label
);
951 gfc_add_expr_to_block (&body
, tmp
);
954 tmp
= gfc_finish_block (&body
);
955 tmp
= build3_v (SWITCH_EXPR
, se
.expr
, tmp
, NULL_TREE
);
956 gfc_add_expr_to_block (&block
, tmp
);
958 tmp
= build1_v (LABEL_EXPR
, end_label
);
959 gfc_add_expr_to_block (&block
, tmp
);
961 return gfc_finish_block (&block
);
965 /* Translate the SELECT CASE construct for LOGICAL case expressions.
967 There are only two cases possible here, even though the standard
968 does allow three cases in a LOGICAL SELECT CASE construct: .TRUE.,
969 .FALSE., and DEFAULT.
971 We never generate more than two blocks here. Instead, we always
972 try to eliminate the DEFAULT case. This way, we can translate this
973 kind of SELECT construct to a simple
977 expression in GENERIC. */
980 gfc_trans_logical_select (gfc_code
* code
)
988 /* Assume we don't have any cases at all. */
991 /* Now see which ones we actually do have. We can have at most two
992 cases in a single case list: one for .TRUE. and one for .FALSE.
993 The default case is always separate. If the cases for .TRUE. and
994 .FALSE. are in the same case list, the block for that case list
995 always executed, and we don't generate code a COND_EXPR. */
996 for (c
= code
->block
; c
; c
= c
->block
)
998 for (cp
= c
->ext
.case_list
; cp
; cp
= cp
->next
)
1002 if (cp
->low
->value
.logical
== 0) /* .FALSE. */
1004 else /* if (cp->value.logical != 0), thus .TRUE. */
1012 /* Start a new block. */
1013 gfc_start_block (&block
);
1015 /* Calculate the switch expression. We always need to do this
1016 because it may have side effects. */
1017 gfc_init_se (&se
, NULL
);
1018 gfc_conv_expr_val (&se
, code
->expr
);
1019 gfc_add_block_to_block (&block
, &se
.pre
);
1021 if (t
== f
&& t
!= NULL
)
1023 /* Cases for .TRUE. and .FALSE. are in the same block. Just
1024 translate the code for these cases, append it to the current
1026 gfc_add_expr_to_block (&block
, gfc_trans_code (t
->next
));
1030 tree true_tree
, false_tree
;
1032 true_tree
= build_empty_stmt ();
1033 false_tree
= build_empty_stmt ();
1035 /* If we have a case for .TRUE. and for .FALSE., discard the default case.
1036 Otherwise, if .TRUE. or .FALSE. is missing and there is a default case,
1037 make the missing case the default case. */
1038 if (t
!= NULL
&& f
!= NULL
)
1048 /* Translate the code for each of these blocks, and append it to
1049 the current block. */
1051 true_tree
= gfc_trans_code (t
->next
);
1054 false_tree
= gfc_trans_code (f
->next
);
1056 gfc_add_expr_to_block (&block
, build3_v (COND_EXPR
, se
.expr
,
1057 true_tree
, false_tree
));
1060 return gfc_finish_block (&block
);
1064 /* Translate the SELECT CASE construct for CHARACTER case expressions.
1065 Instead of generating compares and jumps, it is far simpler to
1066 generate a data structure describing the cases in order and call a
1067 library subroutine that locates the right case.
1068 This is particularly true because this is the only case where we
1069 might have to dispose of a temporary.
1070 The library subroutine returns a pointer to jump to or NULL if no
1071 branches are to be taken. */
1074 gfc_trans_character_select (gfc_code
*code
)
1076 tree init
, node
, end_label
, tmp
, type
, args
, *labels
;
1077 stmtblock_t block
, body
;
1083 static tree select_struct
;
1084 static tree ss_string1
, ss_string1_len
;
1085 static tree ss_string2
, ss_string2_len
;
1086 static tree ss_target
;
1088 if (select_struct
== NULL
)
1090 tree gfc_int4_type_node
= gfc_get_int_type (4);
1092 select_struct
= make_node (RECORD_TYPE
);
1093 TYPE_NAME (select_struct
) = get_identifier ("_jump_struct");
1096 #define ADD_FIELD(NAME, TYPE) \
1097 ss_##NAME = gfc_add_field_to_struct \
1098 (&(TYPE_FIELDS (select_struct)), select_struct, \
1099 get_identifier (stringize(NAME)), TYPE)
1101 ADD_FIELD (string1
, pchar_type_node
);
1102 ADD_FIELD (string1_len
, gfc_int4_type_node
);
1104 ADD_FIELD (string2
, pchar_type_node
);
1105 ADD_FIELD (string2_len
, gfc_int4_type_node
);
1107 ADD_FIELD (target
, pvoid_type_node
);
1110 gfc_finish_type (select_struct
);
1113 cp
= code
->block
->ext
.case_list
;
1114 while (cp
->left
!= NULL
)
1118 for (d
= cp
; d
; d
= d
->right
)
1122 labels
= gfc_getmem (n
* sizeof (tree
));
1126 for(i
= 0; i
< n
; i
++)
1128 labels
[i
] = gfc_build_label_decl (NULL_TREE
);
1129 TREE_USED (labels
[i
]) = 1;
1130 /* TODO: The gimplifier should do this for us, but it has
1131 inadequacies when dealing with static initializers. */
1132 FORCED_LABEL (labels
[i
]) = 1;
1135 end_label
= gfc_build_label_decl (NULL_TREE
);
1137 /* Generate the body */
1138 gfc_start_block (&block
);
1139 gfc_init_block (&body
);
1141 for (c
= code
->block
; c
; c
= c
->block
)
1143 for (d
= c
->ext
.case_list
; d
; d
= d
->next
)
1145 tmp
= build1_v (LABEL_EXPR
, labels
[d
->n
]);
1146 gfc_add_expr_to_block (&body
, tmp
);
1149 tmp
= gfc_trans_code (c
->next
);
1150 gfc_add_expr_to_block (&body
, tmp
);
1152 tmp
= build1_v (GOTO_EXPR
, end_label
);
1153 gfc_add_expr_to_block (&body
, tmp
);
1156 /* Generate the structure describing the branches */
1160 for(d
= cp
; d
; d
= d
->right
, i
++)
1164 gfc_init_se (&se
, NULL
);
1168 node
= tree_cons (ss_string1
, null_pointer_node
, node
);
1169 node
= tree_cons (ss_string1_len
, integer_zero_node
, node
);
1173 gfc_conv_expr_reference (&se
, d
->low
);
1175 node
= tree_cons (ss_string1
, se
.expr
, node
);
1176 node
= tree_cons (ss_string1_len
, se
.string_length
, node
);
1179 if (d
->high
== NULL
)
1181 node
= tree_cons (ss_string2
, null_pointer_node
, node
);
1182 node
= tree_cons (ss_string2_len
, integer_zero_node
, node
);
1186 gfc_init_se (&se
, NULL
);
1187 gfc_conv_expr_reference (&se
, d
->high
);
1189 node
= tree_cons (ss_string2
, se
.expr
, node
);
1190 node
= tree_cons (ss_string2_len
, se
.string_length
, node
);
1193 tmp
= gfc_build_addr_expr (pvoid_type_node
, labels
[i
]);
1194 node
= tree_cons (ss_target
, tmp
, node
);
1196 tmp
= build1 (CONSTRUCTOR
, select_struct
, nreverse (node
));
1197 init
= tree_cons (NULL_TREE
, tmp
, init
);
1200 type
= build_array_type (select_struct
, build_index_type
1201 (build_int_cst (NULL_TREE
, n
- 1)));
1203 init
= build1 (CONSTRUCTOR
, type
, nreverse(init
));
1204 TREE_CONSTANT (init
) = 1;
1205 TREE_INVARIANT (init
) = 1;
1206 TREE_STATIC (init
) = 1;
1207 /* Create a static variable to hold the jump table. */
1208 tmp
= gfc_create_var (type
, "jumptable");
1209 TREE_CONSTANT (tmp
) = 1;
1210 TREE_INVARIANT (tmp
) = 1;
1211 TREE_STATIC (tmp
) = 1;
1212 DECL_INITIAL (tmp
) = init
;
1215 /* Build an argument list for the library call */
1216 init
= gfc_build_addr_expr (pvoid_type_node
, init
);
1217 args
= gfc_chainon_list (NULL_TREE
, init
);
1219 tmp
= build_int_cst (NULL_TREE
, n
);
1220 args
= gfc_chainon_list (args
, tmp
);
1222 tmp
= gfc_build_addr_expr (pvoid_type_node
, end_label
);
1223 args
= gfc_chainon_list (args
, tmp
);
1225 gfc_init_se (&se
, NULL
);
1226 gfc_conv_expr_reference (&se
, code
->expr
);
1228 args
= gfc_chainon_list (args
, se
.expr
);
1229 args
= gfc_chainon_list (args
, se
.string_length
);
1231 gfc_add_block_to_block (&block
, &se
.pre
);
1233 tmp
= gfc_build_function_call (gfor_fndecl_select_string
, args
);
1234 tmp
= build1 (GOTO_EXPR
, void_type_node
, tmp
);
1235 gfc_add_expr_to_block (&block
, tmp
);
1237 tmp
= gfc_finish_block (&body
);
1238 gfc_add_expr_to_block (&block
, tmp
);
1239 tmp
= build1_v (LABEL_EXPR
, end_label
);
1240 gfc_add_expr_to_block (&block
, tmp
);
1245 return gfc_finish_block (&block
);
1249 /* Translate the three variants of the SELECT CASE construct.
1251 SELECT CASEs with INTEGER case expressions can be translated to an
1252 equivalent GENERIC switch statement, and for LOGICAL case
1253 expressions we build one or two if-else compares.
1255 SELECT CASEs with CHARACTER case expressions are a whole different
1256 story, because they don't exist in GENERIC. So we sort them and
1257 do a binary search at runtime.
1259 Fortran has no BREAK statement, and it does not allow jumps from
1260 one case block to another. That makes things a lot easier for
1264 gfc_trans_select (gfc_code
* code
)
1266 gcc_assert (code
&& code
->expr
);
1268 /* Empty SELECT constructs are legal. */
1269 if (code
->block
== NULL
)
1270 return build_empty_stmt ();
1272 /* Select the correct translation function. */
1273 switch (code
->expr
->ts
.type
)
1275 case BT_LOGICAL
: return gfc_trans_logical_select (code
);
1276 case BT_INTEGER
: return gfc_trans_integer_select (code
);
1277 case BT_CHARACTER
: return gfc_trans_character_select (code
);
1279 gfc_internal_error ("gfc_trans_select(): Bad type for case expr.");
1285 /* Generate the loops for a FORALL block. The normal loop format:
1286 count = (end - start + step) / step
1299 gfc_trans_forall_loop (forall_info
*forall_tmp
, int nvar
, tree body
, int mask_flag
)
1307 tree var
, start
, end
, step
, mask
, maskindex
;
1310 iter
= forall_tmp
->this_loop
;
1311 for (n
= 0; n
< nvar
; n
++)
1314 start
= iter
->start
;
1318 exit_label
= gfc_build_label_decl (NULL_TREE
);
1319 TREE_USED (exit_label
) = 1;
1321 /* The loop counter. */
1322 count
= gfc_create_var (TREE_TYPE (var
), "count");
1324 /* The body of the loop. */
1325 gfc_init_block (&block
);
1327 /* The exit condition. */
1328 cond
= build2 (LE_EXPR
, boolean_type_node
, count
, integer_zero_node
);
1329 tmp
= build1_v (GOTO_EXPR
, exit_label
);
1330 tmp
= build3_v (COND_EXPR
, cond
, tmp
, build_empty_stmt ());
1331 gfc_add_expr_to_block (&block
, tmp
);
1333 /* The main loop body. */
1334 gfc_add_expr_to_block (&block
, body
);
1336 /* Increment the loop variable. */
1337 tmp
= build2 (PLUS_EXPR
, TREE_TYPE (var
), var
, step
);
1338 gfc_add_modify_expr (&block
, var
, tmp
);
1340 /* Advance to the next mask element. */
1343 mask
= forall_tmp
->mask
;
1344 maskindex
= forall_tmp
->maskindex
;
1347 tmp
= build2 (PLUS_EXPR
, gfc_array_index_type
,
1348 maskindex
, gfc_index_one_node
);
1349 gfc_add_modify_expr (&block
, maskindex
, tmp
);
1352 /* Decrement the loop counter. */
1353 tmp
= build2 (MINUS_EXPR
, TREE_TYPE (var
), count
, gfc_index_one_node
);
1354 gfc_add_modify_expr (&block
, count
, tmp
);
1356 body
= gfc_finish_block (&block
);
1358 /* Loop var initialization. */
1359 gfc_init_block (&block
);
1360 gfc_add_modify_expr (&block
, var
, start
);
1362 /* Initialize the loop counter. */
1363 tmp
= fold (build2 (MINUS_EXPR
, TREE_TYPE (var
), step
, start
));
1364 tmp
= fold (build2 (PLUS_EXPR
, TREE_TYPE (var
), end
, tmp
));
1365 tmp
= fold (build2 (TRUNC_DIV_EXPR
, TREE_TYPE (var
), tmp
, step
));
1366 gfc_add_modify_expr (&block
, count
, tmp
);
1368 /* The loop expression. */
1369 tmp
= build1_v (LOOP_EXPR
, body
);
1370 gfc_add_expr_to_block (&block
, tmp
);
1372 /* The exit label. */
1373 tmp
= build1_v (LABEL_EXPR
, exit_label
);
1374 gfc_add_expr_to_block (&block
, tmp
);
1376 body
= gfc_finish_block (&block
);
1383 /* Generate the body and loops according to MASK_FLAG and NEST_FLAG.
1384 if MASK_FLAG is nonzero, the body is controlled by maskes in forall
1385 nest, otherwise, the body is not controlled by maskes.
1386 if NEST_FLAG is nonzero, generate loops for nested forall, otherwise,
1387 only generate loops for the current forall level. */
1390 gfc_trans_nested_forall_loop (forall_info
* nested_forall_info
, tree body
,
1391 int mask_flag
, int nest_flag
)
1395 forall_info
*forall_tmp
;
1396 tree pmask
, mask
, maskindex
;
1398 forall_tmp
= nested_forall_info
;
1399 /* Generate loops for nested forall. */
1402 while (forall_tmp
->next_nest
!= NULL
)
1403 forall_tmp
= forall_tmp
->next_nest
;
1404 while (forall_tmp
!= NULL
)
1406 /* Generate body with masks' control. */
1409 pmask
= forall_tmp
->pmask
;
1410 mask
= forall_tmp
->mask
;
1411 maskindex
= forall_tmp
->maskindex
;
1415 /* If a mask was specified make the assignment conditional. */
1417 tmp
= gfc_build_indirect_ref (mask
);
1420 tmp
= gfc_build_array_ref (tmp
, maskindex
);
1422 body
= build3_v (COND_EXPR
, tmp
, body
, build_empty_stmt ());
1425 nvar
= forall_tmp
->nvar
;
1426 body
= gfc_trans_forall_loop (forall_tmp
, nvar
, body
, mask_flag
);
1427 forall_tmp
= forall_tmp
->outer
;
1432 nvar
= forall_tmp
->nvar
;
1433 body
= gfc_trans_forall_loop (forall_tmp
, nvar
, body
, mask_flag
);
1440 /* Allocate data for holding a temporary array. Returns either a local
1441 temporary array or a pointer variable. */
1444 gfc_do_allocate (tree bytesize
, tree size
, tree
* pdata
, stmtblock_t
* pblock
,
1452 if (INTEGER_CST_P (size
))
1454 tmp
= fold (build2 (MINUS_EXPR
, gfc_array_index_type
, size
,
1455 gfc_index_one_node
));
1460 type
= build_range_type (gfc_array_index_type
, gfc_index_zero_node
, tmp
);
1461 type
= build_array_type (elem_type
, type
);
1462 if (gfc_can_put_var_on_stack (bytesize
))
1464 gcc_assert (INTEGER_CST_P (size
));
1465 tmpvar
= gfc_create_var (type
, "temp");
1470 tmpvar
= gfc_create_var (build_pointer_type (type
), "temp");
1471 *pdata
= convert (pvoid_type_node
, tmpvar
);
1473 args
= gfc_chainon_list (NULL_TREE
, bytesize
);
1474 if (gfc_index_integer_kind
== 4)
1475 tmp
= gfor_fndecl_internal_malloc
;
1476 else if (gfc_index_integer_kind
== 8)
1477 tmp
= gfor_fndecl_internal_malloc64
;
1480 tmp
= gfc_build_function_call (tmp
, args
);
1481 tmp
= convert (TREE_TYPE (tmpvar
), tmp
);
1482 gfc_add_modify_expr (pblock
, tmpvar
, tmp
);
1488 /* Generate codes to copy the temporary to the actual lhs. */
1491 generate_loop_for_temp_to_lhs (gfc_expr
*expr
, tree tmp1
, tree size
,
1492 tree count3
, tree count1
, tree count2
, tree wheremask
)
1496 stmtblock_t block
, body
;
1503 lss
= gfc_walk_expr (expr
);
1505 if (lss
== gfc_ss_terminator
)
1507 gfc_start_block (&block
);
1509 gfc_init_se (&lse
, NULL
);
1511 /* Translate the expression. */
1512 gfc_conv_expr (&lse
, expr
);
1514 /* Form the expression for the temporary. */
1515 tmp
= gfc_build_array_ref (tmp1
, count1
);
1517 /* Use the scalar assignment as is. */
1518 gfc_add_block_to_block (&block
, &lse
.pre
);
1519 gfc_add_modify_expr (&block
, lse
.expr
, tmp
);
1520 gfc_add_block_to_block (&block
, &lse
.post
);
1522 /* Increment the count1. */
1523 tmp
= fold (build2 (PLUS_EXPR
, TREE_TYPE (count1
), count1
, size
));
1524 gfc_add_modify_expr (&block
, count1
, tmp
);
1525 tmp
= gfc_finish_block (&block
);
1529 gfc_start_block (&block
);
1531 gfc_init_loopinfo (&loop1
);
1532 gfc_init_se (&rse
, NULL
);
1533 gfc_init_se (&lse
, NULL
);
1535 /* Associate the lss with the loop. */
1536 gfc_add_ss_to_loop (&loop1
, lss
);
1538 /* Calculate the bounds of the scalarization. */
1539 gfc_conv_ss_startstride (&loop1
);
1540 /* Setup the scalarizing loops. */
1541 gfc_conv_loop_setup (&loop1
);
1543 gfc_mark_ss_chain_used (lss
, 1);
1544 /* Initialize count2. */
1545 gfc_add_modify_expr (&block
, count2
, gfc_index_zero_node
);
1547 /* Start the scalarized loop body. */
1548 gfc_start_scalarized_body (&loop1
, &body
);
1550 /* Setup the gfc_se structures. */
1551 gfc_copy_loopinfo_to_se (&lse
, &loop1
);
1554 /* Form the expression of the temporary. */
1555 if (lss
!= gfc_ss_terminator
)
1557 index
= fold (build2 (PLUS_EXPR
, gfc_array_index_type
,
1559 rse
.expr
= gfc_build_array_ref (tmp1
, index
);
1561 /* Translate expr. */
1562 gfc_conv_expr (&lse
, expr
);
1564 /* Use the scalar assignment. */
1565 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
.type
);
1567 /* Form the mask expression according to the mask tree list. */
1572 wheremaskexpr
= gfc_build_array_ref (tmp2
, count3
);
1573 tmp2
= TREE_CHAIN (tmp2
);
1576 tmp1
= gfc_build_array_ref (tmp2
, count3
);
1577 wheremaskexpr
= build2 (TRUTH_AND_EXPR
, TREE_TYPE (tmp1
),
1578 wheremaskexpr
, tmp1
);
1579 tmp2
= TREE_CHAIN (tmp2
);
1581 tmp
= build3_v (COND_EXPR
, wheremaskexpr
, tmp
, build_empty_stmt ());
1584 gfc_add_expr_to_block (&body
, tmp
);
1586 /* Increment count2. */
1587 tmp
= fold (build2 (PLUS_EXPR
, gfc_array_index_type
,
1588 count2
, gfc_index_one_node
));
1589 gfc_add_modify_expr (&body
, count2
, tmp
);
1591 /* Increment count3. */
1594 tmp
= fold (build2 (PLUS_EXPR
, gfc_array_index_type
,
1595 count3
, gfc_index_one_node
));
1596 gfc_add_modify_expr (&body
, count3
, tmp
);
1599 /* Generate the copying loops. */
1600 gfc_trans_scalarizing_loops (&loop1
, &body
);
1601 gfc_add_block_to_block (&block
, &loop1
.pre
);
1602 gfc_add_block_to_block (&block
, &loop1
.post
);
1603 gfc_cleanup_loop (&loop1
);
1605 /* Increment count1. */
1606 tmp
= fold (build2 (PLUS_EXPR
, TREE_TYPE (count1
), count1
, size
));
1607 gfc_add_modify_expr (&block
, count1
, tmp
);
1608 tmp
= gfc_finish_block (&block
);
1614 /* Generate codes to copy rhs to the temporary. TMP1 is the address of temporary
1615 LSS and RSS are formed in function compute_inner_temp_size(), and should
1619 generate_loop_for_rhs_to_temp (gfc_expr
*expr2
, tree tmp1
, tree size
,
1620 tree count3
, tree count1
, tree count2
,
1621 gfc_ss
*lss
, gfc_ss
*rss
, tree wheremask
)
1623 stmtblock_t block
, body1
;
1627 tree tmp
, tmp2
, index
;
1630 gfc_start_block (&block
);
1632 gfc_init_se (&rse
, NULL
);
1633 gfc_init_se (&lse
, NULL
);
1635 if (lss
== gfc_ss_terminator
)
1637 gfc_init_block (&body1
);
1638 gfc_conv_expr (&rse
, expr2
);
1639 lse
.expr
= gfc_build_array_ref (tmp1
, count1
);
1643 /* Initialize count2. */
1644 gfc_add_modify_expr (&block
, count2
, gfc_index_zero_node
);
1646 /* Initialize the loop. */
1647 gfc_init_loopinfo (&loop
);
1649 /* We may need LSS to determine the shape of the expression. */
1650 gfc_add_ss_to_loop (&loop
, lss
);
1651 gfc_add_ss_to_loop (&loop
, rss
);
1653 gfc_conv_ss_startstride (&loop
);
1654 gfc_conv_loop_setup (&loop
);
1656 gfc_mark_ss_chain_used (rss
, 1);
1657 /* Start the loop body. */
1658 gfc_start_scalarized_body (&loop
, &body1
);
1660 /* Translate the expression. */
1661 gfc_copy_loopinfo_to_se (&rse
, &loop
);
1663 gfc_conv_expr (&rse
, expr2
);
1665 /* Form the expression of the temporary. */
1666 index
= fold (build2 (PLUS_EXPR
, gfc_array_index_type
, count1
, count2
));
1667 lse
.expr
= gfc_build_array_ref (tmp1
, index
);
1670 /* Use the scalar assignment. */
1671 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr2
->ts
.type
);
1673 /* Form the mask expression according to the mask tree list. */
1678 wheremaskexpr
= gfc_build_array_ref (tmp2
, count3
);
1679 tmp2
= TREE_CHAIN (tmp2
);
1682 tmp1
= gfc_build_array_ref (tmp2
, count3
);
1683 wheremaskexpr
= build2 (TRUTH_AND_EXPR
, TREE_TYPE (tmp1
),
1684 wheremaskexpr
, tmp1
);
1685 tmp2
= TREE_CHAIN (tmp2
);
1687 tmp
= build3_v (COND_EXPR
, wheremaskexpr
, tmp
, build_empty_stmt ());
1690 gfc_add_expr_to_block (&body1
, tmp
);
1692 if (lss
== gfc_ss_terminator
)
1694 gfc_add_block_to_block (&block
, &body1
);
1698 /* Increment count2. */
1699 tmp
= fold (build2 (PLUS_EXPR
, gfc_array_index_type
,
1700 count2
, gfc_index_one_node
));
1701 gfc_add_modify_expr (&body1
, count2
, tmp
);
1703 /* Increment count3. */
1706 tmp
= fold (build2 (PLUS_EXPR
, gfc_array_index_type
,
1707 count3
, gfc_index_one_node
));
1708 gfc_add_modify_expr (&body1
, count3
, tmp
);
1711 /* Generate the copying loops. */
1712 gfc_trans_scalarizing_loops (&loop
, &body1
);
1714 gfc_add_block_to_block (&block
, &loop
.pre
);
1715 gfc_add_block_to_block (&block
, &loop
.post
);
1717 gfc_cleanup_loop (&loop
);
1718 /* TODO: Reuse lss and rss when copying temp->lhs. Need to be careful
1719 as tree nodes in SS may not be valid in different scope. */
1721 /* Increment count1. */
1722 tmp
= fold (build2 (PLUS_EXPR
, TREE_TYPE (count1
), count1
, size
));
1723 gfc_add_modify_expr (&block
, count1
, tmp
);
1725 tmp
= gfc_finish_block (&block
);
1730 /* Calculate the size of temporary needed in the assignment inside forall.
1731 LSS and RSS are filled in this function. */
1734 compute_inner_temp_size (gfc_expr
*expr1
, gfc_expr
*expr2
,
1735 stmtblock_t
* pblock
,
1736 gfc_ss
**lss
, gfc_ss
**rss
)
1743 *lss
= gfc_walk_expr (expr1
);
1746 size
= gfc_index_one_node
;
1747 if (*lss
!= gfc_ss_terminator
)
1749 gfc_init_loopinfo (&loop
);
1751 /* Walk the RHS of the expression. */
1752 *rss
= gfc_walk_expr (expr2
);
1753 if (*rss
== gfc_ss_terminator
)
1755 /* The rhs is scalar. Add a ss for the expression. */
1756 *rss
= gfc_get_ss ();
1757 (*rss
)->next
= gfc_ss_terminator
;
1758 (*rss
)->type
= GFC_SS_SCALAR
;
1759 (*rss
)->expr
= expr2
;
1762 /* Associate the SS with the loop. */
1763 gfc_add_ss_to_loop (&loop
, *lss
);
1764 /* We don't actually need to add the rhs at this point, but it might
1765 make guessing the loop bounds a bit easier. */
1766 gfc_add_ss_to_loop (&loop
, *rss
);
1768 /* We only want the shape of the expression, not rest of the junk
1769 generated by the scalarizer. */
1770 loop
.array_parameter
= 1;
1772 /* Calculate the bounds of the scalarization. */
1773 gfc_conv_ss_startstride (&loop
);
1774 gfc_conv_loop_setup (&loop
);
1776 /* Figure out how many elements we need. */
1777 for (i
= 0; i
< loop
.dimen
; i
++)
1779 tmp
= fold (build2 (MINUS_EXPR
, gfc_array_index_type
,
1780 gfc_index_one_node
, loop
.from
[i
]));
1781 tmp
= fold (build2 (PLUS_EXPR
, gfc_array_index_type
,
1783 size
= fold (build2 (MULT_EXPR
, gfc_array_index_type
, size
, tmp
));
1785 gfc_add_block_to_block (pblock
, &loop
.pre
);
1786 size
= gfc_evaluate_now (size
, pblock
);
1787 gfc_add_block_to_block (pblock
, &loop
.post
);
1789 /* TODO: write a function that cleans up a loopinfo without freeing
1790 the SS chains. Currently a NOP. */
1797 /* Calculate the overall iterator number of the nested forall construct. */
1800 compute_overall_iter_number (forall_info
*nested_forall_info
, tree inner_size
,
1806 /* TODO: optimizing the computing process. */
1807 number
= gfc_create_var (gfc_array_index_type
, "num");
1808 gfc_add_modify_expr (block
, number
, gfc_index_zero_node
);
1810 gfc_start_block (&body
);
1811 if (nested_forall_info
)
1812 tmp
= build2 (PLUS_EXPR
, gfc_array_index_type
, number
,
1816 gfc_add_modify_expr (&body
, number
, tmp
);
1817 tmp
= gfc_finish_block (&body
);
1819 /* Generate loops. */
1820 if (nested_forall_info
!= NULL
)
1821 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, tmp
, 0, 1);
1823 gfc_add_expr_to_block (block
, tmp
);
1829 /* Allocate temporary for forall construct according to the information in
1830 nested_forall_info. INNER_SIZE is the size of temporary needed in the
1831 assignment inside forall. PTEMP1 is returned for space free. */
1834 allocate_temp_for_forall_nest (forall_info
* nested_forall_info
, tree type
,
1835 tree inner_size
, stmtblock_t
* block
,
1841 tree bytesize
, size
;
1843 /* Calculate the total size of temporary needed in forall construct. */
1844 size
= compute_overall_iter_number (nested_forall_info
, inner_size
, block
);
1846 unit
= TYPE_SIZE_UNIT (type
);
1847 bytesize
= fold (build2 (MULT_EXPR
, gfc_array_index_type
, size
, unit
));
1850 temp1
= gfc_do_allocate (bytesize
, size
, ptemp1
, block
, type
);
1853 tmp
= gfc_build_indirect_ref (temp1
);
1861 /* Handle assignments inside forall which need temporary. */
1863 gfc_trans_assign_need_temp (gfc_expr
* expr1
, gfc_expr
* expr2
, tree wheremask
,
1864 forall_info
* nested_forall_info
,
1865 stmtblock_t
* block
)
1870 tree count
, count1
, count2
;
1873 tree mask
, maskindex
;
1874 forall_info
*forall_tmp
;
1876 /* Create vars. count1 is the current iterator number of the nested forall.
1877 count2 is the current iterator number of the inner loops needed in the
1879 count1
= gfc_create_var (gfc_array_index_type
, "count1");
1880 count2
= gfc_create_var (gfc_array_index_type
, "count2");
1882 /* Count is the wheremask index. */
1885 count
= gfc_create_var (gfc_array_index_type
, "count");
1886 gfc_add_modify_expr (block
, count
, gfc_index_zero_node
);
1891 /* Initialize count1. */
1892 gfc_add_modify_expr (block
, count1
, gfc_index_zero_node
);
1894 /* Calculate the size of temporary needed in the assignment. Return loop, lss
1895 and rss which are used in function generate_loop_for_rhs_to_temp(). */
1896 inner_size
= compute_inner_temp_size (expr1
, expr2
, block
, &lss
, &rss
);
1898 /* The type of LHS. Used in function allocate_temp_for_forall_nest */
1899 type
= gfc_typenode_for_spec (&expr1
->ts
);
1901 /* Allocate temporary for nested forall construct according to the
1902 information in nested_forall_info and inner_size. */
1903 tmp1
= allocate_temp_for_forall_nest (nested_forall_info
, type
,
1904 inner_size
, block
, &ptemp1
);
1906 /* Initialize the maskindexes. */
1907 forall_tmp
= nested_forall_info
;
1908 while (forall_tmp
!= NULL
)
1910 mask
= forall_tmp
->mask
;
1911 maskindex
= forall_tmp
->maskindex
;
1913 gfc_add_modify_expr (block
, maskindex
, gfc_index_zero_node
);
1914 forall_tmp
= forall_tmp
->next_nest
;
1917 /* Generate codes to copy rhs to the temporary . */
1918 tmp
= generate_loop_for_rhs_to_temp (expr2
, tmp1
, inner_size
, count
,
1919 count1
, count2
, lss
, rss
, wheremask
);
1921 /* Generate body and loops according to the information in
1922 nested_forall_info. */
1923 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, tmp
, 1, 1);
1924 gfc_add_expr_to_block (block
, tmp
);
1927 gfc_add_modify_expr (block
, count1
, gfc_index_zero_node
);
1929 /* Reset maskindexed. */
1930 forall_tmp
= nested_forall_info
;
1931 while (forall_tmp
!= NULL
)
1933 mask
= forall_tmp
->mask
;
1934 maskindex
= forall_tmp
->maskindex
;
1936 gfc_add_modify_expr (block
, maskindex
, gfc_index_zero_node
);
1937 forall_tmp
= forall_tmp
->next_nest
;
1942 gfc_add_modify_expr (block
, count
, gfc_index_zero_node
);
1944 /* Generate codes to copy the temporary to lhs. */
1945 tmp
= generate_loop_for_temp_to_lhs (expr1
, tmp1
, inner_size
, count
,
1946 count1
, count2
, wheremask
);
1948 /* Generate body and loops according to the information in
1949 nested_forall_info. */
1950 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, tmp
, 1, 1);
1951 gfc_add_expr_to_block (block
, tmp
);
1955 /* Free the temporary. */
1956 tmp
= gfc_chainon_list (NULL_TREE
, ptemp1
);
1957 tmp
= gfc_build_function_call (gfor_fndecl_internal_free
, tmp
);
1958 gfc_add_expr_to_block (block
, tmp
);
1963 /* Translate pointer assignment inside FORALL which need temporary. */
1966 gfc_trans_pointer_assign_need_temp (gfc_expr
* expr1
, gfc_expr
* expr2
,
1967 forall_info
* nested_forall_info
,
1968 stmtblock_t
* block
)
1982 tree tmp
, tmp1
, ptemp1
;
1983 tree mask
, maskindex
;
1984 forall_info
*forall_tmp
;
1986 count
= gfc_create_var (gfc_array_index_type
, "count");
1987 gfc_add_modify_expr (block
, count
, gfc_index_zero_node
);
1989 inner_size
= integer_one_node
;
1990 lss
= gfc_walk_expr (expr1
);
1991 rss
= gfc_walk_expr (expr2
);
1992 if (lss
== gfc_ss_terminator
)
1994 type
= gfc_typenode_for_spec (&expr1
->ts
);
1995 type
= build_pointer_type (type
);
1997 /* Allocate temporary for nested forall construct according to the
1998 information in nested_forall_info and inner_size. */
1999 tmp1
= allocate_temp_for_forall_nest (nested_forall_info
,
2000 type
, inner_size
, block
, &ptemp1
);
2001 gfc_start_block (&body
);
2002 gfc_init_se (&lse
, NULL
);
2003 lse
.expr
= gfc_build_array_ref (tmp1
, count
);
2004 gfc_init_se (&rse
, NULL
);
2005 rse
.want_pointer
= 1;
2006 gfc_conv_expr (&rse
, expr2
);
2007 gfc_add_block_to_block (&body
, &rse
.pre
);
2008 gfc_add_modify_expr (&body
, lse
.expr
, rse
.expr
);
2009 gfc_add_block_to_block (&body
, &rse
.post
);
2011 /* Increment count. */
2012 tmp
= fold (build2 (PLUS_EXPR
, gfc_array_index_type
,
2013 count
, gfc_index_one_node
));
2014 gfc_add_modify_expr (&body
, count
, tmp
);
2016 tmp
= gfc_finish_block (&body
);
2018 /* Initialize the maskindexes. */
2019 forall_tmp
= nested_forall_info
;
2020 while (forall_tmp
!= NULL
)
2022 mask
= forall_tmp
->mask
;
2023 maskindex
= forall_tmp
->maskindex
;
2025 gfc_add_modify_expr (block
, maskindex
, gfc_index_zero_node
);
2026 forall_tmp
= forall_tmp
->next_nest
;
2029 /* Generate body and loops according to the information in
2030 nested_forall_info. */
2031 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, tmp
, 1, 1);
2032 gfc_add_expr_to_block (block
, tmp
);
2035 gfc_add_modify_expr (block
, count
, gfc_index_zero_node
);
2037 /* Reset maskindexes. */
2038 forall_tmp
= nested_forall_info
;
2039 while (forall_tmp
!= NULL
)
2041 mask
= forall_tmp
->mask
;
2042 maskindex
= forall_tmp
->maskindex
;
2044 gfc_add_modify_expr (block
, maskindex
, gfc_index_zero_node
);
2045 forall_tmp
= forall_tmp
->next_nest
;
2047 gfc_start_block (&body
);
2048 gfc_init_se (&lse
, NULL
);
2049 gfc_init_se (&rse
, NULL
);
2050 rse
.expr
= gfc_build_array_ref (tmp1
, count
);
2051 lse
.want_pointer
= 1;
2052 gfc_conv_expr (&lse
, expr1
);
2053 gfc_add_block_to_block (&body
, &lse
.pre
);
2054 gfc_add_modify_expr (&body
, lse
.expr
, rse
.expr
);
2055 gfc_add_block_to_block (&body
, &lse
.post
);
2056 /* Increment count. */
2057 tmp
= fold (build2 (PLUS_EXPR
, gfc_array_index_type
,
2058 count
, gfc_index_one_node
));
2059 gfc_add_modify_expr (&body
, count
, tmp
);
2060 tmp
= gfc_finish_block (&body
);
2062 /* Generate body and loops according to the information in
2063 nested_forall_info. */
2064 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, tmp
, 1, 1);
2065 gfc_add_expr_to_block (block
, tmp
);
2069 gfc_init_loopinfo (&loop
);
2071 /* Associate the SS with the loop. */
2072 gfc_add_ss_to_loop (&loop
, rss
);
2074 /* Setup the scalarizing loops and bounds. */
2075 gfc_conv_ss_startstride (&loop
);
2077 gfc_conv_loop_setup (&loop
);
2079 info
= &rss
->data
.info
;
2080 desc
= info
->descriptor
;
2082 /* Make a new descriptor. */
2083 parmtype
= gfc_get_element_type (TREE_TYPE (desc
));
2084 parmtype
= gfc_get_array_type_bounds (parmtype
, loop
.dimen
,
2085 loop
.from
, loop
.to
, 1);
2087 /* Allocate temporary for nested forall construct. */
2088 tmp1
= allocate_temp_for_forall_nest (nested_forall_info
, parmtype
,
2089 inner_size
, block
, &ptemp1
);
2090 gfc_start_block (&body
);
2091 gfc_init_se (&lse
, NULL
);
2092 lse
.expr
= gfc_build_array_ref (tmp1
, count
);
2093 lse
.direct_byref
= 1;
2094 rss
= gfc_walk_expr (expr2
);
2095 gfc_conv_expr_descriptor (&lse
, expr2
, rss
);
2097 gfc_add_block_to_block (&body
, &lse
.pre
);
2098 gfc_add_block_to_block (&body
, &lse
.post
);
2100 /* Increment count. */
2101 tmp
= fold (build2 (PLUS_EXPR
, gfc_array_index_type
,
2102 count
, gfc_index_one_node
));
2103 gfc_add_modify_expr (&body
, count
, tmp
);
2105 tmp
= gfc_finish_block (&body
);
2107 /* Initialize the maskindexes. */
2108 forall_tmp
= nested_forall_info
;
2109 while (forall_tmp
!= NULL
)
2111 mask
= forall_tmp
->mask
;
2112 maskindex
= forall_tmp
->maskindex
;
2114 gfc_add_modify_expr (block
, maskindex
, gfc_index_zero_node
);
2115 forall_tmp
= forall_tmp
->next_nest
;
2118 /* Generate body and loops according to the information in
2119 nested_forall_info. */
2120 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, tmp
, 1, 1);
2121 gfc_add_expr_to_block (block
, tmp
);
2124 gfc_add_modify_expr (block
, count
, gfc_index_zero_node
);
2126 /* Reset maskindexes. */
2127 forall_tmp
= nested_forall_info
;
2128 while (forall_tmp
!= NULL
)
2130 mask
= forall_tmp
->mask
;
2131 maskindex
= forall_tmp
->maskindex
;
2133 gfc_add_modify_expr (block
, maskindex
, gfc_index_zero_node
);
2134 forall_tmp
= forall_tmp
->next_nest
;
2136 parm
= gfc_build_array_ref (tmp1
, count
);
2137 lss
= gfc_walk_expr (expr1
);
2138 gfc_init_se (&lse
, NULL
);
2139 gfc_conv_expr_descriptor (&lse
, expr1
, lss
);
2140 gfc_add_modify_expr (&lse
.pre
, lse
.expr
, parm
);
2141 gfc_start_block (&body
);
2142 gfc_add_block_to_block (&body
, &lse
.pre
);
2143 gfc_add_block_to_block (&body
, &lse
.post
);
2145 /* Increment count. */
2146 tmp
= fold (build2 (PLUS_EXPR
, gfc_array_index_type
,
2147 count
, gfc_index_one_node
));
2148 gfc_add_modify_expr (&body
, count
, tmp
);
2150 tmp
= gfc_finish_block (&body
);
2152 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, tmp
, 1, 1);
2153 gfc_add_expr_to_block (block
, tmp
);
2155 /* Free the temporary. */
2158 tmp
= gfc_chainon_list (NULL_TREE
, ptemp1
);
2159 tmp
= gfc_build_function_call (gfor_fndecl_internal_free
, tmp
);
2160 gfc_add_expr_to_block (block
, tmp
);
2165 /* FORALL and WHERE statements are really nasty, especially when you nest
2166 them. All the rhs of a forall assignment must be evaluated before the
2167 actual assignments are performed. Presumably this also applies to all the
2168 assignments in an inner where statement. */
2170 /* Generate code for a FORALL statement. Any temporaries are allocated as a
2171 linear array, relying on the fact that we process in the same order in all
2174 forall (i=start:end:stride; maskexpr)
2178 (where e,f,g,h<i> are arbitary expressions possibly involving i)
2180 count = ((end + 1 - start) / staride)
2181 masktmp(:) = maskexpr(:)
2184 for (i = start; i <= end; i += stride)
2186 if (masktmp[maskindex++])
2190 for (i = start; i <= end; i += stride)
2192 if (masktmp[maskindex++])
2196 Note that this code only works when there are no dependencies.
2197 Forall loop with array assignments and data dependencies are a real pain,
2198 because the size of the temporary cannot always be determined before the
2199 loop is executed. This problem is compounded by the presence of nested
2204 gfc_trans_forall_1 (gfc_code
* code
, forall_info
* nested_forall_info
)
2226 gfc_forall_iterator
*fa
;
2229 gfc_saved_var
*saved_vars
;
2230 iter_info
*this_forall
, *iter_tmp
;
2231 forall_info
*info
, *forall_tmp
;
2232 temporary_list
*temp
;
2234 gfc_start_block (&block
);
2237 /* Count the FORALL index number. */
2238 for (fa
= code
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
2242 /* Allocate the space for var, start, end, step, varexpr. */
2243 var
= (tree
*) gfc_getmem (nvar
* sizeof (tree
));
2244 start
= (tree
*) gfc_getmem (nvar
* sizeof (tree
));
2245 end
= (tree
*) gfc_getmem (nvar
* sizeof (tree
));
2246 step
= (tree
*) gfc_getmem (nvar
* sizeof (tree
));
2247 varexpr
= (gfc_expr
**) gfc_getmem (nvar
* sizeof (gfc_expr
*));
2248 saved_vars
= (gfc_saved_var
*) gfc_getmem (nvar
* sizeof (gfc_saved_var
));
2250 /* Allocate the space for info. */
2251 info
= (forall_info
*) gfc_getmem (sizeof (forall_info
));
2253 for (fa
= code
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
2255 gfc_symbol
*sym
= fa
->var
->symtree
->n
.sym
;
2257 /* allocate space for this_forall. */
2258 this_forall
= (iter_info
*) gfc_getmem (sizeof (iter_info
));
2260 /* Create a temporary variable for the FORALL index. */
2261 tmp
= gfc_typenode_for_spec (&sym
->ts
);
2262 var
[n
] = gfc_create_var (tmp
, sym
->name
);
2263 gfc_shadow_sym (sym
, var
[n
], &saved_vars
[n
]);
2265 /* Record it in this_forall. */
2266 this_forall
->var
= var
[n
];
2268 /* Replace the index symbol's backend_decl with the temporary decl. */
2269 sym
->backend_decl
= var
[n
];
2271 /* Work out the start, end and stride for the loop. */
2272 gfc_init_se (&se
, NULL
);
2273 gfc_conv_expr_val (&se
, fa
->start
);
2274 /* Record it in this_forall. */
2275 this_forall
->start
= se
.expr
;
2276 gfc_add_block_to_block (&block
, &se
.pre
);
2279 gfc_init_se (&se
, NULL
);
2280 gfc_conv_expr_val (&se
, fa
->end
);
2281 /* Record it in this_forall. */
2282 this_forall
->end
= se
.expr
;
2283 gfc_make_safe_expr (&se
);
2284 gfc_add_block_to_block (&block
, &se
.pre
);
2287 gfc_init_se (&se
, NULL
);
2288 gfc_conv_expr_val (&se
, fa
->stride
);
2289 /* Record it in this_forall. */
2290 this_forall
->step
= se
.expr
;
2291 gfc_make_safe_expr (&se
);
2292 gfc_add_block_to_block (&block
, &se
.pre
);
2295 /* Set the NEXT field of this_forall to NULL. */
2296 this_forall
->next
= NULL
;
2297 /* Link this_forall to the info construct. */
2298 if (info
->this_loop
== NULL
)
2299 info
->this_loop
= this_forall
;
2302 iter_tmp
= info
->this_loop
;
2303 while (iter_tmp
->next
!= NULL
)
2304 iter_tmp
= iter_tmp
->next
;
2305 iter_tmp
->next
= this_forall
;
2312 /* Work out the number of elements in the mask array. */
2315 size
= gfc_index_one_node
;
2316 sizevar
= NULL_TREE
;
2318 for (n
= 0; n
< nvar
; n
++)
2320 if (lenvar
&& TREE_TYPE (lenvar
) != TREE_TYPE (start
[n
]))
2323 /* size = (end + step - start) / step. */
2324 tmp
= fold (build2 (MINUS_EXPR
, TREE_TYPE (start
[n
]),
2325 step
[n
], start
[n
]));
2326 tmp
= fold (build2 (PLUS_EXPR
, TREE_TYPE (end
[n
]), end
[n
], tmp
));
2328 tmp
= fold (build2 (FLOOR_DIV_EXPR
, TREE_TYPE (tmp
), tmp
, step
[n
]));
2329 tmp
= convert (gfc_array_index_type
, tmp
);
2331 size
= fold (build2 (MULT_EXPR
, gfc_array_index_type
, size
, tmp
));
2334 /* Record the nvar and size of current forall level. */
2338 /* Link the current forall level to nested_forall_info. */
2339 forall_tmp
= nested_forall_info
;
2340 if (forall_tmp
== NULL
)
2341 nested_forall_info
= info
;
2344 while (forall_tmp
->next_nest
!= NULL
)
2345 forall_tmp
= forall_tmp
->next_nest
;
2346 info
->outer
= forall_tmp
;
2347 forall_tmp
->next_nest
= info
;
2350 /* Copy the mask into a temporary variable if required.
2351 For now we assume a mask temporary is needed. */
2354 /* Allocate the mask temporary. */
2355 bytesize
= fold (build2 (MULT_EXPR
, gfc_array_index_type
, size
,
2356 TYPE_SIZE_UNIT (boolean_type_node
)));
2358 mask
= gfc_do_allocate (bytesize
, size
, &pmask
, &block
, boolean_type_node
);
2360 maskindex
= gfc_create_var_np (gfc_array_index_type
, "mi");
2361 /* Record them in the info structure. */
2362 info
->pmask
= pmask
;
2364 info
->maskindex
= maskindex
;
2366 gfc_add_modify_expr (&block
, maskindex
, gfc_index_zero_node
);
2368 /* Start of mask assignment loop body. */
2369 gfc_start_block (&body
);
2371 /* Evaluate the mask expression. */
2372 gfc_init_se (&se
, NULL
);
2373 gfc_conv_expr_val (&se
, code
->expr
);
2374 gfc_add_block_to_block (&body
, &se
.pre
);
2376 /* Store the mask. */
2377 se
.expr
= convert (boolean_type_node
, se
.expr
);
2380 tmp
= gfc_build_indirect_ref (mask
);
2383 tmp
= gfc_build_array_ref (tmp
, maskindex
);
2384 gfc_add_modify_expr (&body
, tmp
, se
.expr
);
2386 /* Advance to the next mask element. */
2387 tmp
= build2 (PLUS_EXPR
, gfc_array_index_type
,
2388 maskindex
, gfc_index_one_node
);
2389 gfc_add_modify_expr (&body
, maskindex
, tmp
);
2391 /* Generate the loops. */
2392 tmp
= gfc_finish_block (&body
);
2393 tmp
= gfc_trans_nested_forall_loop (info
, tmp
, 0, 0);
2394 gfc_add_expr_to_block (&block
, tmp
);
2398 /* No mask was specified. */
2399 maskindex
= NULL_TREE
;
2400 mask
= pmask
= NULL_TREE
;
2403 c
= code
->block
->next
;
2405 /* TODO: loop merging in FORALL statements. */
2406 /* Now that we've got a copy of the mask, generate the assignment loops. */
2412 /* A scalar or array assignment. */
2413 need_temp
= gfc_check_dependency (c
->expr
, c
->expr2
, varexpr
, nvar
);
2414 /* Teporaries due to array assignment data dependencies introduce
2415 no end of problems. */
2417 gfc_trans_assign_need_temp (c
->expr
, c
->expr2
, NULL
,
2418 nested_forall_info
, &block
);
2421 /* Use the normal assignment copying routines. */
2422 assign
= gfc_trans_assignment (c
->expr
, c
->expr2
);
2424 /* Reset the mask index. */
2426 gfc_add_modify_expr (&block
, maskindex
, gfc_index_zero_node
);
2428 /* Generate body and loops. */
2429 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, assign
, 1, 1);
2430 gfc_add_expr_to_block (&block
, tmp
);
2437 /* Translate WHERE or WHERE construct nested in FORALL. */
2439 gfc_trans_where_2 (c
, NULL
, NULL
, nested_forall_info
, &block
, &temp
);
2446 /* Free the temporary. */
2447 args
= gfc_chainon_list (NULL_TREE
, temp
->temporary
);
2448 tmp
= gfc_build_function_call (gfor_fndecl_internal_free
, args
);
2449 gfc_add_expr_to_block (&block
, tmp
);
2458 /* Pointer assignment inside FORALL. */
2459 case EXEC_POINTER_ASSIGN
:
2460 need_temp
= gfc_check_dependency (c
->expr
, c
->expr2
, varexpr
, nvar
);
2462 gfc_trans_pointer_assign_need_temp (c
->expr
, c
->expr2
,
2463 nested_forall_info
, &block
);
2466 /* Use the normal assignment copying routines. */
2467 assign
= gfc_trans_pointer_assignment (c
->expr
, c
->expr2
);
2469 /* Reset the mask index. */
2471 gfc_add_modify_expr (&block
, maskindex
, gfc_index_zero_node
);
2473 /* Generate body and loops. */
2474 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, assign
,
2476 gfc_add_expr_to_block (&block
, tmp
);
2481 tmp
= gfc_trans_forall_1 (c
, nested_forall_info
);
2482 gfc_add_expr_to_block (&block
, tmp
);
2492 /* Restore the original index variables. */
2493 for (fa
= code
->ext
.forall_iterator
, n
= 0; fa
; fa
= fa
->next
, n
++)
2494 gfc_restore_sym (fa
->var
->symtree
->n
.sym
, &saved_vars
[n
]);
2496 /* Free the space for var, start, end, step, varexpr. */
2502 gfc_free (saved_vars
);
2506 /* Free the temporary for the mask. */
2507 tmp
= gfc_chainon_list (NULL_TREE
, pmask
);
2508 tmp
= gfc_build_function_call (gfor_fndecl_internal_free
, tmp
);
2509 gfc_add_expr_to_block (&block
, tmp
);
2512 pushdecl (maskindex
);
2514 return gfc_finish_block (&block
);
2518 /* Translate the FORALL statement or construct. */
2520 tree
gfc_trans_forall (gfc_code
* code
)
2522 return gfc_trans_forall_1 (code
, NULL
);
2526 /* Evaluate the WHERE mask expression, copy its value to a temporary.
2527 If the WHERE construct is nested in FORALL, compute the overall temporary
2528 needed by the WHERE mask expression multiplied by the iterator number of
2530 ME is the WHERE mask expression.
2531 MASK is the temporary which value is mask's value.
2532 NMASK is another temporary which value is !mask.
2533 TEMP records the temporary's address allocated in this function in order to
2534 free them outside this function.
2535 MASK, NMASK and TEMP are all OUT arguments. */
2538 gfc_evaluate_where_mask (gfc_expr
* me
, forall_info
* nested_forall_info
,
2539 tree
* mask
, tree
* nmask
, temporary_list
** temp
,
2540 stmtblock_t
* block
)
2545 tree ptemp1
, ntmp
, ptemp2
;
2547 stmtblock_t body
, body1
;
2552 gfc_init_loopinfo (&loop
);
2554 /* Calculate the size of temporary needed by the mask-expr. */
2555 inner_size
= compute_inner_temp_size (me
, me
, block
, &lss
, &rss
);
2557 /* Allocate temporary for where mask. */
2558 tmp
= allocate_temp_for_forall_nest (nested_forall_info
, boolean_type_node
,
2559 inner_size
, block
, &ptemp1
);
2560 /* Record the temporary address in order to free it later. */
2563 temporary_list
*tempo
;
2564 tempo
= (temporary_list
*) gfc_getmem (sizeof (temporary_list
));
2565 tempo
->temporary
= ptemp1
;
2566 tempo
->next
= *temp
;
2570 /* Allocate temporary for !mask. */
2571 ntmp
= allocate_temp_for_forall_nest (nested_forall_info
, boolean_type_node
,
2572 inner_size
, block
, &ptemp2
);
2573 /* Record the temporary in order to free it later. */
2576 temporary_list
*tempo
;
2577 tempo
= (temporary_list
*) gfc_getmem (sizeof (temporary_list
));
2578 tempo
->temporary
= ptemp2
;
2579 tempo
->next
= *temp
;
2583 /* Variable to index the temporary. */
2584 count
= gfc_create_var (gfc_array_index_type
, "count");
2585 /* Initialize count. */
2586 gfc_add_modify_expr (block
, count
, gfc_index_zero_node
);
2588 gfc_start_block (&body
);
2590 gfc_init_se (&rse
, NULL
);
2591 gfc_init_se (&lse
, NULL
);
2593 if (lss
== gfc_ss_terminator
)
2595 gfc_init_block (&body1
);
2599 /* Initialize the loop. */
2600 gfc_init_loopinfo (&loop
);
2602 /* We may need LSS to determine the shape of the expression. */
2603 gfc_add_ss_to_loop (&loop
, lss
);
2604 gfc_add_ss_to_loop (&loop
, rss
);
2606 gfc_conv_ss_startstride (&loop
);
2607 gfc_conv_loop_setup (&loop
);
2609 gfc_mark_ss_chain_used (rss
, 1);
2610 /* Start the loop body. */
2611 gfc_start_scalarized_body (&loop
, &body1
);
2613 /* Translate the expression. */
2614 gfc_copy_loopinfo_to_se (&rse
, &loop
);
2616 gfc_conv_expr (&rse
, me
);
2618 /* Form the expression of the temporary. */
2619 lse
.expr
= gfc_build_array_ref (tmp
, count
);
2620 tmpexpr
= gfc_build_array_ref (ntmp
, count
);
2622 /* Use the scalar assignment to fill temporary TMP. */
2623 tmp1
= gfc_trans_scalar_assign (&lse
, &rse
, me
->ts
.type
);
2624 gfc_add_expr_to_block (&body1
, tmp1
);
2626 /* Fill temporary NTMP. */
2627 tmp1
= build1 (TRUTH_NOT_EXPR
, TREE_TYPE (lse
.expr
), lse
.expr
);
2628 gfc_add_modify_expr (&body1
, tmpexpr
, tmp1
);
2630 if (lss
== gfc_ss_terminator
)
2632 gfc_add_block_to_block (&body
, &body1
);
2636 /* Increment count. */
2637 tmp1
= fold (build2 (PLUS_EXPR
, gfc_array_index_type
, count
,
2638 gfc_index_one_node
));
2639 gfc_add_modify_expr (&body1
, count
, tmp1
);
2641 /* Generate the copying loops. */
2642 gfc_trans_scalarizing_loops (&loop
, &body1
);
2644 gfc_add_block_to_block (&body
, &loop
.pre
);
2645 gfc_add_block_to_block (&body
, &loop
.post
);
2647 gfc_cleanup_loop (&loop
);
2648 /* TODO: Reuse lss and rss when copying temp->lhs. Need to be careful
2649 as tree nodes in SS may not be valid in different scope. */
2652 tmp1
= gfc_finish_block (&body
);
2653 /* If the WHERE construct is inside FORALL, fill the full temporary. */
2654 if (nested_forall_info
!= NULL
)
2655 tmp1
= gfc_trans_nested_forall_loop (nested_forall_info
, tmp1
, 1, 1);
2658 gfc_add_expr_to_block (block
, tmp1
);
2667 /* Translate an assignment statement in a WHERE statement or construct
2668 statement. The MASK expression is used to control which elements
2669 of EXPR1 shall be assigned. */
2672 gfc_trans_where_assign (gfc_expr
*expr1
, gfc_expr
*expr2
, tree mask
,
2673 tree count1
, tree count2
)
2678 gfc_ss
*lss_section
;
2685 tree index
, maskexpr
, tmp1
;
2688 /* TODO: handle this special case.
2689 Special case a single function returning an array. */
2690 if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->rank
> 0)
2692 tmp
= gfc_trans_arrayfunc_assign (expr1
, expr2
);
2698 /* Assignment of the form lhs = rhs. */
2699 gfc_start_block (&block
);
2701 gfc_init_se (&lse
, NULL
);
2702 gfc_init_se (&rse
, NULL
);
2705 lss
= gfc_walk_expr (expr1
);
2708 /* In each where-assign-stmt, the mask-expr and the variable being
2709 defined shall be arrays of the same shape. */
2710 gcc_assert (lss
!= gfc_ss_terminator
);
2712 /* The assignment needs scalarization. */
2715 /* Find a non-scalar SS from the lhs. */
2716 while (lss_section
!= gfc_ss_terminator
2717 && lss_section
->type
!= GFC_SS_SECTION
)
2718 lss_section
= lss_section
->next
;
2720 gcc_assert (lss_section
!= gfc_ss_terminator
);
2722 /* Initialize the scalarizer. */
2723 gfc_init_loopinfo (&loop
);
2726 rss
= gfc_walk_expr (expr2
);
2727 if (rss
== gfc_ss_terminator
)
2729 /* The rhs is scalar. Add a ss for the expression. */
2730 rss
= gfc_get_ss ();
2731 rss
->next
= gfc_ss_terminator
;
2732 rss
->type
= GFC_SS_SCALAR
;
2736 /* Associate the SS with the loop. */
2737 gfc_add_ss_to_loop (&loop
, lss
);
2738 gfc_add_ss_to_loop (&loop
, rss
);
2740 /* Calculate the bounds of the scalarization. */
2741 gfc_conv_ss_startstride (&loop
);
2743 /* Resolve any data dependencies in the statement. */
2744 gfc_conv_resolve_dependencies (&loop
, lss_section
, rss
);
2746 /* Setup the scalarizing loops. */
2747 gfc_conv_loop_setup (&loop
);
2749 /* Setup the gfc_se structures. */
2750 gfc_copy_loopinfo_to_se (&lse
, &loop
);
2751 gfc_copy_loopinfo_to_se (&rse
, &loop
);
2754 gfc_mark_ss_chain_used (rss
, 1);
2755 if (loop
.temp_ss
== NULL
)
2758 gfc_mark_ss_chain_used (lss
, 1);
2762 lse
.ss
= loop
.temp_ss
;
2763 gfc_mark_ss_chain_used (lss
, 3);
2764 gfc_mark_ss_chain_used (loop
.temp_ss
, 3);
2767 /* Start the scalarized loop body. */
2768 gfc_start_scalarized_body (&loop
, &body
);
2770 /* Translate the expression. */
2771 gfc_conv_expr (&rse
, expr2
);
2772 if (lss
!= gfc_ss_terminator
&& loop
.temp_ss
!= NULL
)
2774 gfc_conv_tmp_array_ref (&lse
);
2775 gfc_advance_se_ss_chain (&lse
);
2778 gfc_conv_expr (&lse
, expr1
);
2780 /* Form the mask expression according to the mask tree list. */
2784 maskexpr
= gfc_build_array_ref (tmp
, index
);
2788 tmp
= TREE_CHAIN (tmp
);
2791 tmp1
= gfc_build_array_ref (tmp
, index
);
2792 maskexpr
= build2 (TRUTH_AND_EXPR
, TREE_TYPE (tmp1
), maskexpr
, tmp1
);
2793 tmp
= TREE_CHAIN (tmp
);
2795 /* Use the scalar assignment as is. */
2796 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
.type
);
2797 tmp
= build3_v (COND_EXPR
, maskexpr
, tmp
, build_empty_stmt ());
2799 gfc_add_expr_to_block (&body
, tmp
);
2801 if (lss
== gfc_ss_terminator
)
2803 /* Increment count1. */
2804 tmp
= fold (build2 (PLUS_EXPR
, gfc_array_index_type
,
2805 count1
, gfc_index_one_node
));
2806 gfc_add_modify_expr (&body
, count1
, tmp
);
2808 /* Use the scalar assignment as is. */
2809 gfc_add_block_to_block (&block
, &body
);
2813 gcc_assert (lse
.ss
== gfc_ss_terminator
2814 && rse
.ss
== gfc_ss_terminator
);
2816 if (loop
.temp_ss
!= NULL
)
2818 /* Increment count1 before finish the main body of a scalarized
2820 tmp
= fold (build2 (PLUS_EXPR
, gfc_array_index_type
,
2821 count1
, gfc_index_one_node
));
2822 gfc_add_modify_expr (&body
, count1
, tmp
);
2823 gfc_trans_scalarized_loop_boundary (&loop
, &body
);
2825 /* We need to copy the temporary to the actual lhs. */
2826 gfc_init_se (&lse
, NULL
);
2827 gfc_init_se (&rse
, NULL
);
2828 gfc_copy_loopinfo_to_se (&lse
, &loop
);
2829 gfc_copy_loopinfo_to_se (&rse
, &loop
);
2831 rse
.ss
= loop
.temp_ss
;
2834 gfc_conv_tmp_array_ref (&rse
);
2835 gfc_advance_se_ss_chain (&rse
);
2836 gfc_conv_expr (&lse
, expr1
);
2838 gcc_assert (lse
.ss
== gfc_ss_terminator
2839 && rse
.ss
== gfc_ss_terminator
);
2841 /* Form the mask expression according to the mask tree list. */
2845 maskexpr
= gfc_build_array_ref (tmp
, index
);
2849 tmp
= TREE_CHAIN (tmp
);
2852 tmp1
= gfc_build_array_ref (tmp
, index
);
2853 maskexpr
= build2 (TRUTH_AND_EXPR
, TREE_TYPE (tmp1
),
2855 tmp
= TREE_CHAIN (tmp
);
2857 /* Use the scalar assignment as is. */
2858 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
.type
);
2859 tmp
= build3_v (COND_EXPR
, maskexpr
, tmp
, build_empty_stmt ());
2860 gfc_add_expr_to_block (&body
, tmp
);
2862 /* Increment count2. */
2863 tmp
= fold (build2 (PLUS_EXPR
, gfc_array_index_type
,
2864 count2
, gfc_index_one_node
));
2865 gfc_add_modify_expr (&body
, count2
, tmp
);
2869 /* Increment count1. */
2870 tmp
= fold (build2 (PLUS_EXPR
, gfc_array_index_type
,
2871 count1
, gfc_index_one_node
));
2872 gfc_add_modify_expr (&body
, count1
, tmp
);
2875 /* Generate the copying loops. */
2876 gfc_trans_scalarizing_loops (&loop
, &body
);
2878 /* Wrap the whole thing up. */
2879 gfc_add_block_to_block (&block
, &loop
.pre
);
2880 gfc_add_block_to_block (&block
, &loop
.post
);
2881 gfc_cleanup_loop (&loop
);
2884 return gfc_finish_block (&block
);
2888 /* Translate the WHERE construct or statement.
2889 This fuction can be called iteratively to translate the nested WHERE
2890 construct or statement.
2891 MASK is the control mask, and PMASK is the pending control mask.
2892 TEMP records the temporary address which must be freed later. */
2895 gfc_trans_where_2 (gfc_code
* code
, tree mask
, tree pmask
,
2896 forall_info
* nested_forall_info
, stmtblock_t
* block
,
2897 temporary_list
** temp
)
2903 tree tmp
, tmp1
, tmp2
;
2904 tree count1
, count2
;
2908 /* the WHERE statement or the WHERE construct statement. */
2909 cblock
= code
->block
;
2912 /* Has mask-expr. */
2915 /* Ensure that the WHERE mask be evaluated only once. */
2916 tmp2
= gfc_evaluate_where_mask (cblock
->expr
, nested_forall_info
,
2917 &tmp
, &tmp1
, temp
, block
);
2919 /* Set the control mask and the pending control mask. */
2920 /* It's a where-stmt. */
2926 /* It's a nested where-stmt. */
2927 else if (mask
&& pmask
== NULL
)
2930 /* Use the TREE_CHAIN to list the masks. */
2931 tmp2
= copy_list (mask
);
2932 pmask
= chainon (mask
, tmp1
);
2933 mask
= chainon (tmp2
, tmp
);
2935 /* It's a masked-elsewhere-stmt. */
2936 else if (mask
&& cblock
->expr
)
2939 tmp2
= copy_list (pmask
);
2942 tmp2
= chainon (tmp2
, tmp
);
2943 pmask
= chainon (mask
, tmp1
);
2947 /* It's a elsewhere-stmt. No mask-expr is present. */
2951 /* Get the assignment statement of a WHERE statement, or the first
2952 statement in where-body-construct of a WHERE construct. */
2953 cnext
= cblock
->next
;
2958 /* WHERE assignment statement. */
2960 expr1
= cnext
->expr
;
2961 expr2
= cnext
->expr2
;
2962 if (nested_forall_info
!= NULL
)
2967 nvar
= nested_forall_info
->nvar
;
2968 varexpr
= (gfc_expr
**)
2969 gfc_getmem (nvar
* sizeof (gfc_expr
*));
2970 need_temp
= gfc_check_dependency (expr1
, expr2
, varexpr
,
2973 gfc_trans_assign_need_temp (expr1
, expr2
, mask
,
2974 nested_forall_info
, block
);
2977 /* Variables to control maskexpr. */
2978 count1
= gfc_create_var (gfc_array_index_type
, "count1");
2979 count2
= gfc_create_var (gfc_array_index_type
, "count2");
2980 gfc_add_modify_expr (block
, count1
, gfc_index_zero_node
);
2981 gfc_add_modify_expr (block
, count2
, gfc_index_zero_node
);
2983 tmp
= gfc_trans_where_assign (expr1
, expr2
, mask
, count1
,
2985 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
,
2987 gfc_add_expr_to_block (block
, tmp
);
2992 /* Variables to control maskexpr. */
2993 count1
= gfc_create_var (gfc_array_index_type
, "count1");
2994 count2
= gfc_create_var (gfc_array_index_type
, "count2");
2995 gfc_add_modify_expr (block
, count1
, gfc_index_zero_node
);
2996 gfc_add_modify_expr (block
, count2
, gfc_index_zero_node
);
2998 tmp
= gfc_trans_where_assign (expr1
, expr2
, mask
, count1
,
3000 gfc_add_expr_to_block (block
, tmp
);
3005 /* WHERE or WHERE construct is part of a where-body-construct. */
3007 /* Ensure that MASK is not modified by next gfc_trans_where_2. */
3008 mask_copy
= copy_list (mask
);
3009 gfc_trans_where_2 (cnext
, mask_copy
, NULL
, nested_forall_info
,
3017 /* The next statement within the same where-body-construct. */
3018 cnext
= cnext
->next
;
3020 /* The next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt. */
3021 cblock
= cblock
->block
;
3026 /* As the WHERE or WHERE construct statement can be nested, we call
3027 gfc_trans_where_2 to do the translation, and pass the initial
3028 NULL values for both the control mask and the pending control mask. */
3031 gfc_trans_where (gfc_code
* code
)
3034 temporary_list
*temp
, *p
;
3038 gfc_start_block (&block
);
3041 gfc_trans_where_2 (code
, NULL
, NULL
, NULL
, &block
, &temp
);
3043 /* Add calls to free temporaries which were dynamically allocated. */
3046 args
= gfc_chainon_list (NULL_TREE
, temp
->temporary
);
3047 tmp
= gfc_build_function_call (gfor_fndecl_internal_free
, args
);
3048 gfc_add_expr_to_block (&block
, tmp
);
3054 return gfc_finish_block (&block
);
3058 /* CYCLE a DO loop. The label decl has already been created by
3059 gfc_trans_do(), it's in TREE_PURPOSE (backend_decl) of the gfc_code
3060 node at the head of the loop. We must mark the label as used. */
3063 gfc_trans_cycle (gfc_code
* code
)
3067 cycle_label
= TREE_PURPOSE (code
->ext
.whichloop
->backend_decl
);
3068 TREE_USED (cycle_label
) = 1;
3069 return build1_v (GOTO_EXPR
, cycle_label
);
3073 /* EXIT a DO loop. Similair to CYCLE, but now the label is in
3074 TREE_VALUE (backend_decl) of the gfc_code node at the head of the
3078 gfc_trans_exit (gfc_code
* code
)
3082 exit_label
= TREE_VALUE (code
->ext
.whichloop
->backend_decl
);
3083 TREE_USED (exit_label
) = 1;
3084 return build1_v (GOTO_EXPR
, exit_label
);
3088 /* Translate the ALLOCATE statement. */
3091 gfc_trans_allocate (gfc_code
* code
)
3104 if (!code
->ext
.alloc_list
)
3107 gfc_start_block (&block
);
3111 tree gfc_int4_type_node
= gfc_get_int_type (4);
3113 stat
= gfc_create_var (gfc_int4_type_node
, "stat");
3114 pstat
= gfc_build_addr_expr (NULL
, stat
);
3116 error_label
= gfc_build_label_decl (NULL_TREE
);
3117 TREE_USED (error_label
) = 1;
3121 pstat
= integer_zero_node
;
3122 stat
= error_label
= NULL_TREE
;
3126 for (al
= code
->ext
.alloc_list
; al
!= NULL
; al
= al
->next
)
3130 gfc_init_se (&se
, NULL
);
3131 gfc_start_block (&se
.pre
);
3133 se
.want_pointer
= 1;
3134 se
.descriptor_only
= 1;
3135 gfc_conv_expr (&se
, expr
);
3139 /* Find the last reference in the chain. */
3140 while (ref
&& ref
->next
!= NULL
)
3142 gcc_assert (ref
->type
!= REF_ARRAY
|| ref
->u
.ar
.type
== AR_ELEMENT
);
3146 if (ref
!= NULL
&& ref
->type
== REF_ARRAY
)
3149 gfc_array_allocate (&se
, ref
, pstat
);
3153 /* A scalar or derived type. */
3156 val
= gfc_create_var (ppvoid_type_node
, "ptr");
3157 tmp
= gfc_build_addr_expr (ppvoid_type_node
, se
.expr
);
3158 gfc_add_modify_expr (&se
.pre
, val
, tmp
);
3160 tmp
= TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (se
.expr
)));
3161 parm
= gfc_chainon_list (NULL_TREE
, val
);
3162 parm
= gfc_chainon_list (parm
, tmp
);
3163 parm
= gfc_chainon_list (parm
, pstat
);
3164 tmp
= gfc_build_function_call (gfor_fndecl_allocate
, parm
);
3165 gfc_add_expr_to_block (&se
.pre
, tmp
);
3169 tmp
= build1_v (GOTO_EXPR
, error_label
);
3171 build2 (NE_EXPR
, boolean_type_node
, stat
, integer_zero_node
);
3172 tmp
= build3_v (COND_EXPR
, parm
, tmp
, build_empty_stmt ());
3173 gfc_add_expr_to_block (&se
.pre
, tmp
);
3177 tmp
= gfc_finish_block (&se
.pre
);
3178 gfc_add_expr_to_block (&block
, tmp
);
3181 /* Assign the value to the status variable. */
3184 tmp
= build1_v (LABEL_EXPR
, error_label
);
3185 gfc_add_expr_to_block (&block
, tmp
);
3187 gfc_init_se (&se
, NULL
);
3188 gfc_conv_expr_lhs (&se
, code
->expr
);
3189 tmp
= convert (TREE_TYPE (se
.expr
), stat
);
3190 gfc_add_modify_expr (&block
, se
.expr
, tmp
);
3193 return gfc_finish_block (&block
);
3198 gfc_trans_deallocate (gfc_code
* code
)
3208 gfc_start_block (&block
);
3210 for (al
= code
->ext
.alloc_list
; al
!= NULL
; al
= al
->next
)
3213 gcc_assert (expr
->expr_type
== EXPR_VARIABLE
);
3215 gfc_init_se (&se
, NULL
);
3216 gfc_start_block (&se
.pre
);
3218 se
.want_pointer
= 1;
3219 se
.descriptor_only
= 1;
3220 gfc_conv_expr (&se
, expr
);
3222 if (expr
->symtree
->n
.sym
->attr
.dimension
)
3224 tmp
= gfc_array_deallocate (se
.expr
);
3225 gfc_add_expr_to_block (&se
.pre
, tmp
);
3229 type
= build_pointer_type (TREE_TYPE (se
.expr
));
3230 var
= gfc_create_var (type
, "ptr");
3231 tmp
= gfc_build_addr_expr (type
, se
.expr
);
3232 gfc_add_modify_expr (&se
.pre
, var
, tmp
);
3234 tmp
= gfc_chainon_list (NULL_TREE
, var
);
3235 tmp
= gfc_chainon_list (tmp
, integer_zero_node
);
3236 tmp
= gfc_build_function_call (gfor_fndecl_deallocate
, tmp
);
3237 gfc_add_expr_to_block (&se
.pre
, tmp
);
3239 tmp
= gfc_finish_block (&se
.pre
);
3240 gfc_add_expr_to_block (&block
, tmp
);
3243 return gfc_finish_block (&block
);