1 /* Statement translation -- generate GCC trees from gfc_code.
2 Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010
3 Free Software Foundation, Inc.
4 Contributed by Paul Brook <paul@nowt.org>
5 and Steven Bosscher <s.bosscher@student.tudelft.nl>
7 This file is part of GCC.
9 GCC is free software; you can redistribute it and/or modify it under
10 the terms of the GNU General Public License as published by the Free
11 Software Foundation; either version 3, or (at your option) any later
14 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
15 WARRANTY; without even the implied warranty of MERCHANTABILITY or
16 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
19 You should have received a copy of the GNU General Public License
20 along with GCC; see the file COPYING3. If not see
21 <http://www.gnu.org/licenses/>. */
26 #include "coretypes.h"
31 #include "trans-stmt.h"
32 #include "trans-types.h"
33 #include "trans-array.h"
34 #include "trans-const.h"
36 #include "dependency.h"
39 typedef struct iter_info
45 struct iter_info
*next
;
49 typedef struct forall_info
56 struct forall_info
*prev_nest
;
60 static void gfc_trans_where_2 (gfc_code
*, tree
, bool,
61 forall_info
*, stmtblock_t
*);
63 /* Translate a F95 label number to a LABEL_EXPR. */
66 gfc_trans_label_here (gfc_code
* code
)
68 return build1_v (LABEL_EXPR
, gfc_get_label_decl (code
->here
));
72 /* Given a variable expression which has been ASSIGNed to, find the decl
73 containing the auxiliary variables. For variables in common blocks this
77 gfc_conv_label_variable (gfc_se
* se
, gfc_expr
* expr
)
79 gcc_assert (expr
->symtree
->n
.sym
->attr
.assign
== 1);
80 gfc_conv_expr (se
, expr
);
81 /* Deals with variable in common block. Get the field declaration. */
82 if (TREE_CODE (se
->expr
) == COMPONENT_REF
)
83 se
->expr
= TREE_OPERAND (se
->expr
, 1);
84 /* Deals with dummy argument. Get the parameter declaration. */
85 else if (TREE_CODE (se
->expr
) == INDIRECT_REF
)
86 se
->expr
= TREE_OPERAND (se
->expr
, 0);
89 /* Translate a label assignment statement. */
92 gfc_trans_label_assign (gfc_code
* code
)
101 /* Start a new block. */
102 gfc_init_se (&se
, NULL
);
103 gfc_start_block (&se
.pre
);
104 gfc_conv_label_variable (&se
, code
->expr1
);
106 len
= GFC_DECL_STRING_LEN (se
.expr
);
107 addr
= GFC_DECL_ASSIGN_ADDR (se
.expr
);
109 label_tree
= gfc_get_label_decl (code
->label1
);
111 if (code
->label1
->defined
== ST_LABEL_TARGET
)
113 label_tree
= gfc_build_addr_expr (pvoid_type_node
, label_tree
);
114 len_tree
= integer_minus_one_node
;
118 gfc_expr
*format
= code
->label1
->format
;
120 label_len
= format
->value
.character
.length
;
121 len_tree
= build_int_cst (NULL_TREE
, label_len
);
122 label_tree
= gfc_build_wide_string_const (format
->ts
.kind
, label_len
+ 1,
123 format
->value
.character
.string
);
124 label_tree
= gfc_build_addr_expr (pvoid_type_node
, label_tree
);
127 gfc_add_modify (&se
.pre
, len
, len_tree
);
128 gfc_add_modify (&se
.pre
, addr
, label_tree
);
130 return gfc_finish_block (&se
.pre
);
133 /* Translate a GOTO statement. */
136 gfc_trans_goto (gfc_code
* code
)
138 locus loc
= code
->loc
;
144 if (code
->label1
!= NULL
)
145 return build1_v (GOTO_EXPR
, gfc_get_label_decl (code
->label1
));
148 gfc_init_se (&se
, NULL
);
149 gfc_start_block (&se
.pre
);
150 gfc_conv_label_variable (&se
, code
->expr1
);
151 tmp
= GFC_DECL_STRING_LEN (se
.expr
);
152 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, tmp
,
153 build_int_cst (TREE_TYPE (tmp
), -1));
154 gfc_trans_runtime_check (true, false, tmp
, &se
.pre
, &loc
,
155 "Assigned label is not a target label");
157 assigned_goto
= GFC_DECL_ASSIGN_ADDR (se
.expr
);
159 /* We're going to ignore a label list. It does not really change the
160 statement's semantics (because it is just a further restriction on
161 what's legal code); before, we were comparing label addresses here, but
162 that's a very fragile business and may break with optimization. So
165 target
= fold_build1_loc (input_location
, GOTO_EXPR
, void_type_node
,
167 gfc_add_expr_to_block (&se
.pre
, target
);
168 return gfc_finish_block (&se
.pre
);
172 /* Translate an ENTRY statement. Just adds a label for this entry point. */
174 gfc_trans_entry (gfc_code
* code
)
176 return build1_v (LABEL_EXPR
, code
->ext
.entry
->label
);
180 /* Check for dependencies between INTENT(IN) and INTENT(OUT) arguments of
181 elemental subroutines. Make temporaries for output arguments if any such
182 dependencies are found. Output arguments are chosen because internal_unpack
183 can be used, as is, to copy the result back to the variable. */
185 gfc_conv_elemental_dependencies (gfc_se
* se
, gfc_se
* loopse
,
186 gfc_symbol
* sym
, gfc_actual_arglist
* arg
,
187 gfc_dep_check check_variable
)
189 gfc_actual_arglist
*arg0
;
191 gfc_formal_arglist
*formal
;
192 gfc_loopinfo tmp_loop
;
204 if (loopse
->ss
== NULL
)
209 formal
= sym
->formal
;
211 /* Loop over all the arguments testing for dependencies. */
212 for (; arg
!= NULL
; arg
= arg
->next
, formal
= formal
? formal
->next
: NULL
)
218 /* Obtain the info structure for the current argument. */
220 for (ss
= loopse
->ss
; ss
&& ss
!= gfc_ss_terminator
; ss
= ss
->next
)
224 info
= &ss
->data
.info
;
228 /* If there is a dependency, create a temporary and use it
229 instead of the variable. */
230 fsym
= formal
? formal
->sym
: NULL
;
231 if (e
->expr_type
== EXPR_VARIABLE
233 && fsym
->attr
.intent
!= INTENT_IN
234 && gfc_check_fncall_dependency (e
, fsym
->attr
.intent
,
235 sym
, arg0
, check_variable
))
237 tree initial
, temptype
;
238 stmtblock_t temp_post
;
240 /* Make a local loopinfo for the temporary creation, so that
241 none of the other ss->info's have to be renormalized. */
242 gfc_init_loopinfo (&tmp_loop
);
243 tmp_loop
.dimen
= info
->dimen
;
244 for (n
= 0; n
< info
->dimen
; n
++)
246 tmp_loop
.to
[n
] = loopse
->loop
->to
[n
];
247 tmp_loop
.from
[n
] = loopse
->loop
->from
[n
];
248 tmp_loop
.order
[n
] = loopse
->loop
->order
[n
];
251 /* Obtain the argument descriptor for unpacking. */
252 gfc_init_se (&parmse
, NULL
);
253 parmse
.want_pointer
= 1;
255 /* The scalarizer introduces some specific peculiarities when
256 handling elemental subroutines; the stride can be needed up to
257 the dim_array - 1, rather than dim_loop - 1 to calculate
258 offsets outside the loop. For this reason, we make sure that
259 the descriptor has the dimensionality of the array by converting
260 trailing elements into ranges with end = start. */
261 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
262 if (ref
->type
== REF_ARRAY
&& ref
->u
.ar
.type
== AR_SECTION
)
267 bool seen_range
= false;
268 for (n
= 0; n
< ref
->u
.ar
.dimen
; n
++)
270 if (ref
->u
.ar
.dimen_type
[n
] == DIMEN_RANGE
)
274 || ref
->u
.ar
.dimen_type
[n
] != DIMEN_ELEMENT
)
277 ref
->u
.ar
.end
[n
] = gfc_copy_expr (ref
->u
.ar
.start
[n
]);
278 ref
->u
.ar
.dimen_type
[n
] = DIMEN_RANGE
;
282 gfc_conv_expr_descriptor (&parmse
, e
, gfc_walk_expr (e
));
283 gfc_add_block_to_block (&se
->pre
, &parmse
.pre
);
285 /* If we've got INTENT(INOUT) or a derived type with INTENT(OUT),
286 initialize the array temporary with a copy of the values. */
287 if (fsym
->attr
.intent
== INTENT_INOUT
288 || (fsym
->ts
.type
==BT_DERIVED
289 && fsym
->attr
.intent
== INTENT_OUT
))
290 initial
= parmse
.expr
;
294 /* Find the type of the temporary to create; we don't use the type
295 of e itself as this breaks for subcomponent-references in e (where
296 the type of e is that of the final reference, but parmse.expr's
297 type corresponds to the full derived-type). */
298 /* TODO: Fix this somehow so we don't need a temporary of the whole
299 array but instead only the components referenced. */
300 temptype
= TREE_TYPE (parmse
.expr
); /* Pointer to descriptor. */
301 gcc_assert (TREE_CODE (temptype
) == POINTER_TYPE
);
302 temptype
= TREE_TYPE (temptype
);
303 temptype
= gfc_get_element_type (temptype
);
305 /* Generate the temporary. Cleaning up the temporary should be the
306 very last thing done, so we add the code to a new block and add it
307 to se->post as last instructions. */
308 size
= gfc_create_var (gfc_array_index_type
, NULL
);
309 data
= gfc_create_var (pvoid_type_node
, NULL
);
310 gfc_init_block (&temp_post
);
311 tmp
= gfc_trans_create_temp_array (&se
->pre
, &temp_post
,
312 &tmp_loop
, info
, temptype
,
316 gfc_add_modify (&se
->pre
, size
, tmp
);
317 tmp
= fold_convert (pvoid_type_node
, info
->data
);
318 gfc_add_modify (&se
->pre
, data
, tmp
);
320 /* Calculate the offset for the temporary. */
321 offset
= gfc_index_zero_node
;
322 for (n
= 0; n
< info
->dimen
; n
++)
324 tmp
= gfc_conv_descriptor_stride_get (info
->descriptor
,
326 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
327 gfc_array_index_type
,
328 loopse
->loop
->from
[n
], tmp
);
329 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
330 gfc_array_index_type
, offset
, tmp
);
332 info
->offset
= gfc_create_var (gfc_array_index_type
, NULL
);
333 gfc_add_modify (&se
->pre
, info
->offset
, offset
);
335 /* Copy the result back using unpack. */
336 tmp
= build_call_expr_loc (input_location
,
337 gfor_fndecl_in_unpack
, 2, parmse
.expr
, data
);
338 gfc_add_expr_to_block (&se
->post
, tmp
);
340 /* parmse.pre is already added above. */
341 gfc_add_block_to_block (&se
->post
, &parmse
.post
);
342 gfc_add_block_to_block (&se
->post
, &temp_post
);
348 /* Translate the CALL statement. Builds a call to an F95 subroutine. */
351 gfc_trans_call (gfc_code
* code
, bool dependency_check
,
352 tree mask
, tree count1
, bool invert
)
356 int has_alternate_specifier
;
357 gfc_dep_check check_variable
;
358 tree index
= NULL_TREE
;
359 tree maskexpr
= NULL_TREE
;
362 /* A CALL starts a new block because the actual arguments may have to
363 be evaluated first. */
364 gfc_init_se (&se
, NULL
);
365 gfc_start_block (&se
.pre
);
367 gcc_assert (code
->resolved_sym
);
369 ss
= gfc_ss_terminator
;
370 if (code
->resolved_sym
->attr
.elemental
)
371 ss
= gfc_walk_elemental_function_args (ss
, code
->ext
.actual
, GFC_SS_REFERENCE
);
373 /* Is not an elemental subroutine call with array valued arguments. */
374 if (ss
== gfc_ss_terminator
)
377 /* Translate the call. */
378 has_alternate_specifier
379 = gfc_conv_procedure_call (&se
, code
->resolved_sym
, code
->ext
.actual
,
382 /* A subroutine without side-effect, by definition, does nothing! */
383 TREE_SIDE_EFFECTS (se
.expr
) = 1;
385 /* Chain the pieces together and return the block. */
386 if (has_alternate_specifier
)
388 gfc_code
*select_code
;
390 select_code
= code
->next
;
391 gcc_assert(select_code
->op
== EXEC_SELECT
);
392 sym
= select_code
->expr1
->symtree
->n
.sym
;
393 se
.expr
= convert (gfc_typenode_for_spec (&sym
->ts
), se
.expr
);
394 if (sym
->backend_decl
== NULL
)
395 sym
->backend_decl
= gfc_get_symbol_decl (sym
);
396 gfc_add_modify (&se
.pre
, sym
->backend_decl
, se
.expr
);
399 gfc_add_expr_to_block (&se
.pre
, se
.expr
);
401 gfc_add_block_to_block (&se
.pre
, &se
.post
);
406 /* An elemental subroutine call with array valued arguments has
414 /* gfc_walk_elemental_function_args renders the ss chain in the
415 reverse order to the actual argument order. */
416 ss
= gfc_reverse_ss (ss
);
418 /* Initialize the loop. */
419 gfc_init_se (&loopse
, NULL
);
420 gfc_init_loopinfo (&loop
);
421 gfc_add_ss_to_loop (&loop
, ss
);
423 gfc_conv_ss_startstride (&loop
);
424 /* TODO: gfc_conv_loop_setup generates a temporary for vector
425 subscripts. This could be prevented in the elemental case
426 as temporaries are handled separatedly
427 (below in gfc_conv_elemental_dependencies). */
428 gfc_conv_loop_setup (&loop
, &code
->expr1
->where
);
429 gfc_mark_ss_chain_used (ss
, 1);
431 /* Convert the arguments, checking for dependencies. */
432 gfc_copy_loopinfo_to_se (&loopse
, &loop
);
435 /* For operator assignment, do dependency checking. */
436 if (dependency_check
)
437 check_variable
= ELEM_CHECK_VARIABLE
;
439 check_variable
= ELEM_DONT_CHECK_VARIABLE
;
441 gfc_init_se (&depse
, NULL
);
442 gfc_conv_elemental_dependencies (&depse
, &loopse
, code
->resolved_sym
,
443 code
->ext
.actual
, check_variable
);
445 gfc_add_block_to_block (&loop
.pre
, &depse
.pre
);
446 gfc_add_block_to_block (&loop
.post
, &depse
.post
);
448 /* Generate the loop body. */
449 gfc_start_scalarized_body (&loop
, &body
);
450 gfc_init_block (&block
);
454 /* Form the mask expression according to the mask. */
456 maskexpr
= gfc_build_array_ref (mask
, index
, NULL
);
458 maskexpr
= fold_build1_loc (input_location
, TRUTH_NOT_EXPR
,
459 TREE_TYPE (maskexpr
), maskexpr
);
462 /* Add the subroutine call to the block. */
463 gfc_conv_procedure_call (&loopse
, code
->resolved_sym
,
464 code
->ext
.actual
, code
->expr1
, NULL
);
468 tmp
= build3_v (COND_EXPR
, maskexpr
, loopse
.expr
,
469 build_empty_stmt (input_location
));
470 gfc_add_expr_to_block (&loopse
.pre
, tmp
);
471 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
472 gfc_array_index_type
,
473 count1
, gfc_index_one_node
);
474 gfc_add_modify (&loopse
.pre
, count1
, tmp
);
477 gfc_add_expr_to_block (&loopse
.pre
, loopse
.expr
);
479 gfc_add_block_to_block (&block
, &loopse
.pre
);
480 gfc_add_block_to_block (&block
, &loopse
.post
);
482 /* Finish up the loop block and the loop. */
483 gfc_add_expr_to_block (&body
, gfc_finish_block (&block
));
484 gfc_trans_scalarizing_loops (&loop
, &body
);
485 gfc_add_block_to_block (&se
.pre
, &loop
.pre
);
486 gfc_add_block_to_block (&se
.pre
, &loop
.post
);
487 gfc_add_block_to_block (&se
.pre
, &se
.post
);
488 gfc_cleanup_loop (&loop
);
491 return gfc_finish_block (&se
.pre
);
495 /* Translate the RETURN statement. */
498 gfc_trans_return (gfc_code
* code
)
506 /* If code->expr is not NULL, this return statement must appear
507 in a subroutine and current_fake_result_decl has already
510 result
= gfc_get_fake_result_decl (NULL
, 0);
513 gfc_warning ("An alternate return at %L without a * dummy argument",
514 &code
->expr1
->where
);
515 return gfc_generate_return ();
518 /* Start a new block for this statement. */
519 gfc_init_se (&se
, NULL
);
520 gfc_start_block (&se
.pre
);
522 gfc_conv_expr (&se
, code
->expr1
);
524 /* Note that the actually returned expression is a simple value and
525 does not depend on any pointers or such; thus we can clean-up with
526 se.post before returning. */
527 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
, TREE_TYPE (result
),
528 result
, fold_convert (TREE_TYPE (result
),
530 gfc_add_expr_to_block (&se
.pre
, tmp
);
531 gfc_add_block_to_block (&se
.pre
, &se
.post
);
533 tmp
= gfc_generate_return ();
534 gfc_add_expr_to_block (&se
.pre
, tmp
);
535 return gfc_finish_block (&se
.pre
);
538 return gfc_generate_return ();
542 /* Translate the PAUSE statement. We have to translate this statement
543 to a runtime library call. */
546 gfc_trans_pause (gfc_code
* code
)
548 tree gfc_int4_type_node
= gfc_get_int_type (4);
552 /* Start a new block for this statement. */
553 gfc_init_se (&se
, NULL
);
554 gfc_start_block (&se
.pre
);
557 if (code
->expr1
== NULL
)
559 tmp
= build_int_cst (gfc_int4_type_node
, 0);
560 tmp
= build_call_expr_loc (input_location
,
561 gfor_fndecl_pause_string
, 2,
562 build_int_cst (pchar_type_node
, 0), tmp
);
564 else if (code
->expr1
->ts
.type
== BT_INTEGER
)
566 gfc_conv_expr (&se
, code
->expr1
);
567 tmp
= build_call_expr_loc (input_location
,
568 gfor_fndecl_pause_numeric
, 1,
569 fold_convert (gfc_int4_type_node
, se
.expr
));
573 gfc_conv_expr_reference (&se
, code
->expr1
);
574 tmp
= build_call_expr_loc (input_location
,
575 gfor_fndecl_pause_string
, 2,
576 se
.expr
, se
.string_length
);
579 gfc_add_expr_to_block (&se
.pre
, tmp
);
581 gfc_add_block_to_block (&se
.pre
, &se
.post
);
583 return gfc_finish_block (&se
.pre
);
587 /* Translate the STOP statement. We have to translate this statement
588 to a runtime library call. */
591 gfc_trans_stop (gfc_code
*code
, bool error_stop
)
593 tree gfc_int4_type_node
= gfc_get_int_type (4);
597 /* Start a new block for this statement. */
598 gfc_init_se (&se
, NULL
);
599 gfc_start_block (&se
.pre
);
601 if (code
->expr1
== NULL
)
603 tmp
= build_int_cst (gfc_int4_type_node
, 0);
604 tmp
= build_call_expr_loc (input_location
,
605 error_stop
? gfor_fndecl_error_stop_string
606 : gfor_fndecl_stop_string
,
607 2, build_int_cst (pchar_type_node
, 0), tmp
);
609 else if (code
->expr1
->ts
.type
== BT_INTEGER
)
611 gfc_conv_expr (&se
, code
->expr1
);
612 tmp
= build_call_expr_loc (input_location
,
613 error_stop
? gfor_fndecl_error_stop_numeric
614 : gfor_fndecl_stop_numeric
, 1,
615 fold_convert (gfc_int4_type_node
, se
.expr
));
619 gfc_conv_expr_reference (&se
, code
->expr1
);
620 tmp
= build_call_expr_loc (input_location
,
621 error_stop
? gfor_fndecl_error_stop_string
622 : gfor_fndecl_stop_string
,
623 2, se
.expr
, se
.string_length
);
626 gfc_add_expr_to_block (&se
.pre
, tmp
);
628 gfc_add_block_to_block (&se
.pre
, &se
.post
);
630 return gfc_finish_block (&se
.pre
);
635 gfc_trans_sync (gfc_code
*code
, gfc_exec_op type
__attribute__ ((unused
)))
639 if ((code
->expr1
&& (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)) || code
->expr2
)
641 gfc_init_se (&se
, NULL
);
642 gfc_start_block (&se
.pre
);
645 /* Check SYNC IMAGES(imageset) for valid image index.
646 FIXME: Add a check for image-set arrays. */
647 if (code
->expr1
&& (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
648 && code
->expr1
->rank
== 0)
651 gfc_conv_expr (&se
, code
->expr1
);
652 cond
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
653 se
.expr
, build_int_cst (TREE_TYPE (se
.expr
), 1));
654 gfc_trans_runtime_check (true, false, cond
, &se
.pre
,
655 &code
->expr1
->where
, "Invalid image number "
657 fold_convert (integer_type_node
, se
.expr
));
660 /* If STAT is present, set it to zero. */
663 gcc_assert (code
->expr2
->expr_type
== EXPR_VARIABLE
);
664 gfc_conv_expr (&se
, code
->expr2
);
665 gfc_add_modify (&se
.pre
, se
.expr
, build_int_cst (TREE_TYPE (se
.expr
), 0));
668 if ((code
->expr1
&& (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)) || code
->expr2
)
669 return gfc_finish_block (&se
.pre
);
675 /* Generate GENERIC for the IF construct. This function also deals with
676 the simple IF statement, because the front end translates the IF
677 statement into an IF construct.
709 where COND_S is the simplified version of the predicate. PRE_COND_S
710 are the pre side-effects produced by the translation of the
712 We need to build the chain recursively otherwise we run into
713 problems with folding incomplete statements. */
716 gfc_trans_if_1 (gfc_code
* code
)
722 /* Check for an unconditional ELSE clause. */
724 return gfc_trans_code (code
->next
);
726 /* Initialize a statement builder for each block. Puts in NULL_TREEs. */
727 gfc_init_se (&if_se
, NULL
);
728 gfc_start_block (&if_se
.pre
);
730 /* Calculate the IF condition expression. */
731 gfc_conv_expr_val (&if_se
, code
->expr1
);
733 /* Translate the THEN clause. */
734 stmt
= gfc_trans_code (code
->next
);
736 /* Translate the ELSE clause. */
738 elsestmt
= gfc_trans_if_1 (code
->block
);
740 elsestmt
= build_empty_stmt (input_location
);
742 /* Build the condition expression and add it to the condition block. */
743 loc
= code
->expr1
->where
.lb
? code
->expr1
->where
.lb
->location
: input_location
;
744 stmt
= fold_build3_loc (loc
, COND_EXPR
, void_type_node
, if_se
.expr
, stmt
,
747 gfc_add_expr_to_block (&if_se
.pre
, stmt
);
749 /* Finish off this statement. */
750 return gfc_finish_block (&if_se
.pre
);
754 gfc_trans_if (gfc_code
* code
)
759 /* Create exit label so it is available for trans'ing the body code. */
760 exit_label
= gfc_build_label_decl (NULL_TREE
);
761 code
->exit_label
= exit_label
;
763 /* Translate the actual code in code->block. */
764 gfc_init_block (&body
);
765 gfc_add_expr_to_block (&body
, gfc_trans_if_1 (code
->block
));
767 /* Add exit label. */
768 gfc_add_expr_to_block (&body
, build1_v (LABEL_EXPR
, exit_label
));
770 return gfc_finish_block (&body
);
774 /* Translate an arithmetic IF expression.
776 IF (cond) label1, label2, label3 translates to
788 An optimized version can be generated in case of equal labels.
789 E.g., if label1 is equal to label2, we can translate it to
798 gfc_trans_arithmetic_if (gfc_code
* code
)
806 /* Start a new block. */
807 gfc_init_se (&se
, NULL
);
808 gfc_start_block (&se
.pre
);
810 /* Pre-evaluate COND. */
811 gfc_conv_expr_val (&se
, code
->expr1
);
812 se
.expr
= gfc_evaluate_now (se
.expr
, &se
.pre
);
814 /* Build something to compare with. */
815 zero
= gfc_build_const (TREE_TYPE (se
.expr
), integer_zero_node
);
817 if (code
->label1
->value
!= code
->label2
->value
)
819 /* If (cond < 0) take branch1 else take branch2.
820 First build jumps to the COND .LT. 0 and the COND .EQ. 0 cases. */
821 branch1
= build1_v (GOTO_EXPR
, gfc_get_label_decl (code
->label1
));
822 branch2
= build1_v (GOTO_EXPR
, gfc_get_label_decl (code
->label2
));
824 if (code
->label1
->value
!= code
->label3
->value
)
825 tmp
= fold_build2_loc (input_location
, LT_EXPR
, boolean_type_node
,
828 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
,
831 branch1
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
832 tmp
, branch1
, branch2
);
835 branch1
= build1_v (GOTO_EXPR
, gfc_get_label_decl (code
->label1
));
837 if (code
->label1
->value
!= code
->label3
->value
838 && code
->label2
->value
!= code
->label3
->value
)
840 /* if (cond <= 0) take branch1 else take branch2. */
841 branch2
= build1_v (GOTO_EXPR
, gfc_get_label_decl (code
->label3
));
842 tmp
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
,
844 branch1
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
845 tmp
, branch1
, branch2
);
848 /* Append the COND_EXPR to the evaluation of COND, and return. */
849 gfc_add_expr_to_block (&se
.pre
, branch1
);
850 return gfc_finish_block (&se
.pre
);
854 /* Translate a CRITICAL block. */
856 gfc_trans_critical (gfc_code
*code
)
861 gfc_start_block (&block
);
862 tmp
= gfc_trans_code (code
->block
->next
);
863 gfc_add_expr_to_block (&block
, tmp
);
865 return gfc_finish_block (&block
);
869 /* Translate a BLOCK construct. This is basically what we would do for a
873 gfc_trans_block_construct (gfc_code
* code
)
877 gfc_wrapped_block block
;
881 ns
= code
->ext
.block
.ns
;
886 /* Process local variables. */
887 gcc_assert (!sym
->tlink
);
889 gfc_process_block_locals (ns
, code
->ext
.block
.assoc
);
891 /* Generate code including exit-label. */
892 gfc_init_block (&body
);
893 exit_label
= gfc_build_label_decl (NULL_TREE
);
894 code
->exit_label
= exit_label
;
895 gfc_add_expr_to_block (&body
, gfc_trans_code (ns
->code
));
896 gfc_add_expr_to_block (&body
, build1_v (LABEL_EXPR
, exit_label
));
898 /* Finish everything. */
899 gfc_start_wrapped_block (&block
, gfc_finish_block (&body
));
900 gfc_trans_deferred_vars (sym
, &block
);
902 return gfc_finish_wrapped_block (&block
);
906 /* Translate the simple DO construct. This is where the loop variable has
907 integer type and step +-1. We can't use this in the general case
908 because integer overflow and floating point errors could give incorrect
910 We translate a do loop from:
912 DO dovar = from, to, step
918 [Evaluate loop bounds and step]
920 if ((step > 0) ? (dovar <= to) : (dovar => to))
926 cond = (dovar == to);
928 if (cond) goto end_label;
933 This helps the optimizers by avoiding the extra induction variable
934 used in the general case. */
937 gfc_trans_simple_do (gfc_code
* code
, stmtblock_t
*pblock
, tree dovar
,
938 tree from
, tree to
, tree step
, tree exit_cond
)
944 tree saved_dovar
= NULL
;
949 type
= TREE_TYPE (dovar
);
951 loc
= code
->ext
.iterator
->start
->where
.lb
->location
;
953 /* Initialize the DO variable: dovar = from. */
954 gfc_add_modify_loc (loc
, pblock
, dovar
, from
);
956 /* Save value for do-tinkering checking. */
957 if (gfc_option
.rtcheck
& GFC_RTCHECK_DO
)
959 saved_dovar
= gfc_create_var (type
, ".saved_dovar");
960 gfc_add_modify_loc (loc
, pblock
, saved_dovar
, dovar
);
963 /* Cycle and exit statements are implemented with gotos. */
964 cycle_label
= gfc_build_label_decl (NULL_TREE
);
965 exit_label
= gfc_build_label_decl (NULL_TREE
);
967 /* Put the labels where they can be found later. See gfc_trans_do(). */
968 code
->cycle_label
= cycle_label
;
969 code
->exit_label
= exit_label
;
972 gfc_start_block (&body
);
974 /* Main loop body. */
975 tmp
= gfc_trans_code_cond (code
->block
->next
, exit_cond
);
976 gfc_add_expr_to_block (&body
, tmp
);
978 /* Label for cycle statements (if needed). */
979 if (TREE_USED (cycle_label
))
981 tmp
= build1_v (LABEL_EXPR
, cycle_label
);
982 gfc_add_expr_to_block (&body
, tmp
);
985 /* Check whether someone has modified the loop variable. */
986 if (gfc_option
.rtcheck
& GFC_RTCHECK_DO
)
988 tmp
= fold_build2_loc (loc
, NE_EXPR
, boolean_type_node
,
990 gfc_trans_runtime_check (true, false, tmp
, &body
, &code
->loc
,
991 "Loop variable has been modified");
994 /* Exit the loop if there is an I/O result condition or error. */
997 tmp
= build1_v (GOTO_EXPR
, exit_label
);
998 tmp
= fold_build3_loc (loc
, COND_EXPR
, void_type_node
,
1000 build_empty_stmt (loc
));
1001 gfc_add_expr_to_block (&body
, tmp
);
1004 /* Evaluate the loop condition. */
1005 cond
= fold_build2_loc (loc
, EQ_EXPR
, boolean_type_node
, dovar
,
1007 cond
= gfc_evaluate_now_loc (loc
, cond
, &body
);
1009 /* Increment the loop variable. */
1010 tmp
= fold_build2_loc (loc
, PLUS_EXPR
, type
, dovar
, step
);
1011 gfc_add_modify_loc (loc
, &body
, dovar
, tmp
);
1013 if (gfc_option
.rtcheck
& GFC_RTCHECK_DO
)
1014 gfc_add_modify_loc (loc
, &body
, saved_dovar
, dovar
);
1016 /* The loop exit. */
1017 tmp
= fold_build1_loc (loc
, GOTO_EXPR
, void_type_node
, exit_label
);
1018 TREE_USED (exit_label
) = 1;
1019 tmp
= fold_build3_loc (loc
, COND_EXPR
, void_type_node
,
1020 cond
, tmp
, build_empty_stmt (loc
));
1021 gfc_add_expr_to_block (&body
, tmp
);
1023 /* Finish the loop body. */
1024 tmp
= gfc_finish_block (&body
);
1025 tmp
= fold_build1_loc (loc
, LOOP_EXPR
, void_type_node
, tmp
);
1027 /* Only execute the loop if the number of iterations is positive. */
1028 if (tree_int_cst_sgn (step
) > 0)
1029 cond
= fold_build2_loc (loc
, LE_EXPR
, boolean_type_node
, dovar
,
1032 cond
= fold_build2_loc (loc
, GE_EXPR
, boolean_type_node
, dovar
,
1034 tmp
= fold_build3_loc (loc
, COND_EXPR
, void_type_node
, cond
, tmp
,
1035 build_empty_stmt (loc
));
1036 gfc_add_expr_to_block (pblock
, tmp
);
1038 /* Add the exit label. */
1039 tmp
= build1_v (LABEL_EXPR
, exit_label
);
1040 gfc_add_expr_to_block (pblock
, tmp
);
1042 return gfc_finish_block (pblock
);
1045 /* Translate the DO construct. This obviously is one of the most
1046 important ones to get right with any compiler, but especially
1049 We special case some loop forms as described in gfc_trans_simple_do.
1050 For other cases we implement them with a separate loop count,
1051 as described in the standard.
1053 We translate a do loop from:
1055 DO dovar = from, to, step
1061 [evaluate loop bounds and step]
1062 empty = (step > 0 ? to < from : to > from);
1063 countm1 = (to - from) / step;
1065 if (empty) goto exit_label;
1071 if (countm1 ==0) goto exit_label;
1076 countm1 is an unsigned integer. It is equal to the loop count minus one,
1077 because the loop count itself can overflow. */
1080 gfc_trans_do (gfc_code
* code
, tree exit_cond
)
1084 tree saved_dovar
= NULL
;
1100 gfc_start_block (&block
);
1102 loc
= code
->ext
.iterator
->start
->where
.lb
->location
;
1104 /* Evaluate all the expressions in the iterator. */
1105 gfc_init_se (&se
, NULL
);
1106 gfc_conv_expr_lhs (&se
, code
->ext
.iterator
->var
);
1107 gfc_add_block_to_block (&block
, &se
.pre
);
1109 type
= TREE_TYPE (dovar
);
1111 gfc_init_se (&se
, NULL
);
1112 gfc_conv_expr_val (&se
, code
->ext
.iterator
->start
);
1113 gfc_add_block_to_block (&block
, &se
.pre
);
1114 from
= gfc_evaluate_now (se
.expr
, &block
);
1116 gfc_init_se (&se
, NULL
);
1117 gfc_conv_expr_val (&se
, code
->ext
.iterator
->end
);
1118 gfc_add_block_to_block (&block
, &se
.pre
);
1119 to
= gfc_evaluate_now (se
.expr
, &block
);
1121 gfc_init_se (&se
, NULL
);
1122 gfc_conv_expr_val (&se
, code
->ext
.iterator
->step
);
1123 gfc_add_block_to_block (&block
, &se
.pre
);
1124 step
= gfc_evaluate_now (se
.expr
, &block
);
1126 if (gfc_option
.rtcheck
& GFC_RTCHECK_DO
)
1128 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, boolean_type_node
, step
,
1129 fold_convert (type
, integer_zero_node
));
1130 gfc_trans_runtime_check (true, false, tmp
, &block
, &code
->loc
,
1131 "DO step value is zero");
1134 /* Special case simple loops. */
1135 if (TREE_CODE (type
) == INTEGER_TYPE
1136 && (integer_onep (step
)
1137 || tree_int_cst_equal (step
, integer_minus_one_node
)))
1138 return gfc_trans_simple_do (code
, &block
, dovar
, from
, to
, step
, exit_cond
);
1140 pos_step
= fold_build2_loc (loc
, GT_EXPR
, boolean_type_node
, step
,
1141 fold_convert (type
, integer_zero_node
));
1143 if (TREE_CODE (type
) == INTEGER_TYPE
)
1144 utype
= unsigned_type_for (type
);
1146 utype
= unsigned_type_for (gfc_array_index_type
);
1147 countm1
= gfc_create_var (utype
, "countm1");
1149 /* Cycle and exit statements are implemented with gotos. */
1150 cycle_label
= gfc_build_label_decl (NULL_TREE
);
1151 exit_label
= gfc_build_label_decl (NULL_TREE
);
1152 TREE_USED (exit_label
) = 1;
1154 /* Put these labels where they can be found later. */
1155 code
->cycle_label
= cycle_label
;
1156 code
->exit_label
= exit_label
;
1158 /* Initialize the DO variable: dovar = from. */
1159 gfc_add_modify (&block
, dovar
, from
);
1161 /* Save value for do-tinkering checking. */
1162 if (gfc_option
.rtcheck
& GFC_RTCHECK_DO
)
1164 saved_dovar
= gfc_create_var (type
, ".saved_dovar");
1165 gfc_add_modify_loc (loc
, &block
, saved_dovar
, dovar
);
1168 /* Initialize loop count and jump to exit label if the loop is empty.
1169 This code is executed before we enter the loop body. We generate:
1170 step_sign = sign(1,step);
1181 countm1 = (to*step_sign - from*step_sign) / (step*step_sign);
1185 if (TREE_CODE (type
) == INTEGER_TYPE
)
1187 tree pos
, neg
, step_sign
, to2
, from2
, step2
;
1189 /* Calculate SIGN (1,step), as (step < 0 ? -1 : 1) */
1191 tmp
= fold_build2_loc (loc
, LT_EXPR
, boolean_type_node
, step
,
1192 build_int_cst (TREE_TYPE (step
), 0));
1193 step_sign
= fold_build3_loc (loc
, COND_EXPR
, type
, tmp
,
1194 build_int_cst (type
, -1),
1195 build_int_cst (type
, 1));
1197 tmp
= fold_build2_loc (loc
, LT_EXPR
, boolean_type_node
, to
, from
);
1198 pos
= fold_build3_loc (loc
, COND_EXPR
, void_type_node
, tmp
,
1199 fold_build1_loc (loc
, GOTO_EXPR
, void_type_node
,
1201 build_empty_stmt (loc
));
1203 tmp
= fold_build2_loc (loc
, GT_EXPR
, boolean_type_node
, to
,
1205 neg
= fold_build3_loc (loc
, COND_EXPR
, void_type_node
, tmp
,
1206 fold_build1_loc (loc
, GOTO_EXPR
, void_type_node
,
1208 build_empty_stmt (loc
));
1209 tmp
= fold_build3_loc (loc
, COND_EXPR
, void_type_node
,
1210 pos_step
, pos
, neg
);
1212 gfc_add_expr_to_block (&block
, tmp
);
1214 /* Calculate the loop count. to-from can overflow, so
1215 we cast to unsigned. */
1217 to2
= fold_build2_loc (loc
, MULT_EXPR
, type
, step_sign
, to
);
1218 from2
= fold_build2_loc (loc
, MULT_EXPR
, type
, step_sign
, from
);
1219 step2
= fold_build2_loc (loc
, MULT_EXPR
, type
, step_sign
, step
);
1220 step2
= fold_convert (utype
, step2
);
1221 tmp
= fold_build2_loc (loc
, MINUS_EXPR
, type
, to2
, from2
);
1222 tmp
= fold_convert (utype
, tmp
);
1223 tmp
= fold_build2_loc (loc
, TRUNC_DIV_EXPR
, utype
, tmp
, step2
);
1224 tmp
= fold_build2_loc (loc
, MODIFY_EXPR
, void_type_node
, countm1
, tmp
);
1225 gfc_add_expr_to_block (&block
, tmp
);
1229 /* TODO: We could use the same width as the real type.
1230 This would probably cause more problems that it solves
1231 when we implement "long double" types. */
1233 tmp
= fold_build2_loc (loc
, MINUS_EXPR
, type
, to
, from
);
1234 tmp
= fold_build2_loc (loc
, RDIV_EXPR
, type
, tmp
, step
);
1235 tmp
= fold_build1_loc (loc
, FIX_TRUNC_EXPR
, utype
, tmp
);
1236 gfc_add_modify (&block
, countm1
, tmp
);
1238 /* We need a special check for empty loops:
1239 empty = (step > 0 ? to < from : to > from); */
1240 tmp
= fold_build3_loc (loc
, COND_EXPR
, boolean_type_node
, pos_step
,
1241 fold_build2_loc (loc
, LT_EXPR
,
1242 boolean_type_node
, to
, from
),
1243 fold_build2_loc (loc
, GT_EXPR
,
1244 boolean_type_node
, to
, from
));
1245 /* If the loop is empty, go directly to the exit label. */
1246 tmp
= fold_build3_loc (loc
, COND_EXPR
, void_type_node
, tmp
,
1247 build1_v (GOTO_EXPR
, exit_label
),
1248 build_empty_stmt (input_location
));
1249 gfc_add_expr_to_block (&block
, tmp
);
1253 gfc_start_block (&body
);
1255 /* Main loop body. */
1256 tmp
= gfc_trans_code_cond (code
->block
->next
, exit_cond
);
1257 gfc_add_expr_to_block (&body
, tmp
);
1259 /* Label for cycle statements (if needed). */
1260 if (TREE_USED (cycle_label
))
1262 tmp
= build1_v (LABEL_EXPR
, cycle_label
);
1263 gfc_add_expr_to_block (&body
, tmp
);
1266 /* Check whether someone has modified the loop variable. */
1267 if (gfc_option
.rtcheck
& GFC_RTCHECK_DO
)
1269 tmp
= fold_build2_loc (loc
, NE_EXPR
, boolean_type_node
, dovar
,
1271 gfc_trans_runtime_check (true, false, tmp
, &body
, &code
->loc
,
1272 "Loop variable has been modified");
1275 /* Exit the loop if there is an I/O result condition or error. */
1278 tmp
= build1_v (GOTO_EXPR
, exit_label
);
1279 tmp
= fold_build3_loc (loc
, COND_EXPR
, void_type_node
,
1281 build_empty_stmt (input_location
));
1282 gfc_add_expr_to_block (&body
, tmp
);
1285 /* Increment the loop variable. */
1286 tmp
= fold_build2_loc (loc
, PLUS_EXPR
, type
, dovar
, step
);
1287 gfc_add_modify_loc (loc
, &body
, dovar
, tmp
);
1289 if (gfc_option
.rtcheck
& GFC_RTCHECK_DO
)
1290 gfc_add_modify_loc (loc
, &body
, saved_dovar
, dovar
);
1292 /* End with the loop condition. Loop until countm1 == 0. */
1293 cond
= fold_build2_loc (loc
, EQ_EXPR
, boolean_type_node
, countm1
,
1294 build_int_cst (utype
, 0));
1295 tmp
= fold_build1_loc (loc
, GOTO_EXPR
, void_type_node
, exit_label
);
1296 tmp
= fold_build3_loc (loc
, COND_EXPR
, void_type_node
,
1297 cond
, tmp
, build_empty_stmt (loc
));
1298 gfc_add_expr_to_block (&body
, tmp
);
1300 /* Decrement the loop count. */
1301 tmp
= fold_build2_loc (loc
, MINUS_EXPR
, utype
, countm1
,
1302 build_int_cst (utype
, 1));
1303 gfc_add_modify_loc (loc
, &body
, countm1
, tmp
);
1305 /* End of loop body. */
1306 tmp
= gfc_finish_block (&body
);
1308 /* The for loop itself. */
1309 tmp
= fold_build1_loc (loc
, LOOP_EXPR
, void_type_node
, tmp
);
1310 gfc_add_expr_to_block (&block
, tmp
);
1312 /* Add the exit label. */
1313 tmp
= build1_v (LABEL_EXPR
, exit_label
);
1314 gfc_add_expr_to_block (&block
, tmp
);
1316 return gfc_finish_block (&block
);
1320 /* Translate the DO WHILE construct.
1333 if (! cond) goto exit_label;
1339 Because the evaluation of the exit condition `cond' may have side
1340 effects, we can't do much for empty loop bodies. The backend optimizers
1341 should be smart enough to eliminate any dead loops. */
1344 gfc_trans_do_while (gfc_code
* code
)
1352 /* Everything we build here is part of the loop body. */
1353 gfc_start_block (&block
);
1355 /* Cycle and exit statements are implemented with gotos. */
1356 cycle_label
= gfc_build_label_decl (NULL_TREE
);
1357 exit_label
= gfc_build_label_decl (NULL_TREE
);
1359 /* Put the labels where they can be found later. See gfc_trans_do(). */
1360 code
->cycle_label
= cycle_label
;
1361 code
->exit_label
= exit_label
;
1363 /* Create a GIMPLE version of the exit condition. */
1364 gfc_init_se (&cond
, NULL
);
1365 gfc_conv_expr_val (&cond
, code
->expr1
);
1366 gfc_add_block_to_block (&block
, &cond
.pre
);
1367 cond
.expr
= fold_build1_loc (code
->expr1
->where
.lb
->location
,
1368 TRUTH_NOT_EXPR
, boolean_type_node
, cond
.expr
);
1370 /* Build "IF (! cond) GOTO exit_label". */
1371 tmp
= build1_v (GOTO_EXPR
, exit_label
);
1372 TREE_USED (exit_label
) = 1;
1373 tmp
= fold_build3_loc (code
->expr1
->where
.lb
->location
, COND_EXPR
,
1374 void_type_node
, cond
.expr
, tmp
,
1375 build_empty_stmt (code
->expr1
->where
.lb
->location
));
1376 gfc_add_expr_to_block (&block
, tmp
);
1378 /* The main body of the loop. */
1379 tmp
= gfc_trans_code (code
->block
->next
);
1380 gfc_add_expr_to_block (&block
, tmp
);
1382 /* Label for cycle statements (if needed). */
1383 if (TREE_USED (cycle_label
))
1385 tmp
= build1_v (LABEL_EXPR
, cycle_label
);
1386 gfc_add_expr_to_block (&block
, tmp
);
1389 /* End of loop body. */
1390 tmp
= gfc_finish_block (&block
);
1392 gfc_init_block (&block
);
1393 /* Build the loop. */
1394 tmp
= fold_build1_loc (code
->expr1
->where
.lb
->location
, LOOP_EXPR
,
1395 void_type_node
, tmp
);
1396 gfc_add_expr_to_block (&block
, tmp
);
1398 /* Add the exit label. */
1399 tmp
= build1_v (LABEL_EXPR
, exit_label
);
1400 gfc_add_expr_to_block (&block
, tmp
);
1402 return gfc_finish_block (&block
);
1406 /* Translate the SELECT CASE construct for INTEGER case expressions,
1407 without killing all potential optimizations. The problem is that
1408 Fortran allows unbounded cases, but the back-end does not, so we
1409 need to intercept those before we enter the equivalent SWITCH_EXPR
1412 For example, we translate this,
1415 CASE (:100,101,105:115)
1425 to the GENERIC equivalent,
1429 case (minimum value for typeof(expr) ... 100:
1435 case 200 ... (maximum value for typeof(expr):
1452 gfc_trans_integer_select (gfc_code
* code
)
1462 gfc_start_block (&block
);
1464 /* Calculate the switch expression. */
1465 gfc_init_se (&se
, NULL
);
1466 gfc_conv_expr_val (&se
, code
->expr1
);
1467 gfc_add_block_to_block (&block
, &se
.pre
);
1469 end_label
= gfc_build_label_decl (NULL_TREE
);
1471 gfc_init_block (&body
);
1473 for (c
= code
->block
; c
; c
= c
->block
)
1475 for (cp
= c
->ext
.case_list
; cp
; cp
= cp
->next
)
1480 /* Assume it's the default case. */
1481 low
= high
= NULL_TREE
;
1485 low
= gfc_conv_mpz_to_tree (cp
->low
->value
.integer
,
1488 /* If there's only a lower bound, set the high bound to the
1489 maximum value of the case expression. */
1491 high
= TYPE_MAX_VALUE (TREE_TYPE (se
.expr
));
1496 /* Three cases are possible here:
1498 1) There is no lower bound, e.g. CASE (:N).
1499 2) There is a lower bound .NE. high bound, that is
1500 a case range, e.g. CASE (N:M) where M>N (we make
1501 sure that M>N during type resolution).
1502 3) There is a lower bound, and it has the same value
1503 as the high bound, e.g. CASE (N:N). This is our
1504 internal representation of CASE(N).
1506 In the first and second case, we need to set a value for
1507 high. In the third case, we don't because the GCC middle
1508 end represents a single case value by just letting high be
1509 a NULL_TREE. We can't do that because we need to be able
1510 to represent unbounded cases. */
1514 && mpz_cmp (cp
->low
->value
.integer
,
1515 cp
->high
->value
.integer
) != 0))
1516 high
= gfc_conv_mpz_to_tree (cp
->high
->value
.integer
,
1519 /* Unbounded case. */
1521 low
= TYPE_MIN_VALUE (TREE_TYPE (se
.expr
));
1524 /* Build a label. */
1525 label
= gfc_build_label_decl (NULL_TREE
);
1527 /* Add this case label.
1528 Add parameter 'label', make it match GCC backend. */
1529 tmp
= fold_build3_loc (input_location
, CASE_LABEL_EXPR
,
1530 void_type_node
, low
, high
, label
);
1531 gfc_add_expr_to_block (&body
, tmp
);
1534 /* Add the statements for this case. */
1535 tmp
= gfc_trans_code (c
->next
);
1536 gfc_add_expr_to_block (&body
, tmp
);
1538 /* Break to the end of the construct. */
1539 tmp
= build1_v (GOTO_EXPR
, end_label
);
1540 gfc_add_expr_to_block (&body
, tmp
);
1543 tmp
= gfc_finish_block (&body
);
1544 tmp
= build3_v (SWITCH_EXPR
, se
.expr
, tmp
, NULL_TREE
);
1545 gfc_add_expr_to_block (&block
, tmp
);
1547 tmp
= build1_v (LABEL_EXPR
, end_label
);
1548 gfc_add_expr_to_block (&block
, tmp
);
1550 return gfc_finish_block (&block
);
1554 /* Translate the SELECT CASE construct for LOGICAL case expressions.
1556 There are only two cases possible here, even though the standard
1557 does allow three cases in a LOGICAL SELECT CASE construct: .TRUE.,
1558 .FALSE., and DEFAULT.
1560 We never generate more than two blocks here. Instead, we always
1561 try to eliminate the DEFAULT case. This way, we can translate this
1562 kind of SELECT construct to a simple
1566 expression in GENERIC. */
1569 gfc_trans_logical_select (gfc_code
* code
)
1572 gfc_code
*t
, *f
, *d
;
1577 /* Assume we don't have any cases at all. */
1580 /* Now see which ones we actually do have. We can have at most two
1581 cases in a single case list: one for .TRUE. and one for .FALSE.
1582 The default case is always separate. If the cases for .TRUE. and
1583 .FALSE. are in the same case list, the block for that case list
1584 always executed, and we don't generate code a COND_EXPR. */
1585 for (c
= code
->block
; c
; c
= c
->block
)
1587 for (cp
= c
->ext
.case_list
; cp
; cp
= cp
->next
)
1591 if (cp
->low
->value
.logical
== 0) /* .FALSE. */
1593 else /* if (cp->value.logical != 0), thus .TRUE. */
1601 /* Start a new block. */
1602 gfc_start_block (&block
);
1604 /* Calculate the switch expression. We always need to do this
1605 because it may have side effects. */
1606 gfc_init_se (&se
, NULL
);
1607 gfc_conv_expr_val (&se
, code
->expr1
);
1608 gfc_add_block_to_block (&block
, &se
.pre
);
1610 if (t
== f
&& t
!= NULL
)
1612 /* Cases for .TRUE. and .FALSE. are in the same block. Just
1613 translate the code for these cases, append it to the current
1615 gfc_add_expr_to_block (&block
, gfc_trans_code (t
->next
));
1619 tree true_tree
, false_tree
, stmt
;
1621 true_tree
= build_empty_stmt (input_location
);
1622 false_tree
= build_empty_stmt (input_location
);
1624 /* If we have a case for .TRUE. and for .FALSE., discard the default case.
1625 Otherwise, if .TRUE. or .FALSE. is missing and there is a default case,
1626 make the missing case the default case. */
1627 if (t
!= NULL
&& f
!= NULL
)
1637 /* Translate the code for each of these blocks, and append it to
1638 the current block. */
1640 true_tree
= gfc_trans_code (t
->next
);
1643 false_tree
= gfc_trans_code (f
->next
);
1645 stmt
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
1646 se
.expr
, true_tree
, false_tree
);
1647 gfc_add_expr_to_block (&block
, stmt
);
1650 return gfc_finish_block (&block
);
1654 /* The jump table types are stored in static variables to avoid
1655 constructing them from scratch every single time. */
1656 static GTY(()) tree select_struct
[2];
1658 /* Translate the SELECT CASE construct for CHARACTER case expressions.
1659 Instead of generating compares and jumps, it is far simpler to
1660 generate a data structure describing the cases in order and call a
1661 library subroutine that locates the right case.
1662 This is particularly true because this is the only case where we
1663 might have to dispose of a temporary.
1664 The library subroutine returns a pointer to jump to or NULL if no
1665 branches are to be taken. */
1668 gfc_trans_character_select (gfc_code
*code
)
1670 tree init
, end_label
, tmp
, type
, case_num
, label
, fndecl
;
1671 stmtblock_t block
, body
;
1676 VEC(constructor_elt
,gc
) *inits
= NULL
;
1678 tree pchartype
= gfc_get_pchar_type (code
->expr1
->ts
.kind
);
1680 /* The jump table types are stored in static variables to avoid
1681 constructing them from scratch every single time. */
1682 static tree ss_string1
[2], ss_string1_len
[2];
1683 static tree ss_string2
[2], ss_string2_len
[2];
1684 static tree ss_target
[2];
1686 cp
= code
->block
->ext
.case_list
;
1687 while (cp
->left
!= NULL
)
1690 /* Generate the body */
1691 gfc_start_block (&block
);
1692 gfc_init_se (&expr1se
, NULL
);
1693 gfc_conv_expr_reference (&expr1se
, code
->expr1
);
1695 gfc_add_block_to_block (&block
, &expr1se
.pre
);
1697 end_label
= gfc_build_label_decl (NULL_TREE
);
1699 gfc_init_block (&body
);
1701 /* Attempt to optimize length 1 selects. */
1702 if (integer_onep (expr1se
.string_length
))
1704 for (d
= cp
; d
; d
= d
->right
)
1709 gcc_assert (d
->low
->expr_type
== EXPR_CONSTANT
1710 && d
->low
->ts
.type
== BT_CHARACTER
);
1711 if (d
->low
->value
.character
.length
> 1)
1713 for (i
= 1; i
< d
->low
->value
.character
.length
; i
++)
1714 if (d
->low
->value
.character
.string
[i
] != ' ')
1716 if (i
!= d
->low
->value
.character
.length
)
1718 if (optimize
&& d
->high
&& i
== 1)
1720 gcc_assert (d
->high
->expr_type
== EXPR_CONSTANT
1721 && d
->high
->ts
.type
== BT_CHARACTER
);
1722 if (d
->high
->value
.character
.length
> 1
1723 && (d
->low
->value
.character
.string
[0]
1724 == d
->high
->value
.character
.string
[0])
1725 && d
->high
->value
.character
.string
[1] != ' '
1726 && ((d
->low
->value
.character
.string
[1] < ' ')
1727 == (d
->high
->value
.character
.string
[1]
1737 gcc_assert (d
->high
->expr_type
== EXPR_CONSTANT
1738 && d
->high
->ts
.type
== BT_CHARACTER
);
1739 if (d
->high
->value
.character
.length
> 1)
1741 for (i
= 1; i
< d
->high
->value
.character
.length
; i
++)
1742 if (d
->high
->value
.character
.string
[i
] != ' ')
1744 if (i
!= d
->high
->value
.character
.length
)
1751 tree ctype
= gfc_get_char_type (code
->expr1
->ts
.kind
);
1753 for (c
= code
->block
; c
; c
= c
->block
)
1755 for (cp
= c
->ext
.case_list
; cp
; cp
= cp
->next
)
1761 /* Assume it's the default case. */
1762 low
= high
= NULL_TREE
;
1766 /* CASE ('ab') or CASE ('ab':'az') will never match
1767 any length 1 character. */
1768 if (cp
->low
->value
.character
.length
> 1
1769 && cp
->low
->value
.character
.string
[1] != ' ')
1772 if (cp
->low
->value
.character
.length
> 0)
1773 r
= cp
->low
->value
.character
.string
[0];
1776 low
= build_int_cst (ctype
, r
);
1778 /* If there's only a lower bound, set the high bound
1779 to the maximum value of the case expression. */
1781 high
= TYPE_MAX_VALUE (ctype
);
1787 || (cp
->low
->value
.character
.string
[0]
1788 != cp
->high
->value
.character
.string
[0]))
1790 if (cp
->high
->value
.character
.length
> 0)
1791 r
= cp
->high
->value
.character
.string
[0];
1794 high
= build_int_cst (ctype
, r
);
1797 /* Unbounded case. */
1799 low
= TYPE_MIN_VALUE (ctype
);
1802 /* Build a label. */
1803 label
= gfc_build_label_decl (NULL_TREE
);
1805 /* Add this case label.
1806 Add parameter 'label', make it match GCC backend. */
1807 tmp
= fold_build3_loc (input_location
, CASE_LABEL_EXPR
,
1808 void_type_node
, low
, high
, label
);
1809 gfc_add_expr_to_block (&body
, tmp
);
1812 /* Add the statements for this case. */
1813 tmp
= gfc_trans_code (c
->next
);
1814 gfc_add_expr_to_block (&body
, tmp
);
1816 /* Break to the end of the construct. */
1817 tmp
= build1_v (GOTO_EXPR
, end_label
);
1818 gfc_add_expr_to_block (&body
, tmp
);
1821 tmp
= gfc_string_to_single_character (expr1se
.string_length
,
1823 code
->expr1
->ts
.kind
);
1824 case_num
= gfc_create_var (ctype
, "case_num");
1825 gfc_add_modify (&block
, case_num
, tmp
);
1827 gfc_add_block_to_block (&block
, &expr1se
.post
);
1829 tmp
= gfc_finish_block (&body
);
1830 tmp
= build3_v (SWITCH_EXPR
, case_num
, tmp
, NULL_TREE
);
1831 gfc_add_expr_to_block (&block
, tmp
);
1833 tmp
= build1_v (LABEL_EXPR
, end_label
);
1834 gfc_add_expr_to_block (&block
, tmp
);
1836 return gfc_finish_block (&block
);
1840 if (code
->expr1
->ts
.kind
== 1)
1842 else if (code
->expr1
->ts
.kind
== 4)
1847 if (select_struct
[k
] == NULL
)
1850 select_struct
[k
] = make_node (RECORD_TYPE
);
1852 if (code
->expr1
->ts
.kind
== 1)
1853 TYPE_NAME (select_struct
[k
]) = get_identifier ("_jump_struct_char1");
1854 else if (code
->expr1
->ts
.kind
== 4)
1855 TYPE_NAME (select_struct
[k
]) = get_identifier ("_jump_struct_char4");
1860 #define ADD_FIELD(NAME, TYPE) \
1861 ss_##NAME[k] = gfc_add_field_to_struct (select_struct[k], \
1862 get_identifier (stringize(NAME)), \
1866 ADD_FIELD (string1
, pchartype
);
1867 ADD_FIELD (string1_len
, gfc_charlen_type_node
);
1869 ADD_FIELD (string2
, pchartype
);
1870 ADD_FIELD (string2_len
, gfc_charlen_type_node
);
1872 ADD_FIELD (target
, integer_type_node
);
1875 gfc_finish_type (select_struct
[k
]);
1879 for (d
= cp
; d
; d
= d
->right
)
1882 for (c
= code
->block
; c
; c
= c
->block
)
1884 for (d
= c
->ext
.case_list
; d
; d
= d
->next
)
1886 label
= gfc_build_label_decl (NULL_TREE
);
1887 tmp
= fold_build3_loc (input_location
, CASE_LABEL_EXPR
,
1889 (d
->low
== NULL
&& d
->high
== NULL
)
1890 ? NULL
: build_int_cst (NULL_TREE
, d
->n
),
1892 gfc_add_expr_to_block (&body
, tmp
);
1895 tmp
= gfc_trans_code (c
->next
);
1896 gfc_add_expr_to_block (&body
, tmp
);
1898 tmp
= build1_v (GOTO_EXPR
, end_label
);
1899 gfc_add_expr_to_block (&body
, tmp
);
1902 /* Generate the structure describing the branches */
1903 for (d
= cp
; d
; d
= d
->right
)
1905 VEC(constructor_elt
,gc
) *node
= NULL
;
1907 gfc_init_se (&se
, NULL
);
1911 CONSTRUCTOR_APPEND_ELT (node
, ss_string1
[k
], null_pointer_node
);
1912 CONSTRUCTOR_APPEND_ELT (node
, ss_string1_len
[k
], integer_zero_node
);
1916 gfc_conv_expr_reference (&se
, d
->low
);
1918 CONSTRUCTOR_APPEND_ELT (node
, ss_string1
[k
], se
.expr
);
1919 CONSTRUCTOR_APPEND_ELT (node
, ss_string1_len
[k
], se
.string_length
);
1922 if (d
->high
== NULL
)
1924 CONSTRUCTOR_APPEND_ELT (node
, ss_string2
[k
], null_pointer_node
);
1925 CONSTRUCTOR_APPEND_ELT (node
, ss_string2_len
[k
], integer_zero_node
);
1929 gfc_init_se (&se
, NULL
);
1930 gfc_conv_expr_reference (&se
, d
->high
);
1932 CONSTRUCTOR_APPEND_ELT (node
, ss_string2
[k
], se
.expr
);
1933 CONSTRUCTOR_APPEND_ELT (node
, ss_string2_len
[k
], se
.string_length
);
1936 CONSTRUCTOR_APPEND_ELT (node
, ss_target
[k
],
1937 build_int_cst (integer_type_node
, d
->n
));
1939 tmp
= build_constructor (select_struct
[k
], node
);
1940 CONSTRUCTOR_APPEND_ELT (inits
, NULL_TREE
, tmp
);
1943 type
= build_array_type (select_struct
[k
],
1944 build_index_type (build_int_cst (NULL_TREE
, n
-1)));
1946 init
= build_constructor (type
, inits
);
1947 TREE_CONSTANT (init
) = 1;
1948 TREE_STATIC (init
) = 1;
1949 /* Create a static variable to hold the jump table. */
1950 tmp
= gfc_create_var (type
, "jumptable");
1951 TREE_CONSTANT (tmp
) = 1;
1952 TREE_STATIC (tmp
) = 1;
1953 TREE_READONLY (tmp
) = 1;
1954 DECL_INITIAL (tmp
) = init
;
1957 /* Build the library call */
1958 init
= gfc_build_addr_expr (pvoid_type_node
, init
);
1960 if (code
->expr1
->ts
.kind
== 1)
1961 fndecl
= gfor_fndecl_select_string
;
1962 else if (code
->expr1
->ts
.kind
== 4)
1963 fndecl
= gfor_fndecl_select_string_char4
;
1967 tmp
= build_call_expr_loc (input_location
,
1968 fndecl
, 4, init
, build_int_cst (NULL_TREE
, n
),
1969 expr1se
.expr
, expr1se
.string_length
);
1970 case_num
= gfc_create_var (integer_type_node
, "case_num");
1971 gfc_add_modify (&block
, case_num
, tmp
);
1973 gfc_add_block_to_block (&block
, &expr1se
.post
);
1975 tmp
= gfc_finish_block (&body
);
1976 tmp
= build3_v (SWITCH_EXPR
, case_num
, tmp
, NULL_TREE
);
1977 gfc_add_expr_to_block (&block
, tmp
);
1979 tmp
= build1_v (LABEL_EXPR
, end_label
);
1980 gfc_add_expr_to_block (&block
, tmp
);
1982 return gfc_finish_block (&block
);
1986 /* Translate the three variants of the SELECT CASE construct.
1988 SELECT CASEs with INTEGER case expressions can be translated to an
1989 equivalent GENERIC switch statement, and for LOGICAL case
1990 expressions we build one or two if-else compares.
1992 SELECT CASEs with CHARACTER case expressions are a whole different
1993 story, because they don't exist in GENERIC. So we sort them and
1994 do a binary search at runtime.
1996 Fortran has no BREAK statement, and it does not allow jumps from
1997 one case block to another. That makes things a lot easier for
2001 gfc_trans_select (gfc_code
* code
)
2007 gcc_assert (code
&& code
->expr1
);
2008 gfc_init_block (&block
);
2010 /* Build the exit label and hang it in. */
2011 exit_label
= gfc_build_label_decl (NULL_TREE
);
2012 code
->exit_label
= exit_label
;
2014 /* Empty SELECT constructs are legal. */
2015 if (code
->block
== NULL
)
2016 body
= build_empty_stmt (input_location
);
2018 /* Select the correct translation function. */
2020 switch (code
->expr1
->ts
.type
)
2023 body
= gfc_trans_logical_select (code
);
2027 body
= gfc_trans_integer_select (code
);
2031 body
= gfc_trans_character_select (code
);
2035 gfc_internal_error ("gfc_trans_select(): Bad type for case expr.");
2039 /* Build everything together. */
2040 gfc_add_expr_to_block (&block
, body
);
2041 gfc_add_expr_to_block (&block
, build1_v (LABEL_EXPR
, exit_label
));
2043 return gfc_finish_block (&block
);
2047 /* Traversal function to substitute a replacement symtree if the symbol
2048 in the expression is the same as that passed. f == 2 signals that
2049 that variable itself is not to be checked - only the references.
2050 This group of functions is used when the variable expression in a
2051 FORALL assignment has internal references. For example:
2052 FORALL (i = 1:4) p(p(i)) = i
2053 The only recourse here is to store a copy of 'p' for the index
2056 static gfc_symtree
*new_symtree
;
2057 static gfc_symtree
*old_symtree
;
2060 forall_replace (gfc_expr
*expr
, gfc_symbol
*sym
, int *f
)
2062 if (expr
->expr_type
!= EXPR_VARIABLE
)
2067 else if (expr
->symtree
->n
.sym
== sym
)
2068 expr
->symtree
= new_symtree
;
2074 forall_replace_symtree (gfc_expr
*e
, gfc_symbol
*sym
, int f
)
2076 gfc_traverse_expr (e
, sym
, forall_replace
, f
);
2080 forall_restore (gfc_expr
*expr
,
2081 gfc_symbol
*sym ATTRIBUTE_UNUSED
,
2082 int *f ATTRIBUTE_UNUSED
)
2084 if (expr
->expr_type
!= EXPR_VARIABLE
)
2087 if (expr
->symtree
== new_symtree
)
2088 expr
->symtree
= old_symtree
;
2094 forall_restore_symtree (gfc_expr
*e
)
2096 gfc_traverse_expr (e
, NULL
, forall_restore
, 0);
2100 forall_make_variable_temp (gfc_code
*c
, stmtblock_t
*pre
, stmtblock_t
*post
)
2105 gfc_symbol
*new_sym
;
2106 gfc_symbol
*old_sym
;
2110 /* Build a copy of the lvalue. */
2111 old_symtree
= c
->expr1
->symtree
;
2112 old_sym
= old_symtree
->n
.sym
;
2113 e
= gfc_lval_expr_from_sym (old_sym
);
2114 if (old_sym
->attr
.dimension
)
2116 gfc_init_se (&tse
, NULL
);
2117 gfc_conv_subref_array_arg (&tse
, e
, 0, INTENT_IN
, false);
2118 gfc_add_block_to_block (pre
, &tse
.pre
);
2119 gfc_add_block_to_block (post
, &tse
.post
);
2120 tse
.expr
= build_fold_indirect_ref_loc (input_location
, tse
.expr
);
2122 if (e
->ts
.type
!= BT_CHARACTER
)
2124 /* Use the variable offset for the temporary. */
2125 tmp
= gfc_conv_array_offset (old_sym
->backend_decl
);
2126 gfc_conv_descriptor_offset_set (pre
, tse
.expr
, tmp
);
2131 gfc_init_se (&tse
, NULL
);
2132 gfc_init_se (&rse
, NULL
);
2133 gfc_conv_expr (&rse
, e
);
2134 if (e
->ts
.type
== BT_CHARACTER
)
2136 tse
.string_length
= rse
.string_length
;
2137 tmp
= gfc_get_character_type_len (gfc_default_character_kind
,
2139 tse
.expr
= gfc_conv_string_tmp (&tse
, build_pointer_type (tmp
),
2141 gfc_add_block_to_block (pre
, &tse
.pre
);
2142 gfc_add_block_to_block (post
, &tse
.post
);
2146 tmp
= gfc_typenode_for_spec (&e
->ts
);
2147 tse
.expr
= gfc_create_var (tmp
, "temp");
2150 tmp
= gfc_trans_scalar_assign (&tse
, &rse
, e
->ts
, true,
2151 e
->expr_type
== EXPR_VARIABLE
, true);
2152 gfc_add_expr_to_block (pre
, tmp
);
2156 /* Create a new symbol to represent the lvalue. */
2157 new_sym
= gfc_new_symbol (old_sym
->name
, NULL
);
2158 new_sym
->ts
= old_sym
->ts
;
2159 new_sym
->attr
.referenced
= 1;
2160 new_sym
->attr
.temporary
= 1;
2161 new_sym
->attr
.dimension
= old_sym
->attr
.dimension
;
2162 new_sym
->attr
.flavor
= old_sym
->attr
.flavor
;
2164 /* Use the temporary as the backend_decl. */
2165 new_sym
->backend_decl
= tse
.expr
;
2167 /* Create a fake symtree for it. */
2169 new_symtree
= gfc_new_symtree (&root
, old_sym
->name
);
2170 new_symtree
->n
.sym
= new_sym
;
2171 gcc_assert (new_symtree
== root
);
2173 /* Go through the expression reference replacing the old_symtree
2175 forall_replace_symtree (c
->expr1
, old_sym
, 2);
2177 /* Now we have made this temporary, we might as well use it for
2178 the right hand side. */
2179 forall_replace_symtree (c
->expr2
, old_sym
, 1);
2183 /* Handles dependencies in forall assignments. */
2185 check_forall_dependencies (gfc_code
*c
, stmtblock_t
*pre
, stmtblock_t
*post
)
2192 lsym
= c
->expr1
->symtree
->n
.sym
;
2193 need_temp
= gfc_check_dependency (c
->expr1
, c
->expr2
, 0);
2195 /* Now check for dependencies within the 'variable'
2196 expression itself. These are treated by making a complete
2197 copy of variable and changing all the references to it
2198 point to the copy instead. Note that the shallow copy of
2199 the variable will not suffice for derived types with
2200 pointer components. We therefore leave these to their
2202 if (lsym
->ts
.type
== BT_DERIVED
2203 && lsym
->ts
.u
.derived
->attr
.pointer_comp
)
2207 if (find_forall_index (c
->expr1
, lsym
, 2) == SUCCESS
)
2209 forall_make_variable_temp (c
, pre
, post
);
2213 /* Substrings with dependencies are treated in the same
2215 if (c
->expr1
->ts
.type
== BT_CHARACTER
2217 && c
->expr2
->expr_type
== EXPR_VARIABLE
2218 && lsym
== c
->expr2
->symtree
->n
.sym
)
2220 for (lref
= c
->expr1
->ref
; lref
; lref
= lref
->next
)
2221 if (lref
->type
== REF_SUBSTRING
)
2223 for (rref
= c
->expr2
->ref
; rref
; rref
= rref
->next
)
2224 if (rref
->type
== REF_SUBSTRING
)
2228 && gfc_dep_compare_expr (rref
->u
.ss
.start
, lref
->u
.ss
.start
) < 0)
2230 forall_make_variable_temp (c
, pre
, post
);
2239 cleanup_forall_symtrees (gfc_code
*c
)
2241 forall_restore_symtree (c
->expr1
);
2242 forall_restore_symtree (c
->expr2
);
2243 gfc_free (new_symtree
->n
.sym
);
2244 gfc_free (new_symtree
);
2248 /* Generate the loops for a FORALL block, specified by FORALL_TMP. BODY
2249 is the contents of the FORALL block/stmt to be iterated. MASK_FLAG
2250 indicates whether we should generate code to test the FORALLs mask
2251 array. OUTER is the loop header to be used for initializing mask
2254 The generated loop format is:
2255 count = (end - start + step) / step
2268 gfc_trans_forall_loop (forall_info
*forall_tmp
, tree body
,
2269 int mask_flag
, stmtblock_t
*outer
)
2277 tree var
, start
, end
, step
;
2280 /* Initialize the mask index outside the FORALL nest. */
2281 if (mask_flag
&& forall_tmp
->mask
)
2282 gfc_add_modify (outer
, forall_tmp
->maskindex
, gfc_index_zero_node
);
2284 iter
= forall_tmp
->this_loop
;
2285 nvar
= forall_tmp
->nvar
;
2286 for (n
= 0; n
< nvar
; n
++)
2289 start
= iter
->start
;
2293 exit_label
= gfc_build_label_decl (NULL_TREE
);
2294 TREE_USED (exit_label
) = 1;
2296 /* The loop counter. */
2297 count
= gfc_create_var (TREE_TYPE (var
), "count");
2299 /* The body of the loop. */
2300 gfc_init_block (&block
);
2302 /* The exit condition. */
2303 cond
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
,
2304 count
, build_int_cst (TREE_TYPE (count
), 0));
2305 tmp
= build1_v (GOTO_EXPR
, exit_label
);
2306 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
2307 cond
, tmp
, build_empty_stmt (input_location
));
2308 gfc_add_expr_to_block (&block
, tmp
);
2310 /* The main loop body. */
2311 gfc_add_expr_to_block (&block
, body
);
2313 /* Increment the loop variable. */
2314 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (var
), var
,
2316 gfc_add_modify (&block
, var
, tmp
);
2318 /* Advance to the next mask element. Only do this for the
2320 if (n
== 0 && mask_flag
&& forall_tmp
->mask
)
2322 tree maskindex
= forall_tmp
->maskindex
;
2323 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
2324 maskindex
, gfc_index_one_node
);
2325 gfc_add_modify (&block
, maskindex
, tmp
);
2328 /* Decrement the loop counter. */
2329 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (var
), count
,
2330 build_int_cst (TREE_TYPE (var
), 1));
2331 gfc_add_modify (&block
, count
, tmp
);
2333 body
= gfc_finish_block (&block
);
2335 /* Loop var initialization. */
2336 gfc_init_block (&block
);
2337 gfc_add_modify (&block
, var
, start
);
2340 /* Initialize the loop counter. */
2341 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (var
), step
,
2343 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (var
), end
,
2345 tmp
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
, TREE_TYPE (var
),
2347 gfc_add_modify (&block
, count
, tmp
);
2349 /* The loop expression. */
2350 tmp
= build1_v (LOOP_EXPR
, body
);
2351 gfc_add_expr_to_block (&block
, tmp
);
2353 /* The exit label. */
2354 tmp
= build1_v (LABEL_EXPR
, exit_label
);
2355 gfc_add_expr_to_block (&block
, tmp
);
2357 body
= gfc_finish_block (&block
);
2364 /* Generate the body and loops according to MASK_FLAG. If MASK_FLAG
2365 is nonzero, the body is controlled by all masks in the forall nest.
2366 Otherwise, the innermost loop is not controlled by it's mask. This
2367 is used for initializing that mask. */
2370 gfc_trans_nested_forall_loop (forall_info
* nested_forall_info
, tree body
,
2375 forall_info
*forall_tmp
;
2376 tree mask
, maskindex
;
2378 gfc_start_block (&header
);
2380 forall_tmp
= nested_forall_info
;
2381 while (forall_tmp
!= NULL
)
2383 /* Generate body with masks' control. */
2386 mask
= forall_tmp
->mask
;
2387 maskindex
= forall_tmp
->maskindex
;
2389 /* If a mask was specified make the assignment conditional. */
2392 tmp
= gfc_build_array_ref (mask
, maskindex
, NULL
);
2393 body
= build3_v (COND_EXPR
, tmp
, body
,
2394 build_empty_stmt (input_location
));
2397 body
= gfc_trans_forall_loop (forall_tmp
, body
, mask_flag
, &header
);
2398 forall_tmp
= forall_tmp
->prev_nest
;
2402 gfc_add_expr_to_block (&header
, body
);
2403 return gfc_finish_block (&header
);
2407 /* Allocate data for holding a temporary array. Returns either a local
2408 temporary array or a pointer variable. */
2411 gfc_do_allocate (tree bytesize
, tree size
, tree
* pdata
, stmtblock_t
* pblock
,
2418 if (INTEGER_CST_P (size
))
2419 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
2420 size
, gfc_index_one_node
);
2424 type
= build_range_type (gfc_array_index_type
, gfc_index_zero_node
, tmp
);
2425 type
= build_array_type (elem_type
, type
);
2426 if (gfc_can_put_var_on_stack (bytesize
))
2428 gcc_assert (INTEGER_CST_P (size
));
2429 tmpvar
= gfc_create_var (type
, "temp");
2434 tmpvar
= gfc_create_var (build_pointer_type (type
), "temp");
2435 *pdata
= convert (pvoid_type_node
, tmpvar
);
2437 tmp
= gfc_call_malloc (pblock
, TREE_TYPE (tmpvar
), bytesize
);
2438 gfc_add_modify (pblock
, tmpvar
, tmp
);
2444 /* Generate codes to copy the temporary to the actual lhs. */
2447 generate_loop_for_temp_to_lhs (gfc_expr
*expr
, tree tmp1
, tree count3
,
2448 tree count1
, tree wheremask
, bool invert
)
2452 stmtblock_t block
, body
;
2458 lss
= gfc_walk_expr (expr
);
2460 if (lss
== gfc_ss_terminator
)
2462 gfc_start_block (&block
);
2464 gfc_init_se (&lse
, NULL
);
2466 /* Translate the expression. */
2467 gfc_conv_expr (&lse
, expr
);
2469 /* Form the expression for the temporary. */
2470 tmp
= gfc_build_array_ref (tmp1
, count1
, NULL
);
2472 /* Use the scalar assignment as is. */
2473 gfc_add_block_to_block (&block
, &lse
.pre
);
2474 gfc_add_modify (&block
, lse
.expr
, tmp
);
2475 gfc_add_block_to_block (&block
, &lse
.post
);
2477 /* Increment the count1. */
2478 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (count1
),
2479 count1
, gfc_index_one_node
);
2480 gfc_add_modify (&block
, count1
, tmp
);
2482 tmp
= gfc_finish_block (&block
);
2486 gfc_start_block (&block
);
2488 gfc_init_loopinfo (&loop1
);
2489 gfc_init_se (&rse
, NULL
);
2490 gfc_init_se (&lse
, NULL
);
2492 /* Associate the lss with the loop. */
2493 gfc_add_ss_to_loop (&loop1
, lss
);
2495 /* Calculate the bounds of the scalarization. */
2496 gfc_conv_ss_startstride (&loop1
);
2497 /* Setup the scalarizing loops. */
2498 gfc_conv_loop_setup (&loop1
, &expr
->where
);
2500 gfc_mark_ss_chain_used (lss
, 1);
2502 /* Start the scalarized loop body. */
2503 gfc_start_scalarized_body (&loop1
, &body
);
2505 /* Setup the gfc_se structures. */
2506 gfc_copy_loopinfo_to_se (&lse
, &loop1
);
2509 /* Form the expression of the temporary. */
2510 if (lss
!= gfc_ss_terminator
)
2511 rse
.expr
= gfc_build_array_ref (tmp1
, count1
, NULL
);
2512 /* Translate expr. */
2513 gfc_conv_expr (&lse
, expr
);
2515 /* Use the scalar assignment. */
2516 rse
.string_length
= lse
.string_length
;
2517 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
, false, true, true);
2519 /* Form the mask expression according to the mask tree list. */
2522 wheremaskexpr
= gfc_build_array_ref (wheremask
, count3
, NULL
);
2524 wheremaskexpr
= fold_build1_loc (input_location
, TRUTH_NOT_EXPR
,
2525 TREE_TYPE (wheremaskexpr
),
2527 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
2529 build_empty_stmt (input_location
));
2532 gfc_add_expr_to_block (&body
, tmp
);
2534 /* Increment count1. */
2535 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
2536 count1
, gfc_index_one_node
);
2537 gfc_add_modify (&body
, count1
, tmp
);
2539 /* Increment count3. */
2542 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
2543 gfc_array_index_type
, count3
,
2544 gfc_index_one_node
);
2545 gfc_add_modify (&body
, count3
, tmp
);
2548 /* Generate the copying loops. */
2549 gfc_trans_scalarizing_loops (&loop1
, &body
);
2550 gfc_add_block_to_block (&block
, &loop1
.pre
);
2551 gfc_add_block_to_block (&block
, &loop1
.post
);
2552 gfc_cleanup_loop (&loop1
);
2554 tmp
= gfc_finish_block (&block
);
2560 /* Generate codes to copy rhs to the temporary. TMP1 is the address of
2561 temporary, LSS and RSS are formed in function compute_inner_temp_size(),
2562 and should not be freed. WHEREMASK is the conditional execution mask
2563 whose sense may be inverted by INVERT. */
2566 generate_loop_for_rhs_to_temp (gfc_expr
*expr2
, tree tmp1
, tree count3
,
2567 tree count1
, gfc_ss
*lss
, gfc_ss
*rss
,
2568 tree wheremask
, bool invert
)
2570 stmtblock_t block
, body1
;
2577 gfc_start_block (&block
);
2579 gfc_init_se (&rse
, NULL
);
2580 gfc_init_se (&lse
, NULL
);
2582 if (lss
== gfc_ss_terminator
)
2584 gfc_init_block (&body1
);
2585 gfc_conv_expr (&rse
, expr2
);
2586 lse
.expr
= gfc_build_array_ref (tmp1
, count1
, NULL
);
2590 /* Initialize the loop. */
2591 gfc_init_loopinfo (&loop
);
2593 /* We may need LSS to determine the shape of the expression. */
2594 gfc_add_ss_to_loop (&loop
, lss
);
2595 gfc_add_ss_to_loop (&loop
, rss
);
2597 gfc_conv_ss_startstride (&loop
);
2598 gfc_conv_loop_setup (&loop
, &expr2
->where
);
2600 gfc_mark_ss_chain_used (rss
, 1);
2601 /* Start the loop body. */
2602 gfc_start_scalarized_body (&loop
, &body1
);
2604 /* Translate the expression. */
2605 gfc_copy_loopinfo_to_se (&rse
, &loop
);
2607 gfc_conv_expr (&rse
, expr2
);
2609 /* Form the expression of the temporary. */
2610 lse
.expr
= gfc_build_array_ref (tmp1
, count1
, NULL
);
2613 /* Use the scalar assignment. */
2614 lse
.string_length
= rse
.string_length
;
2615 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr2
->ts
, true,
2616 expr2
->expr_type
== EXPR_VARIABLE
, true);
2618 /* Form the mask expression according to the mask tree list. */
2621 wheremaskexpr
= gfc_build_array_ref (wheremask
, count3
, NULL
);
2623 wheremaskexpr
= fold_build1_loc (input_location
, TRUTH_NOT_EXPR
,
2624 TREE_TYPE (wheremaskexpr
),
2626 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
2628 build_empty_stmt (input_location
));
2631 gfc_add_expr_to_block (&body1
, tmp
);
2633 if (lss
== gfc_ss_terminator
)
2635 gfc_add_block_to_block (&block
, &body1
);
2637 /* Increment count1. */
2638 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (count1
),
2639 count1
, gfc_index_one_node
);
2640 gfc_add_modify (&block
, count1
, tmp
);
2644 /* Increment count1. */
2645 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
2646 count1
, gfc_index_one_node
);
2647 gfc_add_modify (&body1
, count1
, tmp
);
2649 /* Increment count3. */
2652 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
2653 gfc_array_index_type
,
2654 count3
, gfc_index_one_node
);
2655 gfc_add_modify (&body1
, count3
, tmp
);
2658 /* Generate the copying loops. */
2659 gfc_trans_scalarizing_loops (&loop
, &body1
);
2661 gfc_add_block_to_block (&block
, &loop
.pre
);
2662 gfc_add_block_to_block (&block
, &loop
.post
);
2664 gfc_cleanup_loop (&loop
);
2665 /* TODO: Reuse lss and rss when copying temp->lhs. Need to be careful
2666 as tree nodes in SS may not be valid in different scope. */
2669 tmp
= gfc_finish_block (&block
);
2674 /* Calculate the size of temporary needed in the assignment inside forall.
2675 LSS and RSS are filled in this function. */
2678 compute_inner_temp_size (gfc_expr
*expr1
, gfc_expr
*expr2
,
2679 stmtblock_t
* pblock
,
2680 gfc_ss
**lss
, gfc_ss
**rss
)
2688 *lss
= gfc_walk_expr (expr1
);
2691 size
= gfc_index_one_node
;
2692 if (*lss
!= gfc_ss_terminator
)
2694 gfc_init_loopinfo (&loop
);
2696 /* Walk the RHS of the expression. */
2697 *rss
= gfc_walk_expr (expr2
);
2698 if (*rss
== gfc_ss_terminator
)
2700 /* The rhs is scalar. Add a ss for the expression. */
2701 *rss
= gfc_get_ss ();
2702 (*rss
)->next
= gfc_ss_terminator
;
2703 (*rss
)->type
= GFC_SS_SCALAR
;
2704 (*rss
)->expr
= expr2
;
2707 /* Associate the SS with the loop. */
2708 gfc_add_ss_to_loop (&loop
, *lss
);
2709 /* We don't actually need to add the rhs at this point, but it might
2710 make guessing the loop bounds a bit easier. */
2711 gfc_add_ss_to_loop (&loop
, *rss
);
2713 /* We only want the shape of the expression, not rest of the junk
2714 generated by the scalarizer. */
2715 loop
.array_parameter
= 1;
2717 /* Calculate the bounds of the scalarization. */
2718 save_flag
= gfc_option
.rtcheck
;
2719 gfc_option
.rtcheck
&= !GFC_RTCHECK_BOUNDS
;
2720 gfc_conv_ss_startstride (&loop
);
2721 gfc_option
.rtcheck
= save_flag
;
2722 gfc_conv_loop_setup (&loop
, &expr2
->where
);
2724 /* Figure out how many elements we need. */
2725 for (i
= 0; i
< loop
.dimen
; i
++)
2727 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
2728 gfc_array_index_type
,
2729 gfc_index_one_node
, loop
.from
[i
]);
2730 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
2731 gfc_array_index_type
, tmp
, loop
.to
[i
]);
2732 size
= fold_build2_loc (input_location
, MULT_EXPR
,
2733 gfc_array_index_type
, size
, tmp
);
2735 gfc_add_block_to_block (pblock
, &loop
.pre
);
2736 size
= gfc_evaluate_now (size
, pblock
);
2737 gfc_add_block_to_block (pblock
, &loop
.post
);
2739 /* TODO: write a function that cleans up a loopinfo without freeing
2740 the SS chains. Currently a NOP. */
2747 /* Calculate the overall iterator number of the nested forall construct.
2748 This routine actually calculates the number of times the body of the
2749 nested forall specified by NESTED_FORALL_INFO is executed and multiplies
2750 that by the expression INNER_SIZE. The BLOCK argument specifies the
2751 block in which to calculate the result, and the optional INNER_SIZE_BODY
2752 argument contains any statements that need to executed (inside the loop)
2753 to initialize or calculate INNER_SIZE. */
2756 compute_overall_iter_number (forall_info
*nested_forall_info
, tree inner_size
,
2757 stmtblock_t
*inner_size_body
, stmtblock_t
*block
)
2759 forall_info
*forall_tmp
= nested_forall_info
;
2763 /* We can eliminate the innermost unconditional loops with constant
2765 if (INTEGER_CST_P (inner_size
))
2768 && !forall_tmp
->mask
2769 && INTEGER_CST_P (forall_tmp
->size
))
2771 inner_size
= fold_build2_loc (input_location
, MULT_EXPR
,
2772 gfc_array_index_type
,
2773 inner_size
, forall_tmp
->size
);
2774 forall_tmp
= forall_tmp
->prev_nest
;
2777 /* If there are no loops left, we have our constant result. */
2782 /* Otherwise, create a temporary variable to compute the result. */
2783 number
= gfc_create_var (gfc_array_index_type
, "num");
2784 gfc_add_modify (block
, number
, gfc_index_zero_node
);
2786 gfc_start_block (&body
);
2787 if (inner_size_body
)
2788 gfc_add_block_to_block (&body
, inner_size_body
);
2790 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
2791 gfc_array_index_type
, number
, inner_size
);
2794 gfc_add_modify (&body
, number
, tmp
);
2795 tmp
= gfc_finish_block (&body
);
2797 /* Generate loops. */
2798 if (forall_tmp
!= NULL
)
2799 tmp
= gfc_trans_nested_forall_loop (forall_tmp
, tmp
, 1);
2801 gfc_add_expr_to_block (block
, tmp
);
2807 /* Allocate temporary for forall construct. SIZE is the size of temporary
2808 needed. PTEMP1 is returned for space free. */
2811 allocate_temp_for_forall_nest_1 (tree type
, tree size
, stmtblock_t
* block
,
2818 unit
= fold_convert (gfc_array_index_type
, TYPE_SIZE_UNIT (type
));
2819 if (!integer_onep (unit
))
2820 bytesize
= fold_build2_loc (input_location
, MULT_EXPR
,
2821 gfc_array_index_type
, size
, unit
);
2826 tmp
= gfc_do_allocate (bytesize
, size
, ptemp1
, block
, type
);
2829 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
2834 /* Allocate temporary for forall construct according to the information in
2835 nested_forall_info. INNER_SIZE is the size of temporary needed in the
2836 assignment inside forall. PTEMP1 is returned for space free. */
2839 allocate_temp_for_forall_nest (forall_info
* nested_forall_info
, tree type
,
2840 tree inner_size
, stmtblock_t
* inner_size_body
,
2841 stmtblock_t
* block
, tree
* ptemp1
)
2845 /* Calculate the total size of temporary needed in forall construct. */
2846 size
= compute_overall_iter_number (nested_forall_info
, inner_size
,
2847 inner_size_body
, block
);
2849 return allocate_temp_for_forall_nest_1 (type
, size
, block
, ptemp1
);
2853 /* Handle assignments inside forall which need temporary.
2855 forall (i=start:end:stride; maskexpr)
2858 (where e,f<i> are arbitrary expressions possibly involving i
2859 and there is a dependency between e<i> and f<i>)
2861 masktmp(:) = maskexpr(:)
2866 for (i = start; i <= end; i += stride)
2870 for (i = start; i <= end; i += stride)
2872 if (masktmp[maskindex++])
2873 tmp[count1++] = f<i>
2877 for (i = start; i <= end; i += stride)
2879 if (masktmp[maskindex++])
2880 e<i> = tmp[count1++]
2885 gfc_trans_assign_need_temp (gfc_expr
* expr1
, gfc_expr
* expr2
,
2886 tree wheremask
, bool invert
,
2887 forall_info
* nested_forall_info
,
2888 stmtblock_t
* block
)
2896 stmtblock_t inner_size_body
;
2898 /* Create vars. count1 is the current iterator number of the nested
2900 count1
= gfc_create_var (gfc_array_index_type
, "count1");
2902 /* Count is the wheremask index. */
2905 count
= gfc_create_var (gfc_array_index_type
, "count");
2906 gfc_add_modify (block
, count
, gfc_index_zero_node
);
2911 /* Initialize count1. */
2912 gfc_add_modify (block
, count1
, gfc_index_zero_node
);
2914 /* Calculate the size of temporary needed in the assignment. Return loop, lss
2915 and rss which are used in function generate_loop_for_rhs_to_temp(). */
2916 gfc_init_block (&inner_size_body
);
2917 inner_size
= compute_inner_temp_size (expr1
, expr2
, &inner_size_body
,
2920 /* The type of LHS. Used in function allocate_temp_for_forall_nest */
2921 if (expr1
->ts
.type
== BT_CHARACTER
&& expr1
->ts
.u
.cl
->length
)
2923 if (!expr1
->ts
.u
.cl
->backend_decl
)
2926 gfc_init_se (&tse
, NULL
);
2927 gfc_conv_expr (&tse
, expr1
->ts
.u
.cl
->length
);
2928 expr1
->ts
.u
.cl
->backend_decl
= tse
.expr
;
2930 type
= gfc_get_character_type_len (gfc_default_character_kind
,
2931 expr1
->ts
.u
.cl
->backend_decl
);
2934 type
= gfc_typenode_for_spec (&expr1
->ts
);
2936 /* Allocate temporary for nested forall construct according to the
2937 information in nested_forall_info and inner_size. */
2938 tmp1
= allocate_temp_for_forall_nest (nested_forall_info
, type
, inner_size
,
2939 &inner_size_body
, block
, &ptemp1
);
2941 /* Generate codes to copy rhs to the temporary . */
2942 tmp
= generate_loop_for_rhs_to_temp (expr2
, tmp1
, count
, count1
, lss
, rss
,
2945 /* Generate body and loops according to the information in
2946 nested_forall_info. */
2947 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, tmp
, 1);
2948 gfc_add_expr_to_block (block
, tmp
);
2951 gfc_add_modify (block
, count1
, gfc_index_zero_node
);
2955 gfc_add_modify (block
, count
, gfc_index_zero_node
);
2957 /* Generate codes to copy the temporary to lhs. */
2958 tmp
= generate_loop_for_temp_to_lhs (expr1
, tmp1
, count
, count1
,
2961 /* Generate body and loops according to the information in
2962 nested_forall_info. */
2963 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, tmp
, 1);
2964 gfc_add_expr_to_block (block
, tmp
);
2968 /* Free the temporary. */
2969 tmp
= gfc_call_free (ptemp1
);
2970 gfc_add_expr_to_block (block
, tmp
);
2975 /* Translate pointer assignment inside FORALL which need temporary. */
2978 gfc_trans_pointer_assign_need_temp (gfc_expr
* expr1
, gfc_expr
* expr2
,
2979 forall_info
* nested_forall_info
,
2980 stmtblock_t
* block
)
2994 tree tmp
, tmp1
, ptemp1
;
2996 count
= gfc_create_var (gfc_array_index_type
, "count");
2997 gfc_add_modify (block
, count
, gfc_index_zero_node
);
2999 inner_size
= integer_one_node
;
3000 lss
= gfc_walk_expr (expr1
);
3001 rss
= gfc_walk_expr (expr2
);
3002 if (lss
== gfc_ss_terminator
)
3004 type
= gfc_typenode_for_spec (&expr1
->ts
);
3005 type
= build_pointer_type (type
);
3007 /* Allocate temporary for nested forall construct according to the
3008 information in nested_forall_info and inner_size. */
3009 tmp1
= allocate_temp_for_forall_nest (nested_forall_info
, type
,
3010 inner_size
, NULL
, block
, &ptemp1
);
3011 gfc_start_block (&body
);
3012 gfc_init_se (&lse
, NULL
);
3013 lse
.expr
= gfc_build_array_ref (tmp1
, count
, NULL
);
3014 gfc_init_se (&rse
, NULL
);
3015 rse
.want_pointer
= 1;
3016 gfc_conv_expr (&rse
, expr2
);
3017 gfc_add_block_to_block (&body
, &rse
.pre
);
3018 gfc_add_modify (&body
, lse
.expr
,
3019 fold_convert (TREE_TYPE (lse
.expr
), rse
.expr
));
3020 gfc_add_block_to_block (&body
, &rse
.post
);
3022 /* Increment count. */
3023 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
3024 count
, gfc_index_one_node
);
3025 gfc_add_modify (&body
, count
, tmp
);
3027 tmp
= gfc_finish_block (&body
);
3029 /* Generate body and loops according to the information in
3030 nested_forall_info. */
3031 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, tmp
, 1);
3032 gfc_add_expr_to_block (block
, tmp
);
3035 gfc_add_modify (block
, count
, gfc_index_zero_node
);
3037 gfc_start_block (&body
);
3038 gfc_init_se (&lse
, NULL
);
3039 gfc_init_se (&rse
, NULL
);
3040 rse
.expr
= gfc_build_array_ref (tmp1
, count
, NULL
);
3041 lse
.want_pointer
= 1;
3042 gfc_conv_expr (&lse
, expr1
);
3043 gfc_add_block_to_block (&body
, &lse
.pre
);
3044 gfc_add_modify (&body
, lse
.expr
, rse
.expr
);
3045 gfc_add_block_to_block (&body
, &lse
.post
);
3046 /* Increment count. */
3047 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
3048 count
, gfc_index_one_node
);
3049 gfc_add_modify (&body
, count
, tmp
);
3050 tmp
= gfc_finish_block (&body
);
3052 /* Generate body and loops according to the information in
3053 nested_forall_info. */
3054 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, tmp
, 1);
3055 gfc_add_expr_to_block (block
, tmp
);
3059 gfc_init_loopinfo (&loop
);
3061 /* Associate the SS with the loop. */
3062 gfc_add_ss_to_loop (&loop
, rss
);
3064 /* Setup the scalarizing loops and bounds. */
3065 gfc_conv_ss_startstride (&loop
);
3067 gfc_conv_loop_setup (&loop
, &expr2
->where
);
3069 info
= &rss
->data
.info
;
3070 desc
= info
->descriptor
;
3072 /* Make a new descriptor. */
3073 parmtype
= gfc_get_element_type (TREE_TYPE (desc
));
3074 parmtype
= gfc_get_array_type_bounds (parmtype
, loop
.dimen
, 0,
3075 loop
.from
, loop
.to
, 1,
3076 GFC_ARRAY_UNKNOWN
, true);
3078 /* Allocate temporary for nested forall construct. */
3079 tmp1
= allocate_temp_for_forall_nest (nested_forall_info
, parmtype
,
3080 inner_size
, NULL
, block
, &ptemp1
);
3081 gfc_start_block (&body
);
3082 gfc_init_se (&lse
, NULL
);
3083 lse
.expr
= gfc_build_array_ref (tmp1
, count
, NULL
);
3084 lse
.direct_byref
= 1;
3085 rss
= gfc_walk_expr (expr2
);
3086 gfc_conv_expr_descriptor (&lse
, expr2
, rss
);
3088 gfc_add_block_to_block (&body
, &lse
.pre
);
3089 gfc_add_block_to_block (&body
, &lse
.post
);
3091 /* Increment count. */
3092 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
3093 count
, gfc_index_one_node
);
3094 gfc_add_modify (&body
, count
, tmp
);
3096 tmp
= gfc_finish_block (&body
);
3098 /* Generate body and loops according to the information in
3099 nested_forall_info. */
3100 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, tmp
, 1);
3101 gfc_add_expr_to_block (block
, tmp
);
3104 gfc_add_modify (block
, count
, gfc_index_zero_node
);
3106 parm
= gfc_build_array_ref (tmp1
, count
, NULL
);
3107 lss
= gfc_walk_expr (expr1
);
3108 gfc_init_se (&lse
, NULL
);
3109 gfc_conv_expr_descriptor (&lse
, expr1
, lss
);
3110 gfc_add_modify (&lse
.pre
, lse
.expr
, parm
);
3111 gfc_start_block (&body
);
3112 gfc_add_block_to_block (&body
, &lse
.pre
);
3113 gfc_add_block_to_block (&body
, &lse
.post
);
3115 /* Increment count. */
3116 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
3117 count
, gfc_index_one_node
);
3118 gfc_add_modify (&body
, count
, tmp
);
3120 tmp
= gfc_finish_block (&body
);
3122 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, tmp
, 1);
3123 gfc_add_expr_to_block (block
, tmp
);
3125 /* Free the temporary. */
3128 tmp
= gfc_call_free (ptemp1
);
3129 gfc_add_expr_to_block (block
, tmp
);
3134 /* FORALL and WHERE statements are really nasty, especially when you nest
3135 them. All the rhs of a forall assignment must be evaluated before the
3136 actual assignments are performed. Presumably this also applies to all the
3137 assignments in an inner where statement. */
3139 /* Generate code for a FORALL statement. Any temporaries are allocated as a
3140 linear array, relying on the fact that we process in the same order in all
3143 forall (i=start:end:stride; maskexpr)
3147 (where e,f,g,h<i> are arbitrary expressions possibly involving i)
3149 count = ((end + 1 - start) / stride)
3150 masktmp(:) = maskexpr(:)
3153 for (i = start; i <= end; i += stride)
3155 if (masktmp[maskindex++])
3159 for (i = start; i <= end; i += stride)
3161 if (masktmp[maskindex++])
3165 Note that this code only works when there are no dependencies.
3166 Forall loop with array assignments and data dependencies are a real pain,
3167 because the size of the temporary cannot always be determined before the
3168 loop is executed. This problem is compounded by the presence of nested
3173 gfc_trans_forall_1 (gfc_code
* code
, forall_info
* nested_forall_info
)
3193 gfc_forall_iterator
*fa
;
3196 gfc_saved_var
*saved_vars
;
3197 iter_info
*this_forall
;
3201 /* Do nothing if the mask is false. */
3203 && code
->expr1
->expr_type
== EXPR_CONSTANT
3204 && !code
->expr1
->value
.logical
)
3205 return build_empty_stmt (input_location
);
3208 /* Count the FORALL index number. */
3209 for (fa
= code
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
3213 /* Allocate the space for var, start, end, step, varexpr. */
3214 var
= (tree
*) gfc_getmem (nvar
* sizeof (tree
));
3215 start
= (tree
*) gfc_getmem (nvar
* sizeof (tree
));
3216 end
= (tree
*) gfc_getmem (nvar
* sizeof (tree
));
3217 step
= (tree
*) gfc_getmem (nvar
* sizeof (tree
));
3218 varexpr
= (gfc_expr
**) gfc_getmem (nvar
* sizeof (gfc_expr
*));
3219 saved_vars
= (gfc_saved_var
*) gfc_getmem (nvar
* sizeof (gfc_saved_var
));
3221 /* Allocate the space for info. */
3222 info
= (forall_info
*) gfc_getmem (sizeof (forall_info
));
3224 gfc_start_block (&pre
);
3225 gfc_init_block (&post
);
3226 gfc_init_block (&block
);
3229 for (fa
= code
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
3231 gfc_symbol
*sym
= fa
->var
->symtree
->n
.sym
;
3233 /* Allocate space for this_forall. */
3234 this_forall
= (iter_info
*) gfc_getmem (sizeof (iter_info
));
3236 /* Create a temporary variable for the FORALL index. */
3237 tmp
= gfc_typenode_for_spec (&sym
->ts
);
3238 var
[n
] = gfc_create_var (tmp
, sym
->name
);
3239 gfc_shadow_sym (sym
, var
[n
], &saved_vars
[n
]);
3241 /* Record it in this_forall. */
3242 this_forall
->var
= var
[n
];
3244 /* Replace the index symbol's backend_decl with the temporary decl. */
3245 sym
->backend_decl
= var
[n
];
3247 /* Work out the start, end and stride for the loop. */
3248 gfc_init_se (&se
, NULL
);
3249 gfc_conv_expr_val (&se
, fa
->start
);
3250 /* Record it in this_forall. */
3251 this_forall
->start
= se
.expr
;
3252 gfc_add_block_to_block (&block
, &se
.pre
);
3255 gfc_init_se (&se
, NULL
);
3256 gfc_conv_expr_val (&se
, fa
->end
);
3257 /* Record it in this_forall. */
3258 this_forall
->end
= se
.expr
;
3259 gfc_make_safe_expr (&se
);
3260 gfc_add_block_to_block (&block
, &se
.pre
);
3263 gfc_init_se (&se
, NULL
);
3264 gfc_conv_expr_val (&se
, fa
->stride
);
3265 /* Record it in this_forall. */
3266 this_forall
->step
= se
.expr
;
3267 gfc_make_safe_expr (&se
);
3268 gfc_add_block_to_block (&block
, &se
.pre
);
3271 /* Set the NEXT field of this_forall to NULL. */
3272 this_forall
->next
= NULL
;
3273 /* Link this_forall to the info construct. */
3274 if (info
->this_loop
)
3276 iter_info
*iter_tmp
= info
->this_loop
;
3277 while (iter_tmp
->next
!= NULL
)
3278 iter_tmp
= iter_tmp
->next
;
3279 iter_tmp
->next
= this_forall
;
3282 info
->this_loop
= this_forall
;
3288 /* Calculate the size needed for the current forall level. */
3289 size
= gfc_index_one_node
;
3290 for (n
= 0; n
< nvar
; n
++)
3292 /* size = (end + step - start) / step. */
3293 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (start
[n
]),
3295 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (end
[n
]),
3297 tmp
= fold_build2_loc (input_location
, FLOOR_DIV_EXPR
, TREE_TYPE (tmp
),
3299 tmp
= convert (gfc_array_index_type
, tmp
);
3301 size
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
3305 /* Record the nvar and size of current forall level. */
3311 /* If the mask is .true., consider the FORALL unconditional. */
3312 if (code
->expr1
->expr_type
== EXPR_CONSTANT
3313 && code
->expr1
->value
.logical
)
3321 /* First we need to allocate the mask. */
3324 /* As the mask array can be very big, prefer compact boolean types. */
3325 tree mask_type
= gfc_get_logical_type (gfc_logical_kinds
[0].kind
);
3326 mask
= allocate_temp_for_forall_nest (nested_forall_info
, mask_type
,
3327 size
, NULL
, &block
, &pmask
);
3328 maskindex
= gfc_create_var_np (gfc_array_index_type
, "mi");
3330 /* Record them in the info structure. */
3331 info
->maskindex
= maskindex
;
3336 /* No mask was specified. */
3337 maskindex
= NULL_TREE
;
3338 mask
= pmask
= NULL_TREE
;
3341 /* Link the current forall level to nested_forall_info. */
3342 info
->prev_nest
= nested_forall_info
;
3343 nested_forall_info
= info
;
3345 /* Copy the mask into a temporary variable if required.
3346 For now we assume a mask temporary is needed. */
3349 /* As the mask array can be very big, prefer compact boolean types. */
3350 tree mask_type
= gfc_get_logical_type (gfc_logical_kinds
[0].kind
);
3352 gfc_add_modify (&block
, maskindex
, gfc_index_zero_node
);
3354 /* Start of mask assignment loop body. */
3355 gfc_start_block (&body
);
3357 /* Evaluate the mask expression. */
3358 gfc_init_se (&se
, NULL
);
3359 gfc_conv_expr_val (&se
, code
->expr1
);
3360 gfc_add_block_to_block (&body
, &se
.pre
);
3362 /* Store the mask. */
3363 se
.expr
= convert (mask_type
, se
.expr
);
3365 tmp
= gfc_build_array_ref (mask
, maskindex
, NULL
);
3366 gfc_add_modify (&body
, tmp
, se
.expr
);
3368 /* Advance to the next mask element. */
3369 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
3370 maskindex
, gfc_index_one_node
);
3371 gfc_add_modify (&body
, maskindex
, tmp
);
3373 /* Generate the loops. */
3374 tmp
= gfc_finish_block (&body
);
3375 tmp
= gfc_trans_nested_forall_loop (info
, tmp
, 0);
3376 gfc_add_expr_to_block (&block
, tmp
);
3379 c
= code
->block
->next
;
3381 /* TODO: loop merging in FORALL statements. */
3382 /* Now that we've got a copy of the mask, generate the assignment loops. */
3388 /* A scalar or array assignment. DO the simple check for
3389 lhs to rhs dependencies. These make a temporary for the
3390 rhs and form a second forall block to copy to variable. */
3391 need_temp
= check_forall_dependencies(c
, &pre
, &post
);
3393 /* Temporaries due to array assignment data dependencies introduce
3394 no end of problems. */
3396 gfc_trans_assign_need_temp (c
->expr1
, c
->expr2
, NULL
, false,
3397 nested_forall_info
, &block
);
3400 /* Use the normal assignment copying routines. */
3401 assign
= gfc_trans_assignment (c
->expr1
, c
->expr2
, false, true);
3403 /* Generate body and loops. */
3404 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
,
3406 gfc_add_expr_to_block (&block
, tmp
);
3409 /* Cleanup any temporary symtrees that have been made to deal
3410 with dependencies. */
3412 cleanup_forall_symtrees (c
);
3417 /* Translate WHERE or WHERE construct nested in FORALL. */
3418 gfc_trans_where_2 (c
, NULL
, false, nested_forall_info
, &block
);
3421 /* Pointer assignment inside FORALL. */
3422 case EXEC_POINTER_ASSIGN
:
3423 need_temp
= gfc_check_dependency (c
->expr1
, c
->expr2
, 0);
3425 gfc_trans_pointer_assign_need_temp (c
->expr1
, c
->expr2
,
3426 nested_forall_info
, &block
);
3429 /* Use the normal assignment copying routines. */
3430 assign
= gfc_trans_pointer_assignment (c
->expr1
, c
->expr2
);
3432 /* Generate body and loops. */
3433 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
,
3435 gfc_add_expr_to_block (&block
, tmp
);
3440 tmp
= gfc_trans_forall_1 (c
, nested_forall_info
);
3441 gfc_add_expr_to_block (&block
, tmp
);
3444 /* Explicit subroutine calls are prevented by the frontend but interface
3445 assignments can legitimately produce them. */
3446 case EXEC_ASSIGN_CALL
:
3447 assign
= gfc_trans_call (c
, true, NULL_TREE
, NULL_TREE
, false);
3448 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, assign
, 1);
3449 gfc_add_expr_to_block (&block
, tmp
);
3459 /* Restore the original index variables. */
3460 for (fa
= code
->ext
.forall_iterator
, n
= 0; fa
; fa
= fa
->next
, n
++)
3461 gfc_restore_sym (fa
->var
->symtree
->n
.sym
, &saved_vars
[n
]);
3463 /* Free the space for var, start, end, step, varexpr. */
3469 gfc_free (saved_vars
);
3471 for (this_forall
= info
->this_loop
; this_forall
;)
3473 iter_info
*next
= this_forall
->next
;
3474 gfc_free (this_forall
);
3478 /* Free the space for this forall_info. */
3483 /* Free the temporary for the mask. */
3484 tmp
= gfc_call_free (pmask
);
3485 gfc_add_expr_to_block (&block
, tmp
);
3488 pushdecl (maskindex
);
3490 gfc_add_block_to_block (&pre
, &block
);
3491 gfc_add_block_to_block (&pre
, &post
);
3493 return gfc_finish_block (&pre
);
3497 /* Translate the FORALL statement or construct. */
3499 tree
gfc_trans_forall (gfc_code
* code
)
3501 return gfc_trans_forall_1 (code
, NULL
);
3505 /* Evaluate the WHERE mask expression, copy its value to a temporary.
3506 If the WHERE construct is nested in FORALL, compute the overall temporary
3507 needed by the WHERE mask expression multiplied by the iterator number of
3509 ME is the WHERE mask expression.
3510 MASK is the current execution mask upon input, whose sense may or may
3511 not be inverted as specified by the INVERT argument.
3512 CMASK is the updated execution mask on output, or NULL if not required.
3513 PMASK is the pending execution mask on output, or NULL if not required.
3514 BLOCK is the block in which to place the condition evaluation loops. */
3517 gfc_evaluate_where_mask (gfc_expr
* me
, forall_info
* nested_forall_info
,
3518 tree mask
, bool invert
, tree cmask
, tree pmask
,
3519 tree mask_type
, stmtblock_t
* block
)
3524 stmtblock_t body
, body1
;
3525 tree count
, cond
, mtmp
;
3528 gfc_init_loopinfo (&loop
);
3530 lss
= gfc_walk_expr (me
);
3531 rss
= gfc_walk_expr (me
);
3533 /* Variable to index the temporary. */
3534 count
= gfc_create_var (gfc_array_index_type
, "count");
3535 /* Initialize count. */
3536 gfc_add_modify (block
, count
, gfc_index_zero_node
);
3538 gfc_start_block (&body
);
3540 gfc_init_se (&rse
, NULL
);
3541 gfc_init_se (&lse
, NULL
);
3543 if (lss
== gfc_ss_terminator
)
3545 gfc_init_block (&body1
);
3549 /* Initialize the loop. */
3550 gfc_init_loopinfo (&loop
);
3552 /* We may need LSS to determine the shape of the expression. */
3553 gfc_add_ss_to_loop (&loop
, lss
);
3554 gfc_add_ss_to_loop (&loop
, rss
);
3556 gfc_conv_ss_startstride (&loop
);
3557 gfc_conv_loop_setup (&loop
, &me
->where
);
3559 gfc_mark_ss_chain_used (rss
, 1);
3560 /* Start the loop body. */
3561 gfc_start_scalarized_body (&loop
, &body1
);
3563 /* Translate the expression. */
3564 gfc_copy_loopinfo_to_se (&rse
, &loop
);
3566 gfc_conv_expr (&rse
, me
);
3569 /* Variable to evaluate mask condition. */
3570 cond
= gfc_create_var (mask_type
, "cond");
3571 if (mask
&& (cmask
|| pmask
))
3572 mtmp
= gfc_create_var (mask_type
, "mask");
3573 else mtmp
= NULL_TREE
;
3575 gfc_add_block_to_block (&body1
, &lse
.pre
);
3576 gfc_add_block_to_block (&body1
, &rse
.pre
);
3578 gfc_add_modify (&body1
, cond
, fold_convert (mask_type
, rse
.expr
));
3580 if (mask
&& (cmask
|| pmask
))
3582 tmp
= gfc_build_array_ref (mask
, count
, NULL
);
3584 tmp
= fold_build1_loc (input_location
, TRUTH_NOT_EXPR
, mask_type
, tmp
);
3585 gfc_add_modify (&body1
, mtmp
, tmp
);
3590 tmp1
= gfc_build_array_ref (cmask
, count
, NULL
);
3593 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
, mask_type
,
3595 gfc_add_modify (&body1
, tmp1
, tmp
);
3600 tmp1
= gfc_build_array_ref (pmask
, count
, NULL
);
3601 tmp
= fold_build1_loc (input_location
, TRUTH_NOT_EXPR
, mask_type
, cond
);
3603 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
, mask_type
, mtmp
,
3605 gfc_add_modify (&body1
, tmp1
, tmp
);
3608 gfc_add_block_to_block (&body1
, &lse
.post
);
3609 gfc_add_block_to_block (&body1
, &rse
.post
);
3611 if (lss
== gfc_ss_terminator
)
3613 gfc_add_block_to_block (&body
, &body1
);
3617 /* Increment count. */
3618 tmp1
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
3619 count
, gfc_index_one_node
);
3620 gfc_add_modify (&body1
, count
, tmp1
);
3622 /* Generate the copying loops. */
3623 gfc_trans_scalarizing_loops (&loop
, &body1
);
3625 gfc_add_block_to_block (&body
, &loop
.pre
);
3626 gfc_add_block_to_block (&body
, &loop
.post
);
3628 gfc_cleanup_loop (&loop
);
3629 /* TODO: Reuse lss and rss when copying temp->lhs. Need to be careful
3630 as tree nodes in SS may not be valid in different scope. */
3633 tmp1
= gfc_finish_block (&body
);
3634 /* If the WHERE construct is inside FORALL, fill the full temporary. */
3635 if (nested_forall_info
!= NULL
)
3636 tmp1
= gfc_trans_nested_forall_loop (nested_forall_info
, tmp1
, 1);
3638 gfc_add_expr_to_block (block
, tmp1
);
3642 /* Translate an assignment statement in a WHERE statement or construct
3643 statement. The MASK expression is used to control which elements
3644 of EXPR1 shall be assigned. The sense of MASK is specified by
3648 gfc_trans_where_assign (gfc_expr
*expr1
, gfc_expr
*expr2
,
3649 tree mask
, bool invert
,
3650 tree count1
, tree count2
,
3656 gfc_ss
*lss_section
;
3663 tree index
, maskexpr
;
3665 /* A defined assignment. */
3666 if (cnext
&& cnext
->resolved_sym
)
3667 return gfc_trans_call (cnext
, true, mask
, count1
, invert
);
3670 /* TODO: handle this special case.
3671 Special case a single function returning an array. */
3672 if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->rank
> 0)
3674 tmp
= gfc_trans_arrayfunc_assign (expr1
, expr2
);
3680 /* Assignment of the form lhs = rhs. */
3681 gfc_start_block (&block
);
3683 gfc_init_se (&lse
, NULL
);
3684 gfc_init_se (&rse
, NULL
);
3687 lss
= gfc_walk_expr (expr1
);
3690 /* In each where-assign-stmt, the mask-expr and the variable being
3691 defined shall be arrays of the same shape. */
3692 gcc_assert (lss
!= gfc_ss_terminator
);
3694 /* The assignment needs scalarization. */
3697 /* Find a non-scalar SS from the lhs. */
3698 while (lss_section
!= gfc_ss_terminator
3699 && lss_section
->type
!= GFC_SS_SECTION
)
3700 lss_section
= lss_section
->next
;
3702 gcc_assert (lss_section
!= gfc_ss_terminator
);
3704 /* Initialize the scalarizer. */
3705 gfc_init_loopinfo (&loop
);
3708 rss
= gfc_walk_expr (expr2
);
3709 if (rss
== gfc_ss_terminator
)
3711 /* The rhs is scalar. Add a ss for the expression. */
3712 rss
= gfc_get_ss ();
3714 rss
->next
= gfc_ss_terminator
;
3715 rss
->type
= GFC_SS_SCALAR
;
3719 /* Associate the SS with the loop. */
3720 gfc_add_ss_to_loop (&loop
, lss
);
3721 gfc_add_ss_to_loop (&loop
, rss
);
3723 /* Calculate the bounds of the scalarization. */
3724 gfc_conv_ss_startstride (&loop
);
3726 /* Resolve any data dependencies in the statement. */
3727 gfc_conv_resolve_dependencies (&loop
, lss_section
, rss
);
3729 /* Setup the scalarizing loops. */
3730 gfc_conv_loop_setup (&loop
, &expr2
->where
);
3732 /* Setup the gfc_se structures. */
3733 gfc_copy_loopinfo_to_se (&lse
, &loop
);
3734 gfc_copy_loopinfo_to_se (&rse
, &loop
);
3737 gfc_mark_ss_chain_used (rss
, 1);
3738 if (loop
.temp_ss
== NULL
)
3741 gfc_mark_ss_chain_used (lss
, 1);
3745 lse
.ss
= loop
.temp_ss
;
3746 gfc_mark_ss_chain_used (lss
, 3);
3747 gfc_mark_ss_chain_used (loop
.temp_ss
, 3);
3750 /* Start the scalarized loop body. */
3751 gfc_start_scalarized_body (&loop
, &body
);
3753 /* Translate the expression. */
3754 gfc_conv_expr (&rse
, expr2
);
3755 if (lss
!= gfc_ss_terminator
&& loop
.temp_ss
!= NULL
)
3756 gfc_conv_tmp_array_ref (&lse
);
3758 gfc_conv_expr (&lse
, expr1
);
3760 /* Form the mask expression according to the mask. */
3762 maskexpr
= gfc_build_array_ref (mask
, index
, NULL
);
3764 maskexpr
= fold_build1_loc (input_location
, TRUTH_NOT_EXPR
,
3765 TREE_TYPE (maskexpr
), maskexpr
);
3767 /* Use the scalar assignment as is. */
3768 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
,
3769 loop
.temp_ss
!= NULL
, false, true);
3771 tmp
= build3_v (COND_EXPR
, maskexpr
, tmp
, build_empty_stmt (input_location
));
3773 gfc_add_expr_to_block (&body
, tmp
);
3775 if (lss
== gfc_ss_terminator
)
3777 /* Increment count1. */
3778 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
3779 count1
, gfc_index_one_node
);
3780 gfc_add_modify (&body
, count1
, tmp
);
3782 /* Use the scalar assignment as is. */
3783 gfc_add_block_to_block (&block
, &body
);
3787 gcc_assert (lse
.ss
== gfc_ss_terminator
3788 && rse
.ss
== gfc_ss_terminator
);
3790 if (loop
.temp_ss
!= NULL
)
3792 /* Increment count1 before finish the main body of a scalarized
3794 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
3795 gfc_array_index_type
, count1
, gfc_index_one_node
);
3796 gfc_add_modify (&body
, count1
, tmp
);
3797 gfc_trans_scalarized_loop_boundary (&loop
, &body
);
3799 /* We need to copy the temporary to the actual lhs. */
3800 gfc_init_se (&lse
, NULL
);
3801 gfc_init_se (&rse
, NULL
);
3802 gfc_copy_loopinfo_to_se (&lse
, &loop
);
3803 gfc_copy_loopinfo_to_se (&rse
, &loop
);
3805 rse
.ss
= loop
.temp_ss
;
3808 gfc_conv_tmp_array_ref (&rse
);
3809 gfc_conv_expr (&lse
, expr1
);
3811 gcc_assert (lse
.ss
== gfc_ss_terminator
3812 && rse
.ss
== gfc_ss_terminator
);
3814 /* Form the mask expression according to the mask tree list. */
3816 maskexpr
= gfc_build_array_ref (mask
, index
, NULL
);
3818 maskexpr
= fold_build1_loc (input_location
, TRUTH_NOT_EXPR
,
3819 TREE_TYPE (maskexpr
), maskexpr
);
3821 /* Use the scalar assignment as is. */
3822 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
, false, false,
3824 tmp
= build3_v (COND_EXPR
, maskexpr
, tmp
,
3825 build_empty_stmt (input_location
));
3826 gfc_add_expr_to_block (&body
, tmp
);
3828 /* Increment count2. */
3829 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
3830 gfc_array_index_type
, count2
,
3831 gfc_index_one_node
);
3832 gfc_add_modify (&body
, count2
, tmp
);
3836 /* Increment count1. */
3837 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
3838 gfc_array_index_type
, count1
,
3839 gfc_index_one_node
);
3840 gfc_add_modify (&body
, count1
, tmp
);
3843 /* Generate the copying loops. */
3844 gfc_trans_scalarizing_loops (&loop
, &body
);
3846 /* Wrap the whole thing up. */
3847 gfc_add_block_to_block (&block
, &loop
.pre
);
3848 gfc_add_block_to_block (&block
, &loop
.post
);
3849 gfc_cleanup_loop (&loop
);
3852 return gfc_finish_block (&block
);
3856 /* Translate the WHERE construct or statement.
3857 This function can be called iteratively to translate the nested WHERE
3858 construct or statement.
3859 MASK is the control mask. */
3862 gfc_trans_where_2 (gfc_code
* code
, tree mask
, bool invert
,
3863 forall_info
* nested_forall_info
, stmtblock_t
* block
)
3865 stmtblock_t inner_size_body
;
3866 tree inner_size
, size
;
3875 tree count1
, count2
;
3879 tree pcmask
= NULL_TREE
;
3880 tree ppmask
= NULL_TREE
;
3881 tree cmask
= NULL_TREE
;
3882 tree pmask
= NULL_TREE
;
3883 gfc_actual_arglist
*arg
;
3885 /* the WHERE statement or the WHERE construct statement. */
3886 cblock
= code
->block
;
3888 /* As the mask array can be very big, prefer compact boolean types. */
3889 mask_type
= gfc_get_logical_type (gfc_logical_kinds
[0].kind
);
3891 /* Determine which temporary masks are needed. */
3894 /* One clause: No ELSEWHEREs. */
3895 need_cmask
= (cblock
->next
!= 0);
3898 else if (cblock
->block
->block
)
3900 /* Three or more clauses: Conditional ELSEWHEREs. */
3904 else if (cblock
->next
)
3906 /* Two clauses, the first non-empty. */
3908 need_pmask
= (mask
!= NULL_TREE
3909 && cblock
->block
->next
!= 0);
3911 else if (!cblock
->block
->next
)
3913 /* Two clauses, both empty. */
3917 /* Two clauses, the first empty, the second non-empty. */
3920 need_cmask
= (cblock
->block
->expr1
!= 0);
3929 if (need_cmask
|| need_pmask
)
3931 /* Calculate the size of temporary needed by the mask-expr. */
3932 gfc_init_block (&inner_size_body
);
3933 inner_size
= compute_inner_temp_size (cblock
->expr1
, cblock
->expr1
,
3934 &inner_size_body
, &lss
, &rss
);
3936 gfc_free_ss_chain (lss
);
3937 gfc_free_ss_chain (rss
);
3939 /* Calculate the total size of temporary needed. */
3940 size
= compute_overall_iter_number (nested_forall_info
, inner_size
,
3941 &inner_size_body
, block
);
3943 /* Check whether the size is negative. */
3944 cond
= fold_build2_loc (input_location
, LE_EXPR
, boolean_type_node
, size
,
3945 gfc_index_zero_node
);
3946 size
= fold_build3_loc (input_location
, COND_EXPR
, gfc_array_index_type
,
3947 cond
, gfc_index_zero_node
, size
);
3948 size
= gfc_evaluate_now (size
, block
);
3950 /* Allocate temporary for WHERE mask if needed. */
3952 cmask
= allocate_temp_for_forall_nest_1 (mask_type
, size
, block
,
3955 /* Allocate temporary for !mask if needed. */
3957 pmask
= allocate_temp_for_forall_nest_1 (mask_type
, size
, block
,
3963 /* Each time around this loop, the where clause is conditional
3964 on the value of mask and invert, which are updated at the
3965 bottom of the loop. */
3967 /* Has mask-expr. */
3970 /* Ensure that the WHERE mask will be evaluated exactly once.
3971 If there are no statements in this WHERE/ELSEWHERE clause,
3972 then we don't need to update the control mask (cmask).
3973 If this is the last clause of the WHERE construct, then
3974 we don't need to update the pending control mask (pmask). */
3976 gfc_evaluate_where_mask (cblock
->expr1
, nested_forall_info
,
3978 cblock
->next
? cmask
: NULL_TREE
,
3979 cblock
->block
? pmask
: NULL_TREE
,
3982 gfc_evaluate_where_mask (cblock
->expr1
, nested_forall_info
,
3984 (cblock
->next
|| cblock
->block
)
3985 ? cmask
: NULL_TREE
,
3986 NULL_TREE
, mask_type
, block
);
3990 /* It's a final elsewhere-stmt. No mask-expr is present. */
3994 /* The body of this where clause are controlled by cmask with
3995 sense specified by invert. */
3997 /* Get the assignment statement of a WHERE statement, or the first
3998 statement in where-body-construct of a WHERE construct. */
3999 cnext
= cblock
->next
;
4004 /* WHERE assignment statement. */
4005 case EXEC_ASSIGN_CALL
:
4007 arg
= cnext
->ext
.actual
;
4008 expr1
= expr2
= NULL
;
4009 for (; arg
; arg
= arg
->next
)
4021 expr1
= cnext
->expr1
;
4022 expr2
= cnext
->expr2
;
4024 if (nested_forall_info
!= NULL
)
4026 need_temp
= gfc_check_dependency (expr1
, expr2
, 0);
4027 if (need_temp
&& cnext
->op
!= EXEC_ASSIGN_CALL
)
4028 gfc_trans_assign_need_temp (expr1
, expr2
,
4030 nested_forall_info
, block
);
4033 /* Variables to control maskexpr. */
4034 count1
= gfc_create_var (gfc_array_index_type
, "count1");
4035 count2
= gfc_create_var (gfc_array_index_type
, "count2");
4036 gfc_add_modify (block
, count1
, gfc_index_zero_node
);
4037 gfc_add_modify (block
, count2
, gfc_index_zero_node
);
4039 tmp
= gfc_trans_where_assign (expr1
, expr2
,
4044 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
,
4046 gfc_add_expr_to_block (block
, tmp
);
4051 /* Variables to control maskexpr. */
4052 count1
= gfc_create_var (gfc_array_index_type
, "count1");
4053 count2
= gfc_create_var (gfc_array_index_type
, "count2");
4054 gfc_add_modify (block
, count1
, gfc_index_zero_node
);
4055 gfc_add_modify (block
, count2
, gfc_index_zero_node
);
4057 tmp
= gfc_trans_where_assign (expr1
, expr2
,
4061 gfc_add_expr_to_block (block
, tmp
);
4066 /* WHERE or WHERE construct is part of a where-body-construct. */
4068 gfc_trans_where_2 (cnext
, cmask
, invert
,
4069 nested_forall_info
, block
);
4076 /* The next statement within the same where-body-construct. */
4077 cnext
= cnext
->next
;
4079 /* The next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt. */
4080 cblock
= cblock
->block
;
4081 if (mask
== NULL_TREE
)
4083 /* If we're the initial WHERE, we can simply invert the sense
4084 of the current mask to obtain the "mask" for the remaining
4091 /* Otherwise, for nested WHERE's we need to use the pending mask. */
4097 /* If we allocated a pending mask array, deallocate it now. */
4100 tmp
= gfc_call_free (ppmask
);
4101 gfc_add_expr_to_block (block
, tmp
);
4104 /* If we allocated a current mask array, deallocate it now. */
4107 tmp
= gfc_call_free (pcmask
);
4108 gfc_add_expr_to_block (block
, tmp
);
4112 /* Translate a simple WHERE construct or statement without dependencies.
4113 CBLOCK is the "then" clause of the WHERE statement, where CBLOCK->EXPR
4114 is the mask condition, and EBLOCK if non-NULL is the "else" clause.
4115 Currently both CBLOCK and EBLOCK are restricted to single assignments. */
4118 gfc_trans_where_3 (gfc_code
* cblock
, gfc_code
* eblock
)
4120 stmtblock_t block
, body
;
4121 gfc_expr
*cond
, *tdst
, *tsrc
, *edst
, *esrc
;
4122 tree tmp
, cexpr
, tstmt
, estmt
;
4123 gfc_ss
*css
, *tdss
, *tsss
;
4124 gfc_se cse
, tdse
, tsse
, edse
, esse
;
4129 /* Allow the scalarizer to workshare simple where loops. */
4130 if (ompws_flags
& OMPWS_WORKSHARE_FLAG
)
4131 ompws_flags
|= OMPWS_SCALARIZER_WS
;
4133 cond
= cblock
->expr1
;
4134 tdst
= cblock
->next
->expr1
;
4135 tsrc
= cblock
->next
->expr2
;
4136 edst
= eblock
? eblock
->next
->expr1
: NULL
;
4137 esrc
= eblock
? eblock
->next
->expr2
: NULL
;
4139 gfc_start_block (&block
);
4140 gfc_init_loopinfo (&loop
);
4142 /* Handle the condition. */
4143 gfc_init_se (&cse
, NULL
);
4144 css
= gfc_walk_expr (cond
);
4145 gfc_add_ss_to_loop (&loop
, css
);
4147 /* Handle the then-clause. */
4148 gfc_init_se (&tdse
, NULL
);
4149 gfc_init_se (&tsse
, NULL
);
4150 tdss
= gfc_walk_expr (tdst
);
4151 tsss
= gfc_walk_expr (tsrc
);
4152 if (tsss
== gfc_ss_terminator
)
4154 tsss
= gfc_get_ss ();
4156 tsss
->next
= gfc_ss_terminator
;
4157 tsss
->type
= GFC_SS_SCALAR
;
4160 gfc_add_ss_to_loop (&loop
, tdss
);
4161 gfc_add_ss_to_loop (&loop
, tsss
);
4165 /* Handle the else clause. */
4166 gfc_init_se (&edse
, NULL
);
4167 gfc_init_se (&esse
, NULL
);
4168 edss
= gfc_walk_expr (edst
);
4169 esss
= gfc_walk_expr (esrc
);
4170 if (esss
== gfc_ss_terminator
)
4172 esss
= gfc_get_ss ();
4174 esss
->next
= gfc_ss_terminator
;
4175 esss
->type
= GFC_SS_SCALAR
;
4178 gfc_add_ss_to_loop (&loop
, edss
);
4179 gfc_add_ss_to_loop (&loop
, esss
);
4182 gfc_conv_ss_startstride (&loop
);
4183 gfc_conv_loop_setup (&loop
, &tdst
->where
);
4185 gfc_mark_ss_chain_used (css
, 1);
4186 gfc_mark_ss_chain_used (tdss
, 1);
4187 gfc_mark_ss_chain_used (tsss
, 1);
4190 gfc_mark_ss_chain_used (edss
, 1);
4191 gfc_mark_ss_chain_used (esss
, 1);
4194 gfc_start_scalarized_body (&loop
, &body
);
4196 gfc_copy_loopinfo_to_se (&cse
, &loop
);
4197 gfc_copy_loopinfo_to_se (&tdse
, &loop
);
4198 gfc_copy_loopinfo_to_se (&tsse
, &loop
);
4204 gfc_copy_loopinfo_to_se (&edse
, &loop
);
4205 gfc_copy_loopinfo_to_se (&esse
, &loop
);
4210 gfc_conv_expr (&cse
, cond
);
4211 gfc_add_block_to_block (&body
, &cse
.pre
);
4214 gfc_conv_expr (&tsse
, tsrc
);
4215 if (tdss
!= gfc_ss_terminator
&& loop
.temp_ss
!= NULL
)
4216 gfc_conv_tmp_array_ref (&tdse
);
4218 gfc_conv_expr (&tdse
, tdst
);
4222 gfc_conv_expr (&esse
, esrc
);
4223 if (edss
!= gfc_ss_terminator
&& loop
.temp_ss
!= NULL
)
4224 gfc_conv_tmp_array_ref (&edse
);
4226 gfc_conv_expr (&edse
, edst
);
4229 tstmt
= gfc_trans_scalar_assign (&tdse
, &tsse
, tdst
->ts
, false, false, true);
4230 estmt
= eblock
? gfc_trans_scalar_assign (&edse
, &esse
, edst
->ts
, false,
4232 : build_empty_stmt (input_location
);
4233 tmp
= build3_v (COND_EXPR
, cexpr
, tstmt
, estmt
);
4234 gfc_add_expr_to_block (&body
, tmp
);
4235 gfc_add_block_to_block (&body
, &cse
.post
);
4237 gfc_trans_scalarizing_loops (&loop
, &body
);
4238 gfc_add_block_to_block (&block
, &loop
.pre
);
4239 gfc_add_block_to_block (&block
, &loop
.post
);
4240 gfc_cleanup_loop (&loop
);
4242 return gfc_finish_block (&block
);
4245 /* As the WHERE or WHERE construct statement can be nested, we call
4246 gfc_trans_where_2 to do the translation, and pass the initial
4247 NULL values for both the control mask and the pending control mask. */
4250 gfc_trans_where (gfc_code
* code
)
4256 cblock
= code
->block
;
4258 && cblock
->next
->op
== EXEC_ASSIGN
4259 && !cblock
->next
->next
)
4261 eblock
= cblock
->block
;
4264 /* A simple "WHERE (cond) x = y" statement or block is
4265 dependence free if cond is not dependent upon writing x,
4266 and the source y is unaffected by the destination x. */
4267 if (!gfc_check_dependency (cblock
->next
->expr1
,
4269 && !gfc_check_dependency (cblock
->next
->expr1
,
4270 cblock
->next
->expr2
, 0))
4271 return gfc_trans_where_3 (cblock
, NULL
);
4273 else if (!eblock
->expr1
4276 && eblock
->next
->op
== EXEC_ASSIGN
4277 && !eblock
->next
->next
)
4279 /* A simple "WHERE (cond) x1 = y1 ELSEWHERE x2 = y2 ENDWHERE"
4280 block is dependence free if cond is not dependent on writes
4281 to x1 and x2, y1 is not dependent on writes to x2, and y2
4282 is not dependent on writes to x1, and both y's are not
4283 dependent upon their own x's. In addition to this, the
4284 final two dependency checks below exclude all but the same
4285 array reference if the where and elswhere destinations
4286 are the same. In short, this is VERY conservative and this
4287 is needed because the two loops, required by the standard
4288 are coalesced in gfc_trans_where_3. */
4289 if (!gfc_check_dependency(cblock
->next
->expr1
,
4291 && !gfc_check_dependency(eblock
->next
->expr1
,
4293 && !gfc_check_dependency(cblock
->next
->expr1
,
4294 eblock
->next
->expr2
, 1)
4295 && !gfc_check_dependency(eblock
->next
->expr1
,
4296 cblock
->next
->expr2
, 1)
4297 && !gfc_check_dependency(cblock
->next
->expr1
,
4298 cblock
->next
->expr2
, 1)
4299 && !gfc_check_dependency(eblock
->next
->expr1
,
4300 eblock
->next
->expr2
, 1)
4301 && !gfc_check_dependency(cblock
->next
->expr1
,
4302 eblock
->next
->expr1
, 0)
4303 && !gfc_check_dependency(eblock
->next
->expr1
,
4304 cblock
->next
->expr1
, 0))
4305 return gfc_trans_where_3 (cblock
, eblock
);
4309 gfc_start_block (&block
);
4311 gfc_trans_where_2 (code
, NULL
, false, NULL
, &block
);
4313 return gfc_finish_block (&block
);
4317 /* CYCLE a DO loop. The label decl has already been created by
4318 gfc_trans_do(), it's in TREE_PURPOSE (backend_decl) of the gfc_code
4319 node at the head of the loop. We must mark the label as used. */
4322 gfc_trans_cycle (gfc_code
* code
)
4326 cycle_label
= code
->ext
.which_construct
->cycle_label
;
4327 gcc_assert (cycle_label
);
4329 TREE_USED (cycle_label
) = 1;
4330 return build1_v (GOTO_EXPR
, cycle_label
);
4334 /* EXIT a DO loop. Similar to CYCLE, but now the label is in
4335 TREE_VALUE (backend_decl) of the gfc_code node at the head of the
4339 gfc_trans_exit (gfc_code
* code
)
4343 exit_label
= code
->ext
.which_construct
->exit_label
;
4344 gcc_assert (exit_label
);
4346 TREE_USED (exit_label
) = 1;
4347 return build1_v (GOTO_EXPR
, exit_label
);
4351 /* Translate the ALLOCATE statement. */
4354 gfc_trans_allocate (gfc_code
* code
)
4367 if (!code
->ext
.alloc
.list
)
4370 pstat
= stat
= error_label
= tmp
= memsz
= NULL_TREE
;
4372 gfc_start_block (&block
);
4374 /* Either STAT= and/or ERRMSG is present. */
4375 if (code
->expr1
|| code
->expr2
)
4377 tree gfc_int4_type_node
= gfc_get_int_type (4);
4379 stat
= gfc_create_var (gfc_int4_type_node
, "stat");
4380 pstat
= gfc_build_addr_expr (NULL_TREE
, stat
);
4382 error_label
= gfc_build_label_decl (NULL_TREE
);
4383 TREE_USED (error_label
) = 1;
4386 for (al
= code
->ext
.alloc
.list
; al
!= NULL
; al
= al
->next
)
4388 expr
= gfc_copy_expr (al
->expr
);
4390 if (expr
->ts
.type
== BT_CLASS
)
4391 gfc_add_component_ref (expr
, "$data");
4393 gfc_init_se (&se
, NULL
);
4394 gfc_start_block (&se
.pre
);
4396 se
.want_pointer
= 1;
4397 se
.descriptor_only
= 1;
4398 gfc_conv_expr (&se
, expr
);
4400 if (!gfc_array_allocate (&se
, expr
, pstat
))
4402 /* A scalar or derived type. */
4404 /* Determine allocate size. */
4405 if (al
->expr
->ts
.type
== BT_CLASS
&& code
->expr3
)
4407 if (code
->expr3
->ts
.type
== BT_CLASS
)
4411 sz
= gfc_copy_expr (code
->expr3
);
4412 gfc_add_component_ref (sz
, "$vptr");
4413 gfc_add_component_ref (sz
, "$size");
4414 gfc_init_se (&se_sz
, NULL
);
4415 gfc_conv_expr (&se_sz
, sz
);
4420 memsz
= TYPE_SIZE_UNIT (gfc_typenode_for_spec (&code
->expr3
->ts
));
4422 else if (code
->ext
.alloc
.ts
.type
!= BT_UNKNOWN
)
4423 memsz
= TYPE_SIZE_UNIT (gfc_typenode_for_spec (&code
->ext
.alloc
.ts
));
4425 memsz
= TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (se
.expr
)));
4427 if (expr
->ts
.type
== BT_CHARACTER
&& memsz
== NULL_TREE
)
4428 memsz
= se
.string_length
;
4430 /* Allocate - for non-pointers with re-alloc checking. */
4437 /* Find the last reference in the chain. */
4438 while (ref
&& ref
->next
!= NULL
)
4440 gcc_assert (ref
->type
!= REF_ARRAY
|| ref
->u
.ar
.type
== AR_ELEMENT
);
4445 allocatable
= expr
->symtree
->n
.sym
->attr
.allocatable
;
4447 allocatable
= ref
->u
.c
.component
->attr
.allocatable
;
4450 tmp
= gfc_allocate_array_with_status (&se
.pre
, se
.expr
, memsz
,
4453 tmp
= gfc_allocate_with_status (&se
.pre
, memsz
, pstat
);
4456 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
, void_type_node
,
4458 fold_convert (TREE_TYPE (se
.expr
), tmp
));
4459 gfc_add_expr_to_block (&se
.pre
, tmp
);
4461 if (code
->expr1
|| code
->expr2
)
4463 tmp
= build1_v (GOTO_EXPR
, error_label
);
4464 parm
= fold_build2_loc (input_location
, NE_EXPR
,
4465 boolean_type_node
, stat
,
4466 build_int_cst (TREE_TYPE (stat
), 0));
4467 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
4469 build_empty_stmt (input_location
));
4470 gfc_add_expr_to_block (&se
.pre
, tmp
);
4473 if (expr
->ts
.type
== BT_DERIVED
&& expr
->ts
.u
.derived
->attr
.alloc_comp
)
4475 tmp
= build_fold_indirect_ref_loc (input_location
, se
.expr
);
4476 tmp
= gfc_nullify_alloc_comp (expr
->ts
.u
.derived
, tmp
, 0);
4477 gfc_add_expr_to_block (&se
.pre
, tmp
);
4482 tmp
= gfc_finish_block (&se
.pre
);
4483 gfc_add_expr_to_block (&block
, tmp
);
4485 if (code
->expr3
&& !code
->expr3
->mold
)
4487 /* Initialization via SOURCE block
4488 (or static default initializer). */
4489 gfc_expr
*rhs
= gfc_copy_expr (code
->expr3
);
4490 if (al
->expr
->ts
.type
== BT_CLASS
)
4493 if (rhs
->ts
.type
== BT_CLASS
)
4494 gfc_add_component_ref (rhs
, "$data");
4495 gfc_init_se (&dst
, NULL
);
4496 gfc_init_se (&src
, NULL
);
4497 gfc_conv_expr (&dst
, expr
);
4498 gfc_conv_expr (&src
, rhs
);
4499 gfc_add_block_to_block (&block
, &src
.pre
);
4500 tmp
= gfc_build_memcpy_call (dst
.expr
, src
.expr
, memsz
);
4503 tmp
= gfc_trans_assignment (gfc_expr_to_initialize (expr
),
4505 gfc_free_expr (rhs
);
4506 gfc_add_expr_to_block (&block
, tmp
);
4508 else if (code
->expr3
&& code
->expr3
->mold
4509 && code
->expr3
->ts
.type
== BT_CLASS
)
4511 /* Default-initialization via MOLD (polymorphic). */
4512 gfc_expr
*rhs
= gfc_copy_expr (code
->expr3
);
4514 gfc_add_component_ref (rhs
, "$vptr");
4515 gfc_add_component_ref (rhs
, "$def_init");
4516 gfc_init_se (&dst
, NULL
);
4517 gfc_init_se (&src
, NULL
);
4518 gfc_conv_expr (&dst
, expr
);
4519 gfc_conv_expr (&src
, rhs
);
4520 gfc_add_block_to_block (&block
, &src
.pre
);
4521 tmp
= gfc_build_memcpy_call (dst
.expr
, src
.expr
, memsz
);
4522 gfc_add_expr_to_block (&block
, tmp
);
4523 gfc_free_expr (rhs
);
4526 /* Allocation of CLASS entities. */
4527 gfc_free_expr (expr
);
4529 if (expr
->ts
.type
== BT_CLASS
)
4534 /* Initialize VPTR for CLASS objects. */
4535 lhs
= gfc_expr_to_initialize (expr
);
4536 gfc_add_component_ref (lhs
, "$vptr");
4538 if (code
->expr3
&& code
->expr3
->ts
.type
== BT_CLASS
)
4540 /* Polymorphic SOURCE: VPTR must be determined at run time. */
4541 rhs
= gfc_copy_expr (code
->expr3
);
4542 gfc_add_component_ref (rhs
, "$vptr");
4543 tmp
= gfc_trans_pointer_assignment (lhs
, rhs
);
4544 gfc_add_expr_to_block (&block
, tmp
);
4545 gfc_free_expr (rhs
);
4549 /* VPTR is fixed at compile time. */
4553 ts
= &code
->expr3
->ts
;
4554 else if (expr
->ts
.type
== BT_DERIVED
)
4556 else if (code
->ext
.alloc
.ts
.type
== BT_DERIVED
)
4557 ts
= &code
->ext
.alloc
.ts
;
4558 else if (expr
->ts
.type
== BT_CLASS
)
4559 ts
= &CLASS_DATA (expr
)->ts
;
4563 if (ts
->type
== BT_DERIVED
)
4565 vtab
= gfc_find_derived_vtab (ts
->u
.derived
);
4567 gfc_init_se (&lse
, NULL
);
4568 lse
.want_pointer
= 1;
4569 gfc_conv_expr (&lse
, lhs
);
4570 tmp
= gfc_build_addr_expr (NULL_TREE
,
4571 gfc_get_symbol_decl (vtab
));
4572 gfc_add_modify (&block
, lse
.expr
,
4573 fold_convert (TREE_TYPE (lse
.expr
), tmp
));
4576 gfc_free_expr (lhs
);
4584 tmp
= build1_v (LABEL_EXPR
, error_label
);
4585 gfc_add_expr_to_block (&block
, tmp
);
4587 gfc_init_se (&se
, NULL
);
4588 gfc_conv_expr_lhs (&se
, code
->expr1
);
4589 tmp
= convert (TREE_TYPE (se
.expr
), stat
);
4590 gfc_add_modify (&block
, se
.expr
, tmp
);
4596 /* A better error message may be possible, but not required. */
4597 const char *msg
= "Attempt to allocate an allocated object";
4598 tree errmsg
, slen
, dlen
;
4600 gfc_init_se (&se
, NULL
);
4601 gfc_conv_expr_lhs (&se
, code
->expr2
);
4603 errmsg
= gfc_create_var (pchar_type_node
, "ERRMSG");
4605 gfc_add_modify (&block
, errmsg
,
4606 gfc_build_addr_expr (pchar_type_node
,
4607 gfc_build_localized_cstring_const (msg
)));
4609 slen
= build_int_cst (gfc_charlen_type_node
, ((int) strlen (msg
)));
4610 dlen
= gfc_get_expr_charlen (code
->expr2
);
4611 slen
= fold_build2_loc (input_location
, MIN_EXPR
, TREE_TYPE (slen
), dlen
,
4614 dlen
= build_call_expr_loc (input_location
,
4615 built_in_decls
[BUILT_IN_MEMCPY
], 3,
4616 gfc_build_addr_expr (pvoid_type_node
, se
.expr
), errmsg
, slen
);
4618 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, stat
,
4619 build_int_cst (TREE_TYPE (stat
), 0));
4621 tmp
= build3_v (COND_EXPR
, tmp
, dlen
, build_empty_stmt (input_location
));
4623 gfc_add_expr_to_block (&block
, tmp
);
4626 return gfc_finish_block (&block
);
4630 /* Translate a DEALLOCATE statement. */
4633 gfc_trans_deallocate (gfc_code
*code
)
4638 tree apstat
, astat
, pstat
, stat
, tmp
;
4641 pstat
= apstat
= stat
= astat
= tmp
= NULL_TREE
;
4643 gfc_start_block (&block
);
4645 /* Count the number of failed deallocations. If deallocate() was
4646 called with STAT= , then set STAT to the count. If deallocate
4647 was called with ERRMSG, then set ERRMG to a string. */
4648 if (code
->expr1
|| code
->expr2
)
4650 tree gfc_int4_type_node
= gfc_get_int_type (4);
4652 stat
= gfc_create_var (gfc_int4_type_node
, "stat");
4653 pstat
= gfc_build_addr_expr (NULL_TREE
, stat
);
4655 /* Running total of possible deallocation failures. */
4656 astat
= gfc_create_var (gfc_int4_type_node
, "astat");
4657 apstat
= gfc_build_addr_expr (NULL_TREE
, astat
);
4659 /* Initialize astat to 0. */
4660 gfc_add_modify (&block
, astat
, build_int_cst (TREE_TYPE (astat
), 0));
4663 for (al
= code
->ext
.alloc
.list
; al
!= NULL
; al
= al
->next
)
4666 gcc_assert (expr
->expr_type
== EXPR_VARIABLE
);
4668 gfc_init_se (&se
, NULL
);
4669 gfc_start_block (&se
.pre
);
4671 se
.want_pointer
= 1;
4672 se
.descriptor_only
= 1;
4673 gfc_conv_expr (&se
, expr
);
4675 if (expr
->ts
.type
== BT_DERIVED
&& expr
->ts
.u
.derived
->attr
.alloc_comp
)
4678 gfc_ref
*last
= NULL
;
4679 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
4680 if (ref
->type
== REF_COMPONENT
)
4683 /* Do not deallocate the components of a derived type
4684 ultimate pointer component. */
4685 if (!(last
&& last
->u
.c
.component
->attr
.pointer
)
4686 && !(!last
&& expr
->symtree
->n
.sym
->attr
.pointer
))
4688 tmp
= gfc_deallocate_alloc_comp (expr
->ts
.u
.derived
, se
.expr
,
4690 gfc_add_expr_to_block (&se
.pre
, tmp
);
4695 tmp
= gfc_array_deallocate (se
.expr
, pstat
, expr
);
4698 tmp
= gfc_deallocate_with_status (se
.expr
, pstat
, false, expr
);
4699 gfc_add_expr_to_block (&se
.pre
, tmp
);
4701 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
, void_type_node
,
4703 build_int_cst (TREE_TYPE (se
.expr
), 0));
4706 gfc_add_expr_to_block (&se
.pre
, tmp
);
4708 /* Keep track of the number of failed deallocations by adding stat
4709 of the last deallocation to the running total. */
4710 if (code
->expr1
|| code
->expr2
)
4712 apstat
= fold_build2_loc (input_location
, PLUS_EXPR
,
4713 TREE_TYPE (stat
), astat
, stat
);
4714 gfc_add_modify (&se
.pre
, astat
, apstat
);
4717 tmp
= gfc_finish_block (&se
.pre
);
4718 gfc_add_expr_to_block (&block
, tmp
);
4725 gfc_init_se (&se
, NULL
);
4726 gfc_conv_expr_lhs (&se
, code
->expr1
);
4727 tmp
= convert (TREE_TYPE (se
.expr
), astat
);
4728 gfc_add_modify (&block
, se
.expr
, tmp
);
4734 /* A better error message may be possible, but not required. */
4735 const char *msg
= "Attempt to deallocate an unallocated object";
4736 tree errmsg
, slen
, dlen
;
4738 gfc_init_se (&se
, NULL
);
4739 gfc_conv_expr_lhs (&se
, code
->expr2
);
4741 errmsg
= gfc_create_var (pchar_type_node
, "ERRMSG");
4743 gfc_add_modify (&block
, errmsg
,
4744 gfc_build_addr_expr (pchar_type_node
,
4745 gfc_build_localized_cstring_const (msg
)));
4747 slen
= build_int_cst (gfc_charlen_type_node
, ((int) strlen (msg
)));
4748 dlen
= gfc_get_expr_charlen (code
->expr2
);
4749 slen
= fold_build2_loc (input_location
, MIN_EXPR
, TREE_TYPE (slen
), dlen
,
4752 dlen
= build_call_expr_loc (input_location
,
4753 built_in_decls
[BUILT_IN_MEMCPY
], 3,
4754 gfc_build_addr_expr (pvoid_type_node
, se
.expr
), errmsg
, slen
);
4756 tmp
= fold_build2_loc (input_location
, NE_EXPR
, boolean_type_node
, astat
,
4757 build_int_cst (TREE_TYPE (astat
), 0));
4759 tmp
= build3_v (COND_EXPR
, tmp
, dlen
, build_empty_stmt (input_location
));
4761 gfc_add_expr_to_block (&block
, tmp
);
4764 return gfc_finish_block (&block
);
4767 #include "gt-fortran-trans-stmt.h"