1 /* Statement translation -- generate GCC trees from gfc_code.
2 Copyright (C) 2002-2022 Free Software Foundation, Inc.
3 Contributed by Paul Brook <paul@nowt.org>
4 and Steven Bosscher <s.bosscher@student.tudelft.nl>
6 This file is part of GCC.
8 GCC is free software; you can redistribute it and/or modify it under
9 the terms of the GNU General Public License as published by the Free
10 Software Foundation; either version 3, or (at your option) any later
13 GCC is distributed in the hope that it will be useful, but WITHOUT ANY
14 WARRANTY; without even the implied warranty of MERCHANTABILITY or
15 FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
18 You should have received a copy of the GNU General Public License
19 along with GCC; see the file COPYING3. If not see
20 <http://www.gnu.org/licenses/>. */
25 #include "coretypes.h"
30 #include "stringpool.h"
31 #include "fold-const.h"
32 #include "trans-stmt.h"
33 #include "trans-types.h"
34 #include "trans-array.h"
35 #include "trans-const.h"
36 #include "dependency.h"
38 typedef struct iter_info
44 struct iter_info
*next
;
48 typedef struct forall_info
55 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
112 || code
->label1
->defined
== ST_LABEL_DO_TARGET
)
114 label_tree
= gfc_build_addr_expr (pvoid_type_node
, label_tree
);
115 len_tree
= build_int_cst (gfc_charlen_type_node
, -1);
119 gfc_expr
*format
= code
->label1
->format
;
121 label_len
= format
->value
.character
.length
;
122 len_tree
= build_int_cst (gfc_charlen_type_node
, label_len
);
123 label_tree
= gfc_build_wide_string_const (format
->ts
.kind
, label_len
+ 1,
124 format
->value
.character
.string
);
125 label_tree
= gfc_build_addr_expr (pvoid_type_node
, label_tree
);
128 gfc_add_modify (&se
.pre
, len
, fold_convert (TREE_TYPE (len
), len_tree
));
129 gfc_add_modify (&se
.pre
, addr
, label_tree
);
131 return gfc_finish_block (&se
.pre
);
134 /* Translate a GOTO statement. */
137 gfc_trans_goto (gfc_code
* code
)
139 locus loc
= code
->loc
;
145 if (code
->label1
!= NULL
)
146 return build1_v (GOTO_EXPR
, gfc_get_label_decl (code
->label1
));
149 gfc_init_se (&se
, NULL
);
150 gfc_start_block (&se
.pre
);
151 gfc_conv_label_variable (&se
, code
->expr1
);
152 tmp
= GFC_DECL_STRING_LEN (se
.expr
);
153 tmp
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
, tmp
,
154 build_int_cst (TREE_TYPE (tmp
), -1));
155 gfc_trans_runtime_check (true, false, tmp
, &se
.pre
, &loc
,
156 "Assigned label is not a target label");
158 assigned_goto
= GFC_DECL_ASSIGN_ADDR (se
.expr
);
160 /* We're going to ignore a label list. It does not really change the
161 statement's semantics (because it is just a further restriction on
162 what's legal code); before, we were comparing label addresses here, but
163 that's a very fragile business and may break with optimization. So
166 target
= fold_build1_loc (input_location
, GOTO_EXPR
, void_type_node
,
168 gfc_add_expr_to_block (&se
.pre
, target
);
169 return gfc_finish_block (&se
.pre
);
173 /* Translate an ENTRY statement. Just adds a label for this entry point. */
175 gfc_trans_entry (gfc_code
* code
)
177 return build1_v (LABEL_EXPR
, code
->ext
.entry
->label
);
181 /* Replace a gfc_ss structure by another both in the gfc_se struct
182 and the gfc_loopinfo struct. This is used in gfc_conv_elemental_dependencies
183 to replace a variable ss by the corresponding temporary. */
186 replace_ss (gfc_se
*se
, gfc_ss
*old_ss
, gfc_ss
*new_ss
)
188 gfc_ss
**sess
, **loopss
;
190 /* The old_ss is a ss for a single variable. */
191 gcc_assert (old_ss
->info
->type
== GFC_SS_SECTION
);
193 for (sess
= &(se
->ss
); *sess
!= gfc_ss_terminator
; sess
= &((*sess
)->next
))
196 gcc_assert (*sess
!= gfc_ss_terminator
);
199 new_ss
->next
= old_ss
->next
;
201 /* Make sure that trailing references are not lost. */
203 && old_ss
->info
->data
.array
.ref
204 && old_ss
->info
->data
.array
.ref
->next
205 && !(new_ss
->info
->data
.array
.ref
206 && new_ss
->info
->data
.array
.ref
->next
))
207 new_ss
->info
->data
.array
.ref
= old_ss
->info
->data
.array
.ref
;
209 for (loopss
= &(se
->loop
->ss
); *loopss
!= gfc_ss_terminator
;
210 loopss
= &((*loopss
)->loop_chain
))
211 if (*loopss
== old_ss
)
213 gcc_assert (*loopss
!= gfc_ss_terminator
);
216 new_ss
->loop_chain
= old_ss
->loop_chain
;
217 new_ss
->loop
= old_ss
->loop
;
219 gfc_free_ss (old_ss
);
223 /* Check for dependencies between INTENT(IN) and INTENT(OUT) arguments of
224 elemental subroutines. Make temporaries for output arguments if any such
225 dependencies are found. Output arguments are chosen because internal_unpack
226 can be used, as is, to copy the result back to the variable. */
228 gfc_conv_elemental_dependencies (gfc_se
* se
, gfc_se
* loopse
,
229 gfc_symbol
* sym
, gfc_actual_arglist
* arg
,
230 gfc_dep_check check_variable
)
232 gfc_actual_arglist
*arg0
;
234 gfc_formal_arglist
*formal
;
242 if (loopse
->ss
== NULL
)
247 formal
= gfc_sym_get_dummy_args (sym
);
249 /* Loop over all the arguments testing for dependencies. */
250 for (; arg
!= NULL
; arg
= arg
->next
, formal
= formal
? formal
->next
: NULL
)
256 /* Obtain the info structure for the current argument. */
257 for (ss
= loopse
->ss
; ss
&& ss
!= gfc_ss_terminator
; ss
= ss
->next
)
258 if (ss
->info
->expr
== e
)
261 /* If there is a dependency, create a temporary and use it
262 instead of the variable. */
263 fsym
= formal
? formal
->sym
: NULL
;
264 if (e
->expr_type
== EXPR_VARIABLE
266 && fsym
->attr
.intent
!= INTENT_IN
267 && gfc_check_fncall_dependency (e
, fsym
->attr
.intent
,
268 sym
, arg0
, check_variable
))
270 tree initial
, temptype
;
271 stmtblock_t temp_post
;
274 tmp_ss
= gfc_get_array_ss (gfc_ss_terminator
, NULL
, ss
->dimen
,
276 gfc_mark_ss_chain_used (tmp_ss
, 1);
277 tmp_ss
->info
->expr
= ss
->info
->expr
;
278 replace_ss (loopse
, ss
, tmp_ss
);
280 /* Obtain the argument descriptor for unpacking. */
281 gfc_init_se (&parmse
, NULL
);
282 parmse
.want_pointer
= 1;
283 gfc_conv_expr_descriptor (&parmse
, e
);
284 gfc_add_block_to_block (&se
->pre
, &parmse
.pre
);
286 /* If we've got INTENT(INOUT) or a derived type with INTENT(OUT),
287 initialize the array temporary with a copy of the values. */
288 if (fsym
->attr
.intent
== INTENT_INOUT
289 || (fsym
->ts
.type
==BT_DERIVED
290 && fsym
->attr
.intent
== INTENT_OUT
))
291 initial
= parmse
.expr
;
292 /* For class expressions, we always initialize with the copy of
294 else if (e
->ts
.type
== BT_CLASS
)
295 initial
= parmse
.expr
;
299 if (e
->ts
.type
!= BT_CLASS
)
301 /* Find the type of the temporary to create; we don't use the type
302 of e itself as this breaks for subcomponent-references in e
303 (where the type of e is that of the final reference, but
304 parmse.expr's type corresponds to the full derived-type). */
305 /* TODO: Fix this somehow so we don't need a temporary of the whole
306 array but instead only the components referenced. */
307 temptype
= TREE_TYPE (parmse
.expr
); /* Pointer to descriptor. */
308 gcc_assert (TREE_CODE (temptype
) == POINTER_TYPE
);
309 temptype
= TREE_TYPE (temptype
);
310 temptype
= gfc_get_element_type (temptype
);
314 /* For class arrays signal that the size of the dynamic type has to
315 be obtained from the vtable, using the 'initial' expression. */
316 temptype
= NULL_TREE
;
318 /* Generate the temporary. Cleaning up the temporary should be the
319 very last thing done, so we add the code to a new block and add it
320 to se->post as last instructions. */
321 size
= gfc_create_var (gfc_array_index_type
, NULL
);
322 data
= gfc_create_var (pvoid_type_node
, NULL
);
323 gfc_init_block (&temp_post
);
324 tmp
= gfc_trans_create_temp_array (&se
->pre
, &temp_post
, tmp_ss
,
325 temptype
, initial
, false, true,
326 false, &arg
->expr
->where
);
327 gfc_add_modify (&se
->pre
, size
, tmp
);
328 tmp
= fold_convert (pvoid_type_node
, tmp_ss
->info
->data
.array
.data
);
329 gfc_add_modify (&se
->pre
, data
, tmp
);
331 /* Update other ss' delta. */
332 gfc_set_delta (loopse
->loop
);
334 /* Copy the result back using unpack..... */
335 if (e
->ts
.type
!= BT_CLASS
)
336 tmp
= build_call_expr_loc (input_location
,
337 gfor_fndecl_in_unpack
, 2, parmse
.expr
, data
);
340 /* ... except for class results where the copy is
342 tmp
= build_fold_indirect_ref_loc (input_location
, parmse
.expr
);
343 tmp
= gfc_conv_descriptor_data_get (tmp
);
344 tmp
= build_call_expr_loc (input_location
,
345 builtin_decl_explicit (BUILT_IN_MEMCPY
),
347 fold_convert (size_type_node
, size
));
349 gfc_add_expr_to_block (&se
->post
, tmp
);
351 /* parmse.pre is already added above. */
352 gfc_add_block_to_block (&se
->post
, &parmse
.post
);
353 gfc_add_block_to_block (&se
->post
, &temp_post
);
359 /* Given an executable statement referring to an intrinsic function call,
360 returns the intrinsic symbol. */
362 static gfc_intrinsic_sym
*
363 get_intrinsic_for_code (gfc_code
*code
)
365 if (code
->op
== EXEC_CALL
)
367 gfc_intrinsic_sym
* const isym
= code
->resolved_isym
;
371 return gfc_get_intrinsic_for_expr (code
->expr1
);
378 /* Translate the CALL statement. Builds a call to an F95 subroutine. */
381 gfc_trans_call (gfc_code
* code
, bool dependency_check
,
382 tree mask
, tree count1
, bool invert
)
386 int has_alternate_specifier
;
387 gfc_dep_check check_variable
;
388 tree index
= NULL_TREE
;
389 tree maskexpr
= NULL_TREE
;
391 bool is_intrinsic_mvbits
;
393 /* A CALL starts a new block because the actual arguments may have to
394 be evaluated first. */
395 gfc_init_se (&se
, NULL
);
396 gfc_start_block (&se
.pre
);
398 gcc_assert (code
->resolved_sym
);
400 ss
= gfc_ss_terminator
;
401 if (code
->resolved_sym
->attr
.elemental
)
402 ss
= gfc_walk_elemental_function_args (ss
, code
->ext
.actual
,
403 get_intrinsic_for_code (code
),
406 /* MVBITS is inlined but needs the dependency checking found here. */
407 is_intrinsic_mvbits
= code
->resolved_isym
408 && code
->resolved_isym
->id
== GFC_ISYM_MVBITS
;
410 /* Is not an elemental subroutine call with array valued arguments. */
411 if (ss
== gfc_ss_terminator
)
414 if (is_intrinsic_mvbits
)
416 has_alternate_specifier
= 0;
417 gfc_conv_intrinsic_mvbits (&se
, code
->ext
.actual
, NULL
);
421 /* Translate the call. */
422 has_alternate_specifier
=
423 gfc_conv_procedure_call (&se
, code
->resolved_sym
,
424 code
->ext
.actual
, code
->expr1
, NULL
);
426 /* A subroutine without side-effect, by definition, does nothing! */
427 TREE_SIDE_EFFECTS (se
.expr
) = 1;
430 /* Chain the pieces together and return the block. */
431 if (has_alternate_specifier
)
433 gfc_code
*select_code
;
435 select_code
= code
->next
;
436 gcc_assert(select_code
->op
== EXEC_SELECT
);
437 sym
= select_code
->expr1
->symtree
->n
.sym
;
438 se
.expr
= convert (gfc_typenode_for_spec (&sym
->ts
), se
.expr
);
439 if (sym
->backend_decl
== NULL
)
440 sym
->backend_decl
= gfc_get_symbol_decl (sym
);
441 gfc_add_modify (&se
.pre
, sym
->backend_decl
, se
.expr
);
444 gfc_add_expr_to_block (&se
.pre
, se
.expr
);
446 gfc_add_block_to_block (&se
.pre
, &se
.post
);
451 /* An elemental subroutine call with array valued arguments has
459 /* gfc_walk_elemental_function_args renders the ss chain in the
460 reverse order to the actual argument order. */
461 ss
= gfc_reverse_ss (ss
);
463 /* Initialize the loop. */
464 gfc_init_se (&loopse
, NULL
);
465 gfc_init_loopinfo (&loop
);
466 gfc_add_ss_to_loop (&loop
, ss
);
468 gfc_conv_ss_startstride (&loop
);
469 /* TODO: gfc_conv_loop_setup generates a temporary for vector
470 subscripts. This could be prevented in the elemental case
471 as temporaries are handled separatedly
472 (below in gfc_conv_elemental_dependencies). */
474 gfc_conv_loop_setup (&loop
, &code
->expr1
->where
);
476 gfc_conv_loop_setup (&loop
, &code
->loc
);
478 gfc_mark_ss_chain_used (ss
, 1);
480 /* Convert the arguments, checking for dependencies. */
481 gfc_copy_loopinfo_to_se (&loopse
, &loop
);
484 /* For operator assignment, do dependency checking. */
485 if (dependency_check
)
486 check_variable
= ELEM_CHECK_VARIABLE
;
488 check_variable
= ELEM_DONT_CHECK_VARIABLE
;
490 gfc_init_se (&depse
, NULL
);
491 gfc_conv_elemental_dependencies (&depse
, &loopse
, code
->resolved_sym
,
492 code
->ext
.actual
, check_variable
);
494 gfc_add_block_to_block (&loop
.pre
, &depse
.pre
);
495 gfc_add_block_to_block (&loop
.post
, &depse
.post
);
497 /* Generate the loop body. */
498 gfc_start_scalarized_body (&loop
, &body
);
499 gfc_init_block (&block
);
503 /* Form the mask expression according to the mask. */
505 maskexpr
= gfc_build_array_ref (mask
, index
, NULL
);
507 maskexpr
= fold_build1_loc (input_location
, TRUTH_NOT_EXPR
,
508 TREE_TYPE (maskexpr
), maskexpr
);
511 if (is_intrinsic_mvbits
)
513 has_alternate_specifier
= 0;
514 gfc_conv_intrinsic_mvbits (&loopse
, code
->ext
.actual
, &loop
);
518 /* Add the subroutine call to the block. */
519 gfc_conv_procedure_call (&loopse
, code
->resolved_sym
,
520 code
->ext
.actual
, code
->expr1
,
526 tmp
= build3_v (COND_EXPR
, maskexpr
, loopse
.expr
,
527 build_empty_stmt (input_location
));
528 gfc_add_expr_to_block (&loopse
.pre
, tmp
);
529 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
530 gfc_array_index_type
,
531 count1
, gfc_index_one_node
);
532 gfc_add_modify (&loopse
.pre
, count1
, tmp
);
535 gfc_add_expr_to_block (&loopse
.pre
, loopse
.expr
);
537 gfc_add_block_to_block (&block
, &loopse
.pre
);
538 gfc_add_block_to_block (&block
, &loopse
.post
);
540 /* Finish up the loop block and the loop. */
541 gfc_add_expr_to_block (&body
, gfc_finish_block (&block
));
542 gfc_trans_scalarizing_loops (&loop
, &body
);
543 gfc_add_block_to_block (&se
.pre
, &loop
.pre
);
544 gfc_add_block_to_block (&se
.pre
, &loop
.post
);
545 gfc_add_block_to_block (&se
.pre
, &se
.post
);
546 gfc_cleanup_loop (&loop
);
549 return gfc_finish_block (&se
.pre
);
553 /* Translate the RETURN statement. */
556 gfc_trans_return (gfc_code
* code
)
564 /* If code->expr is not NULL, this return statement must appear
565 in a subroutine and current_fake_result_decl has already
568 result
= gfc_get_fake_result_decl (NULL
, 0);
572 "An alternate return at %L without a * dummy argument",
573 &code
->expr1
->where
);
574 return gfc_generate_return ();
577 /* Start a new block for this statement. */
578 gfc_init_se (&se
, NULL
);
579 gfc_start_block (&se
.pre
);
581 gfc_conv_expr (&se
, code
->expr1
);
583 /* Note that the actually returned expression is a simple value and
584 does not depend on any pointers or such; thus we can clean-up with
585 se.post before returning. */
586 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
, TREE_TYPE (result
),
587 result
, fold_convert (TREE_TYPE (result
),
589 gfc_add_expr_to_block (&se
.pre
, tmp
);
590 gfc_add_block_to_block (&se
.pre
, &se
.post
);
592 tmp
= gfc_generate_return ();
593 gfc_add_expr_to_block (&se
.pre
, tmp
);
594 return gfc_finish_block (&se
.pre
);
597 return gfc_generate_return ();
601 /* Translate the PAUSE statement. We have to translate this statement
602 to a runtime library call. */
605 gfc_trans_pause (gfc_code
* code
)
607 tree gfc_int8_type_node
= gfc_get_int_type (8);
611 /* Start a new block for this statement. */
612 gfc_init_se (&se
, NULL
);
613 gfc_start_block (&se
.pre
);
616 if (code
->expr1
== NULL
)
618 tmp
= build_int_cst (size_type_node
, 0);
619 tmp
= build_call_expr_loc (input_location
,
620 gfor_fndecl_pause_string
, 2,
621 build_int_cst (pchar_type_node
, 0), tmp
);
623 else if (code
->expr1
->ts
.type
== BT_INTEGER
)
625 gfc_conv_expr (&se
, code
->expr1
);
626 tmp
= build_call_expr_loc (input_location
,
627 gfor_fndecl_pause_numeric
, 1,
628 fold_convert (gfc_int8_type_node
, se
.expr
));
632 gfc_conv_expr_reference (&se
, code
->expr1
);
633 tmp
= build_call_expr_loc (input_location
,
634 gfor_fndecl_pause_string
, 2,
635 se
.expr
, fold_convert (size_type_node
,
639 gfc_add_expr_to_block (&se
.pre
, tmp
);
641 gfc_add_block_to_block (&se
.pre
, &se
.post
);
643 return gfc_finish_block (&se
.pre
);
647 /* Translate the STOP statement. We have to translate this statement
648 to a runtime library call. */
651 gfc_trans_stop (gfc_code
*code
, bool error_stop
)
657 /* Start a new block for this statement. */
658 gfc_init_se (&se
, NULL
);
659 gfc_start_block (&se
.pre
);
663 gfc_conv_expr_val (&se
, code
->expr2
);
664 quiet
= fold_convert (boolean_type_node
, se
.expr
);
667 quiet
= boolean_false_node
;
669 if (code
->expr1
== NULL
)
671 tmp
= build_int_cst (size_type_node
, 0);
672 tmp
= build_call_expr_loc (input_location
,
674 ? (flag_coarray
== GFC_FCOARRAY_LIB
675 ? gfor_fndecl_caf_error_stop_str
676 : gfor_fndecl_error_stop_string
)
677 : (flag_coarray
== GFC_FCOARRAY_LIB
678 ? gfor_fndecl_caf_stop_str
679 : gfor_fndecl_stop_string
),
680 3, build_int_cst (pchar_type_node
, 0), tmp
,
683 else if (code
->expr1
->ts
.type
== BT_INTEGER
)
685 gfc_conv_expr (&se
, code
->expr1
);
686 tmp
= build_call_expr_loc (input_location
,
688 ? (flag_coarray
== GFC_FCOARRAY_LIB
689 ? gfor_fndecl_caf_error_stop
690 : gfor_fndecl_error_stop_numeric
)
691 : (flag_coarray
== GFC_FCOARRAY_LIB
692 ? gfor_fndecl_caf_stop_numeric
693 : gfor_fndecl_stop_numeric
), 2,
694 fold_convert (integer_type_node
, se
.expr
),
699 gfc_conv_expr_reference (&se
, code
->expr1
);
700 tmp
= build_call_expr_loc (input_location
,
702 ? (flag_coarray
== GFC_FCOARRAY_LIB
703 ? gfor_fndecl_caf_error_stop_str
704 : gfor_fndecl_error_stop_string
)
705 : (flag_coarray
== GFC_FCOARRAY_LIB
706 ? gfor_fndecl_caf_stop_str
707 : gfor_fndecl_stop_string
),
708 3, se
.expr
, fold_convert (size_type_node
,
713 gfc_add_expr_to_block (&se
.pre
, tmp
);
715 gfc_add_block_to_block (&se
.pre
, &se
.post
);
717 return gfc_finish_block (&se
.pre
);
720 /* Translate the FAIL IMAGE statement. */
723 gfc_trans_fail_image (gfc_code
*code ATTRIBUTE_UNUSED
)
725 if (flag_coarray
== GFC_FCOARRAY_LIB
)
726 return build_call_expr_loc (input_location
,
727 gfor_fndecl_caf_fail_image
, 0);
730 const char *name
= gfc_get_string (PREFIX ("exit_i%d"), 4);
731 gfc_symbol
*exsym
= gfc_get_intrinsic_sub_symbol (name
);
732 tree tmp
= gfc_get_symbol_decl (exsym
);
733 return build_call_expr_loc (input_location
, tmp
, 1, integer_zero_node
);
737 /* Translate the FORM TEAM statement. */
740 gfc_trans_form_team (gfc_code
*code
)
742 if (flag_coarray
== GFC_FCOARRAY_LIB
)
745 gfc_se argse1
, argse2
;
746 tree team_id
, team_type
, tmp
;
748 gfc_init_se (&se
, NULL
);
749 gfc_init_se (&argse1
, NULL
);
750 gfc_init_se (&argse2
, NULL
);
751 gfc_start_block (&se
.pre
);
753 gfc_conv_expr_val (&argse1
, code
->expr1
);
754 gfc_conv_expr_val (&argse2
, code
->expr2
);
755 team_id
= fold_convert (integer_type_node
, argse1
.expr
);
756 team_type
= gfc_build_addr_expr (ppvoid_type_node
, argse2
.expr
);
758 gfc_add_block_to_block (&se
.pre
, &argse1
.pre
);
759 gfc_add_block_to_block (&se
.pre
, &argse2
.pre
);
760 tmp
= build_call_expr_loc (input_location
,
761 gfor_fndecl_caf_form_team
, 3,
763 build_int_cst (integer_type_node
, 0));
764 gfc_add_expr_to_block (&se
.pre
, tmp
);
765 gfc_add_block_to_block (&se
.pre
, &argse1
.post
);
766 gfc_add_block_to_block (&se
.pre
, &argse2
.post
);
767 return gfc_finish_block (&se
.pre
);
771 const char *name
= gfc_get_string (PREFIX ("exit_i%d"), 4);
772 gfc_symbol
*exsym
= gfc_get_intrinsic_sub_symbol (name
);
773 tree tmp
= gfc_get_symbol_decl (exsym
);
774 return build_call_expr_loc (input_location
, tmp
, 1, integer_zero_node
);
778 /* Translate the CHANGE TEAM statement. */
781 gfc_trans_change_team (gfc_code
*code
)
783 if (flag_coarray
== GFC_FCOARRAY_LIB
)
788 gfc_init_se (&argse
, NULL
);
789 gfc_conv_expr_val (&argse
, code
->expr1
);
790 team_type
= gfc_build_addr_expr (ppvoid_type_node
, argse
.expr
);
792 tmp
= build_call_expr_loc (input_location
,
793 gfor_fndecl_caf_change_team
, 2, team_type
,
794 build_int_cst (integer_type_node
, 0));
795 gfc_add_expr_to_block (&argse
.pre
, tmp
);
796 gfc_add_block_to_block (&argse
.pre
, &argse
.post
);
797 return gfc_finish_block (&argse
.pre
);
801 const char *name
= gfc_get_string (PREFIX ("exit_i%d"), 4);
802 gfc_symbol
*exsym
= gfc_get_intrinsic_sub_symbol (name
);
803 tree tmp
= gfc_get_symbol_decl (exsym
);
804 return build_call_expr_loc (input_location
, tmp
, 1, integer_zero_node
);
808 /* Translate the END TEAM statement. */
811 gfc_trans_end_team (gfc_code
*code ATTRIBUTE_UNUSED
)
813 if (flag_coarray
== GFC_FCOARRAY_LIB
)
815 return build_call_expr_loc (input_location
,
816 gfor_fndecl_caf_end_team
, 1,
817 build_int_cst (pchar_type_node
, 0));
821 const char *name
= gfc_get_string (PREFIX ("exit_i%d"), 4);
822 gfc_symbol
*exsym
= gfc_get_intrinsic_sub_symbol (name
);
823 tree tmp
= gfc_get_symbol_decl (exsym
);
824 return build_call_expr_loc (input_location
, tmp
, 1, integer_zero_node
);
828 /* Translate the SYNC TEAM statement. */
831 gfc_trans_sync_team (gfc_code
*code
)
833 if (flag_coarray
== GFC_FCOARRAY_LIB
)
838 gfc_init_se (&argse
, NULL
);
839 gfc_conv_expr_val (&argse
, code
->expr1
);
840 team_type
= gfc_build_addr_expr (ppvoid_type_node
, argse
.expr
);
842 tmp
= build_call_expr_loc (input_location
,
843 gfor_fndecl_caf_sync_team
, 2,
845 build_int_cst (integer_type_node
, 0));
846 gfc_add_expr_to_block (&argse
.pre
, tmp
);
847 gfc_add_block_to_block (&argse
.pre
, &argse
.post
);
848 return gfc_finish_block (&argse
.pre
);
852 const char *name
= gfc_get_string (PREFIX ("exit_i%d"), 4);
853 gfc_symbol
*exsym
= gfc_get_intrinsic_sub_symbol (name
);
854 tree tmp
= gfc_get_symbol_decl (exsym
);
855 return build_call_expr_loc (input_location
, tmp
, 1, integer_zero_node
);
860 gfc_trans_lock_unlock (gfc_code
*code
, gfc_exec_op op
)
863 tree stat
= NULL_TREE
, stat2
= NULL_TREE
;
864 tree lock_acquired
= NULL_TREE
, lock_acquired2
= NULL_TREE
;
866 /* Short cut: For single images without STAT= or LOCK_ACQUIRED
867 return early. (ERRMSG= is always untouched for -fcoarray=single.) */
868 if (!code
->expr2
&& !code
->expr4
&& flag_coarray
!= GFC_FCOARRAY_LIB
)
873 gcc_assert (code
->expr2
->expr_type
== EXPR_VARIABLE
);
874 gfc_init_se (&argse
, NULL
);
875 gfc_conv_expr_val (&argse
, code
->expr2
);
878 else if (flag_coarray
== GFC_FCOARRAY_LIB
)
879 stat
= null_pointer_node
;
883 gcc_assert (code
->expr4
->expr_type
== EXPR_VARIABLE
);
884 gfc_init_se (&argse
, NULL
);
885 gfc_conv_expr_val (&argse
, code
->expr4
);
886 lock_acquired
= argse
.expr
;
888 else if (flag_coarray
== GFC_FCOARRAY_LIB
)
889 lock_acquired
= null_pointer_node
;
891 gfc_start_block (&se
.pre
);
892 if (flag_coarray
== GFC_FCOARRAY_LIB
)
894 tree tmp
, token
, image_index
, errmsg
, errmsg_len
;
895 tree index
= build_zero_cst (gfc_array_index_type
);
896 tree caf_decl
= gfc_get_tree_for_caf_expr (code
->expr1
);
898 if (code
->expr1
->symtree
->n
.sym
->ts
.type
!= BT_DERIVED
899 || code
->expr1
->symtree
->n
.sym
->ts
.u
.derived
->from_intmod
900 != INTMOD_ISO_FORTRAN_ENV
901 || code
->expr1
->symtree
->n
.sym
->ts
.u
.derived
->intmod_sym_id
902 != ISOFORTRAN_LOCK_TYPE
)
904 gfc_error ("Sorry, the lock component of derived type at %L is not "
905 "yet supported", &code
->expr1
->where
);
909 gfc_get_caf_token_offset (&se
, &token
, NULL
, caf_decl
, NULL_TREE
,
912 if (gfc_is_coindexed (code
->expr1
))
913 image_index
= gfc_caf_get_image_index (&se
.pre
, code
->expr1
, caf_decl
);
915 image_index
= integer_zero_node
;
917 /* For arrays, obtain the array index. */
918 if (gfc_expr_attr (code
->expr1
).dimension
)
920 tree desc
, tmp
, extent
, lbound
, ubound
;
921 gfc_array_ref
*ar
, ar2
;
924 /* TODO: Extend this, once DT components are supported. */
925 ar
= &code
->expr1
->ref
->u
.ar
;
927 memset (ar
, '\0', sizeof (*ar
));
931 gfc_init_se (&argse
, NULL
);
932 argse
.descriptor_only
= 1;
933 gfc_conv_expr_descriptor (&argse
, code
->expr1
);
934 gfc_add_block_to_block (&se
.pre
, &argse
.pre
);
938 extent
= build_one_cst (gfc_array_index_type
);
939 for (i
= 0; i
< ar
->dimen
; i
++)
941 gfc_init_se (&argse
, NULL
);
942 gfc_conv_expr_type (&argse
, ar
->start
[i
], gfc_array_index_type
);
943 gfc_add_block_to_block (&argse
.pre
, &argse
.pre
);
944 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[i
]);
945 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
946 TREE_TYPE (lbound
), argse
.expr
, lbound
);
947 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
948 TREE_TYPE (tmp
), extent
, tmp
);
949 index
= fold_build2_loc (input_location
, PLUS_EXPR
,
950 TREE_TYPE (tmp
), index
, tmp
);
951 if (i
< ar
->dimen
- 1)
953 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[i
]);
954 tmp
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
955 extent
= fold_build2_loc (input_location
, MULT_EXPR
,
956 TREE_TYPE (tmp
), extent
, tmp
);
964 gfc_init_se (&argse
, NULL
);
965 argse
.want_pointer
= 1;
966 gfc_conv_expr (&argse
, code
->expr3
);
967 gfc_add_block_to_block (&se
.pre
, &argse
.pre
);
969 errmsg_len
= fold_convert (size_type_node
, argse
.string_length
);
973 errmsg
= null_pointer_node
;
974 errmsg_len
= build_zero_cst (size_type_node
);
977 if (stat
!= null_pointer_node
&& TREE_TYPE (stat
) != integer_type_node
)
980 stat
= gfc_create_var (integer_type_node
, "stat");
983 if (lock_acquired
!= null_pointer_node
984 && TREE_TYPE (lock_acquired
) != integer_type_node
)
986 lock_acquired2
= lock_acquired
;
987 lock_acquired
= gfc_create_var (integer_type_node
, "acquired");
990 index
= fold_convert (size_type_node
, index
);
992 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_lock
, 7,
993 token
, index
, image_index
,
994 lock_acquired
!= null_pointer_node
995 ? gfc_build_addr_expr (NULL
, lock_acquired
)
997 stat
!= null_pointer_node
998 ? gfc_build_addr_expr (NULL
, stat
) : stat
,
1001 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_unlock
, 6,
1002 token
, index
, image_index
,
1003 stat
!= null_pointer_node
1004 ? gfc_build_addr_expr (NULL
, stat
) : stat
,
1005 errmsg
, errmsg_len
);
1006 gfc_add_expr_to_block (&se
.pre
, tmp
);
1008 /* It guarantees memory consistency within the same segment */
1009 tmp
= gfc_build_string_const (strlen ("memory")+1, "memory"),
1010 tmp
= build5_loc (input_location
, ASM_EXPR
, void_type_node
,
1011 gfc_build_string_const (1, ""), NULL_TREE
, NULL_TREE
,
1012 tree_cons (NULL_TREE
, tmp
, NULL_TREE
), NULL_TREE
);
1013 ASM_VOLATILE_P (tmp
) = 1;
1015 gfc_add_expr_to_block (&se
.pre
, tmp
);
1017 if (stat2
!= NULL_TREE
)
1018 gfc_add_modify (&se
.pre
, stat2
,
1019 fold_convert (TREE_TYPE (stat2
), stat
));
1021 if (lock_acquired2
!= NULL_TREE
)
1022 gfc_add_modify (&se
.pre
, lock_acquired2
,
1023 fold_convert (TREE_TYPE (lock_acquired2
),
1026 return gfc_finish_block (&se
.pre
);
1029 if (stat
!= NULL_TREE
)
1030 gfc_add_modify (&se
.pre
, stat
, build_int_cst (TREE_TYPE (stat
), 0));
1032 if (lock_acquired
!= NULL_TREE
)
1033 gfc_add_modify (&se
.pre
, lock_acquired
,
1034 fold_convert (TREE_TYPE (lock_acquired
),
1035 boolean_true_node
));
1037 return gfc_finish_block (&se
.pre
);
1041 gfc_trans_event_post_wait (gfc_code
*code
, gfc_exec_op op
)
1044 tree stat
= NULL_TREE
, stat2
= NULL_TREE
;
1045 tree until_count
= NULL_TREE
;
1049 gcc_assert (code
->expr2
->expr_type
== EXPR_VARIABLE
);
1050 gfc_init_se (&argse
, NULL
);
1051 gfc_conv_expr_val (&argse
, code
->expr2
);
1054 else if (flag_coarray
== GFC_FCOARRAY_LIB
)
1055 stat
= null_pointer_node
;
1059 gfc_init_se (&argse
, NULL
);
1060 gfc_conv_expr_val (&argse
, code
->expr4
);
1061 until_count
= fold_convert (integer_type_node
, argse
.expr
);
1064 until_count
= integer_one_node
;
1066 if (flag_coarray
!= GFC_FCOARRAY_LIB
)
1068 gfc_start_block (&se
.pre
);
1069 gfc_init_se (&argse
, NULL
);
1070 gfc_conv_expr_val (&argse
, code
->expr1
);
1072 if (op
== EXEC_EVENT_POST
)
1073 gfc_add_modify (&se
.pre
, argse
.expr
,
1074 fold_build2_loc (input_location
, PLUS_EXPR
,
1075 TREE_TYPE (argse
.expr
), argse
.expr
,
1076 build_int_cst (TREE_TYPE (argse
.expr
), 1)));
1078 gfc_add_modify (&se
.pre
, argse
.expr
,
1079 fold_build2_loc (input_location
, MINUS_EXPR
,
1080 TREE_TYPE (argse
.expr
), argse
.expr
,
1081 fold_convert (TREE_TYPE (argse
.expr
),
1083 if (stat
!= NULL_TREE
)
1084 gfc_add_modify (&se
.pre
, stat
, build_int_cst (TREE_TYPE (stat
), 0));
1086 return gfc_finish_block (&se
.pre
);
1089 gfc_start_block (&se
.pre
);
1090 tree tmp
, token
, image_index
, errmsg
, errmsg_len
;
1091 tree index
= build_zero_cst (gfc_array_index_type
);
1092 tree caf_decl
= gfc_get_tree_for_caf_expr (code
->expr1
);
1094 if (code
->expr1
->symtree
->n
.sym
->ts
.type
!= BT_DERIVED
1095 || code
->expr1
->symtree
->n
.sym
->ts
.u
.derived
->from_intmod
1096 != INTMOD_ISO_FORTRAN_ENV
1097 || code
->expr1
->symtree
->n
.sym
->ts
.u
.derived
->intmod_sym_id
1098 != ISOFORTRAN_EVENT_TYPE
)
1100 gfc_error ("Sorry, the event component of derived type at %L is not "
1101 "yet supported", &code
->expr1
->where
);
1105 gfc_init_se (&argse
, NULL
);
1106 gfc_get_caf_token_offset (&argse
, &token
, NULL
, caf_decl
, NULL_TREE
,
1108 gfc_add_block_to_block (&se
.pre
, &argse
.pre
);
1110 if (gfc_is_coindexed (code
->expr1
))
1111 image_index
= gfc_caf_get_image_index (&se
.pre
, code
->expr1
, caf_decl
);
1113 image_index
= integer_zero_node
;
1115 /* For arrays, obtain the array index. */
1116 if (gfc_expr_attr (code
->expr1
).dimension
)
1118 tree desc
, tmp
, extent
, lbound
, ubound
;
1119 gfc_array_ref
*ar
, ar2
;
1122 /* TODO: Extend this, once DT components are supported. */
1123 ar
= &code
->expr1
->ref
->u
.ar
;
1125 memset (ar
, '\0', sizeof (*ar
));
1129 gfc_init_se (&argse
, NULL
);
1130 argse
.descriptor_only
= 1;
1131 gfc_conv_expr_descriptor (&argse
, code
->expr1
);
1132 gfc_add_block_to_block (&se
.pre
, &argse
.pre
);
1136 extent
= build_one_cst (gfc_array_index_type
);
1137 for (i
= 0; i
< ar
->dimen
; i
++)
1139 gfc_init_se (&argse
, NULL
);
1140 gfc_conv_expr_type (&argse
, ar
->start
[i
], gfc_array_index_type
);
1141 gfc_add_block_to_block (&argse
.pre
, &argse
.pre
);
1142 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[i
]);
1143 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
1144 TREE_TYPE (lbound
), argse
.expr
, lbound
);
1145 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
1146 TREE_TYPE (tmp
), extent
, tmp
);
1147 index
= fold_build2_loc (input_location
, PLUS_EXPR
,
1148 TREE_TYPE (tmp
), index
, tmp
);
1149 if (i
< ar
->dimen
- 1)
1151 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[i
]);
1152 tmp
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
1153 extent
= fold_build2_loc (input_location
, MULT_EXPR
,
1154 TREE_TYPE (tmp
), extent
, tmp
);
1162 gfc_init_se (&argse
, NULL
);
1163 argse
.want_pointer
= 1;
1164 gfc_conv_expr (&argse
, code
->expr3
);
1165 gfc_add_block_to_block (&se
.pre
, &argse
.pre
);
1166 errmsg
= argse
.expr
;
1167 errmsg_len
= fold_convert (size_type_node
, argse
.string_length
);
1171 errmsg
= null_pointer_node
;
1172 errmsg_len
= build_zero_cst (size_type_node
);
1175 if (stat
!= null_pointer_node
&& TREE_TYPE (stat
) != integer_type_node
)
1178 stat
= gfc_create_var (integer_type_node
, "stat");
1181 index
= fold_convert (size_type_node
, index
);
1182 if (op
== EXEC_EVENT_POST
)
1183 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_event_post
, 6,
1184 token
, index
, image_index
,
1185 stat
!= null_pointer_node
1186 ? gfc_build_addr_expr (NULL
, stat
) : stat
,
1187 errmsg
, errmsg_len
);
1189 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_event_wait
, 6,
1190 token
, index
, until_count
,
1191 stat
!= null_pointer_node
1192 ? gfc_build_addr_expr (NULL
, stat
) : stat
,
1193 errmsg
, errmsg_len
);
1194 gfc_add_expr_to_block (&se
.pre
, tmp
);
1196 /* It guarantees memory consistency within the same segment */
1197 tmp
= gfc_build_string_const (strlen ("memory")+1, "memory"),
1198 tmp
= build5_loc (input_location
, ASM_EXPR
, void_type_node
,
1199 gfc_build_string_const (1, ""), NULL_TREE
, NULL_TREE
,
1200 tree_cons (NULL_TREE
, tmp
, NULL_TREE
), NULL_TREE
);
1201 ASM_VOLATILE_P (tmp
) = 1;
1202 gfc_add_expr_to_block (&se
.pre
, tmp
);
1204 if (stat2
!= NULL_TREE
)
1205 gfc_add_modify (&se
.pre
, stat2
, fold_convert (TREE_TYPE (stat2
), stat
));
1207 return gfc_finish_block (&se
.pre
);
1211 gfc_trans_sync (gfc_code
*code
, gfc_exec_op type
)
1215 tree images
= NULL_TREE
, stat
= NULL_TREE
,
1216 errmsg
= NULL_TREE
, errmsglen
= NULL_TREE
;
1218 /* Short cut: For single images without bound checking or without STAT=,
1219 return early. (ERRMSG= is always untouched for -fcoarray=single.) */
1220 if (!code
->expr2
&& !(gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
1221 && flag_coarray
!= GFC_FCOARRAY_LIB
)
1224 gfc_init_se (&se
, NULL
);
1225 gfc_start_block (&se
.pre
);
1227 if (code
->expr1
&& code
->expr1
->rank
== 0)
1229 gfc_init_se (&argse
, NULL
);
1230 gfc_conv_expr_val (&argse
, code
->expr1
);
1231 images
= argse
.expr
;
1236 gcc_assert (code
->expr2
->expr_type
== EXPR_VARIABLE
1237 || code
->expr2
->expr_type
== EXPR_FUNCTION
);
1238 gfc_init_se (&argse
, NULL
);
1239 gfc_conv_expr_val (&argse
, code
->expr2
);
1243 stat
= null_pointer_node
;
1245 if (code
->expr3
&& flag_coarray
== GFC_FCOARRAY_LIB
)
1247 gcc_assert (code
->expr3
->expr_type
== EXPR_VARIABLE
1248 || code
->expr3
->expr_type
== EXPR_FUNCTION
);
1249 gfc_init_se (&argse
, NULL
);
1250 argse
.want_pointer
= 1;
1251 gfc_conv_expr (&argse
, code
->expr3
);
1252 gfc_conv_string_parameter (&argse
);
1253 errmsg
= gfc_build_addr_expr (NULL
, argse
.expr
);
1254 errmsglen
= fold_convert (size_type_node
, argse
.string_length
);
1256 else if (flag_coarray
== GFC_FCOARRAY_LIB
)
1258 errmsg
= null_pointer_node
;
1259 errmsglen
= build_int_cst (size_type_node
, 0);
1262 /* Check SYNC IMAGES(imageset) for valid image index.
1263 FIXME: Add a check for image-set arrays. */
1264 if (code
->expr1
&& (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
1265 && code
->expr1
->rank
== 0)
1267 tree images2
= fold_convert (integer_type_node
, images
);
1269 if (flag_coarray
!= GFC_FCOARRAY_LIB
)
1270 cond
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
1271 images
, build_int_cst (TREE_TYPE (images
), 1));
1275 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_num_images
,
1276 2, integer_zero_node
,
1277 build_int_cst (integer_type_node
, -1));
1278 cond
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
,
1280 cond2
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
1282 build_int_cst (TREE_TYPE (images
), 1));
1283 cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
1284 logical_type_node
, cond
, cond2
);
1286 gfc_trans_runtime_check (true, false, cond
, &se
.pre
,
1287 &code
->expr1
->where
, "Invalid image number "
1288 "%d in SYNC IMAGES", images2
);
1291 /* Per F2008, 8.5.1, a SYNC MEMORY is implied by calling the
1292 image control statements SYNC IMAGES and SYNC ALL. */
1293 if (flag_coarray
== GFC_FCOARRAY_LIB
)
1295 tmp
= gfc_build_string_const (strlen ("memory")+1, "memory"),
1296 tmp
= build5_loc (input_location
, ASM_EXPR
, void_type_node
,
1297 gfc_build_string_const (1, ""), NULL_TREE
, NULL_TREE
,
1298 tree_cons (NULL_TREE
, tmp
, NULL_TREE
), NULL_TREE
);
1299 ASM_VOLATILE_P (tmp
) = 1;
1300 gfc_add_expr_to_block (&se
.pre
, tmp
);
1303 if (flag_coarray
!= GFC_FCOARRAY_LIB
)
1305 /* Set STAT to zero. */
1307 gfc_add_modify (&se
.pre
, stat
, build_int_cst (TREE_TYPE (stat
), 0));
1309 else if (type
== EXEC_SYNC_ALL
|| type
== EXEC_SYNC_MEMORY
)
1311 /* SYNC ALL => stat == null_pointer_node
1312 SYNC ALL(stat=s) => stat has an integer type
1314 If "stat" has the wrong integer type, use a temp variable of
1315 the right type and later cast the result back into "stat". */
1316 if (stat
== null_pointer_node
|| TREE_TYPE (stat
) == integer_type_node
)
1318 if (TREE_TYPE (stat
) == integer_type_node
)
1319 stat
= gfc_build_addr_expr (NULL
, stat
);
1321 if(type
== EXEC_SYNC_MEMORY
)
1322 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_sync_memory
,
1323 3, stat
, errmsg
, errmsglen
);
1325 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_sync_all
,
1326 3, stat
, errmsg
, errmsglen
);
1328 gfc_add_expr_to_block (&se
.pre
, tmp
);
1332 tree tmp_stat
= gfc_create_var (integer_type_node
, "stat");
1334 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_sync_all
,
1335 3, gfc_build_addr_expr (NULL
, tmp_stat
),
1337 gfc_add_expr_to_block (&se
.pre
, tmp
);
1339 gfc_add_modify (&se
.pre
, stat
,
1340 fold_convert (TREE_TYPE (stat
), tmp_stat
));
1347 gcc_assert (type
== EXEC_SYNC_IMAGES
);
1351 len
= build_int_cst (integer_type_node
, -1);
1352 images
= null_pointer_node
;
1354 else if (code
->expr1
->rank
== 0)
1356 len
= build_int_cst (integer_type_node
, 1);
1357 images
= gfc_build_addr_expr (NULL_TREE
, images
);
1362 if (code
->expr1
->ts
.kind
!= gfc_c_int_kind
)
1363 gfc_fatal_error ("Sorry, only support for integer kind %d "
1364 "implemented for image-set at %L",
1365 gfc_c_int_kind
, &code
->expr1
->where
);
1367 gfc_conv_array_parameter (&se
, code
->expr1
, true, NULL
, NULL
, &len
);
1370 tmp
= gfc_typenode_for_spec (&code
->expr1
->ts
);
1371 if (GFC_ARRAY_TYPE_P (tmp
) || GFC_DESCRIPTOR_TYPE_P (tmp
))
1372 tmp
= gfc_get_element_type (tmp
);
1374 len
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
,
1375 TREE_TYPE (len
), len
,
1376 fold_convert (TREE_TYPE (len
),
1377 TYPE_SIZE_UNIT (tmp
)));
1378 len
= fold_convert (integer_type_node
, len
);
1381 /* SYNC IMAGES(imgs) => stat == null_pointer_node
1382 SYNC IMAGES(imgs,stat=s) => stat has an integer type
1384 If "stat" has the wrong integer type, use a temp variable of
1385 the right type and later cast the result back into "stat". */
1386 if (stat
== null_pointer_node
|| TREE_TYPE (stat
) == integer_type_node
)
1388 if (TREE_TYPE (stat
) == integer_type_node
)
1389 stat
= gfc_build_addr_expr (NULL
, stat
);
1391 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_sync_images
,
1392 5, fold_convert (integer_type_node
, len
),
1393 images
, stat
, errmsg
, errmsglen
);
1394 gfc_add_expr_to_block (&se
.pre
, tmp
);
1398 tree tmp_stat
= gfc_create_var (integer_type_node
, "stat");
1400 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_sync_images
,
1401 5, fold_convert (integer_type_node
, len
),
1402 images
, gfc_build_addr_expr (NULL
, tmp_stat
),
1404 gfc_add_expr_to_block (&se
.pre
, tmp
);
1406 gfc_add_modify (&se
.pre
, stat
,
1407 fold_convert (TREE_TYPE (stat
), tmp_stat
));
1411 return gfc_finish_block (&se
.pre
);
1415 /* Generate GENERIC for the IF construct. This function also deals with
1416 the simple IF statement, because the front end translates the IF
1417 statement into an IF construct.
1449 where COND_S is the simplified version of the predicate. PRE_COND_S
1450 are the pre side-effects produced by the translation of the
1452 We need to build the chain recursively otherwise we run into
1453 problems with folding incomplete statements. */
1456 gfc_trans_if_1 (gfc_code
* code
)
1459 tree stmt
, elsestmt
;
1463 /* Check for an unconditional ELSE clause. */
1465 return gfc_trans_code (code
->next
);
1467 /* Initialize a statement builder for each block. Puts in NULL_TREEs. */
1468 gfc_init_se (&if_se
, NULL
);
1469 gfc_start_block (&if_se
.pre
);
1471 /* Calculate the IF condition expression. */
1472 if (code
->expr1
->where
.lb
)
1474 gfc_save_backend_locus (&saved_loc
);
1475 gfc_set_backend_locus (&code
->expr1
->where
);
1478 gfc_conv_expr_val (&if_se
, code
->expr1
);
1480 if (code
->expr1
->where
.lb
)
1481 gfc_restore_backend_locus (&saved_loc
);
1483 /* Translate the THEN clause. */
1484 stmt
= gfc_trans_code (code
->next
);
1486 /* Translate the ELSE clause. */
1488 elsestmt
= gfc_trans_if_1 (code
->block
);
1490 elsestmt
= build_empty_stmt (input_location
);
1492 /* Build the condition expression and add it to the condition block. */
1493 loc
= code
->expr1
->where
.lb
? gfc_get_location (&code
->expr1
->where
)
1495 stmt
= fold_build3_loc (loc
, COND_EXPR
, void_type_node
, if_se
.expr
, stmt
,
1498 gfc_add_expr_to_block (&if_se
.pre
, stmt
);
1500 /* Finish off this statement. */
1501 return gfc_finish_block (&if_se
.pre
);
1505 gfc_trans_if (gfc_code
* code
)
1510 /* Create exit label so it is available for trans'ing the body code. */
1511 exit_label
= gfc_build_label_decl (NULL_TREE
);
1512 code
->exit_label
= exit_label
;
1514 /* Translate the actual code in code->block. */
1515 gfc_init_block (&body
);
1516 gfc_add_expr_to_block (&body
, gfc_trans_if_1 (code
->block
));
1518 /* Add exit label. */
1519 gfc_add_expr_to_block (&body
, build1_v (LABEL_EXPR
, exit_label
));
1521 return gfc_finish_block (&body
);
1525 /* Translate an arithmetic IF expression.
1527 IF (cond) label1, label2, label3 translates to
1539 An optimized version can be generated in case of equal labels.
1540 E.g., if label1 is equal to label2, we can translate it to
1549 gfc_trans_arithmetic_if (gfc_code
* code
)
1557 /* Start a new block. */
1558 gfc_init_se (&se
, NULL
);
1559 gfc_start_block (&se
.pre
);
1561 /* Pre-evaluate COND. */
1562 gfc_conv_expr_val (&se
, code
->expr1
);
1563 se
.expr
= gfc_evaluate_now (se
.expr
, &se
.pre
);
1565 /* Build something to compare with. */
1566 zero
= gfc_build_const (TREE_TYPE (se
.expr
), integer_zero_node
);
1568 if (code
->label1
->value
!= code
->label2
->value
)
1570 /* If (cond < 0) take branch1 else take branch2.
1571 First build jumps to the COND .LT. 0 and the COND .EQ. 0 cases. */
1572 branch1
= build1_v (GOTO_EXPR
, gfc_get_label_decl (code
->label1
));
1573 branch2
= build1_v (GOTO_EXPR
, gfc_get_label_decl (code
->label2
));
1575 if (code
->label1
->value
!= code
->label3
->value
)
1576 tmp
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
1579 tmp
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
1582 branch1
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
1583 tmp
, branch1
, branch2
);
1586 branch1
= build1_v (GOTO_EXPR
, gfc_get_label_decl (code
->label1
));
1588 if (code
->label1
->value
!= code
->label3
->value
1589 && code
->label2
->value
!= code
->label3
->value
)
1591 /* if (cond <= 0) take branch1 else take branch2. */
1592 branch2
= build1_v (GOTO_EXPR
, gfc_get_label_decl (code
->label3
));
1593 tmp
= fold_build2_loc (input_location
, LE_EXPR
, logical_type_node
,
1595 branch1
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
1596 tmp
, branch1
, branch2
);
1599 /* Append the COND_EXPR to the evaluation of COND, and return. */
1600 gfc_add_expr_to_block (&se
.pre
, branch1
);
1601 return gfc_finish_block (&se
.pre
);
1605 /* Translate a CRITICAL block. */
1607 gfc_trans_critical (gfc_code
*code
)
1610 tree tmp
, token
= NULL_TREE
;
1612 gfc_start_block (&block
);
1614 if (flag_coarray
== GFC_FCOARRAY_LIB
)
1616 tree zero_size
= build_zero_cst (size_type_node
);
1617 token
= gfc_get_symbol_decl (code
->resolved_sym
);
1618 token
= GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (token
));
1619 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_lock
, 7,
1620 token
, zero_size
, integer_one_node
,
1621 null_pointer_node
, null_pointer_node
,
1622 null_pointer_node
, zero_size
);
1623 gfc_add_expr_to_block (&block
, tmp
);
1625 /* It guarantees memory consistency within the same segment */
1626 tmp
= gfc_build_string_const (strlen ("memory")+1, "memory"),
1627 tmp
= build5_loc (input_location
, ASM_EXPR
, void_type_node
,
1628 gfc_build_string_const (1, ""),
1629 NULL_TREE
, NULL_TREE
,
1630 tree_cons (NULL_TREE
, tmp
, NULL_TREE
),
1632 ASM_VOLATILE_P (tmp
) = 1;
1634 gfc_add_expr_to_block (&block
, tmp
);
1637 tmp
= gfc_trans_code (code
->block
->next
);
1638 gfc_add_expr_to_block (&block
, tmp
);
1640 if (flag_coarray
== GFC_FCOARRAY_LIB
)
1642 tree zero_size
= build_zero_cst (size_type_node
);
1643 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_unlock
, 6,
1644 token
, zero_size
, integer_one_node
,
1645 null_pointer_node
, null_pointer_node
,
1647 gfc_add_expr_to_block (&block
, tmp
);
1649 /* It guarantees memory consistency within the same segment */
1650 tmp
= gfc_build_string_const (strlen ("memory")+1, "memory"),
1651 tmp
= build5_loc (input_location
, ASM_EXPR
, void_type_node
,
1652 gfc_build_string_const (1, ""),
1653 NULL_TREE
, NULL_TREE
,
1654 tree_cons (NULL_TREE
, tmp
, NULL_TREE
),
1656 ASM_VOLATILE_P (tmp
) = 1;
1658 gfc_add_expr_to_block (&block
, tmp
);
1661 return gfc_finish_block (&block
);
1665 /* Return true, when the class has a _len component. */
1668 class_has_len_component (gfc_symbol
*sym
)
1670 gfc_component
*comp
= sym
->ts
.u
.derived
->components
;
1673 if (strcmp (comp
->name
, "_len") == 0)
1682 copy_descriptor (stmtblock_t
*block
, tree dst
, tree src
, int rank
)
1691 offset
= gfc_index_zero_node
;
1693 /* Use memcpy to copy the descriptor. The size is the minimum of
1694 the sizes of 'src' and 'dst'. This avoids a non-trivial conversion. */
1695 tmp
= TYPE_SIZE_UNIT (TREE_TYPE (src
));
1696 tmp2
= TYPE_SIZE_UNIT (TREE_TYPE (dst
));
1697 size
= fold_build2_loc (input_location
, MIN_EXPR
,
1698 TREE_TYPE (tmp
), tmp
, tmp2
);
1699 tmp
= builtin_decl_explicit (BUILT_IN_MEMCPY
);
1700 tmp
= build_call_expr_loc (input_location
, tmp
, 3,
1701 gfc_build_addr_expr (NULL_TREE
, dst
),
1702 gfc_build_addr_expr (NULL_TREE
, src
),
1703 fold_convert (size_type_node
, size
));
1704 gfc_add_expr_to_block (block
, tmp
);
1706 /* Set the offset correctly. */
1707 for (n
= 0; n
< rank
; n
++)
1709 dim
= gfc_rank_cst
[n
];
1710 tmp
= gfc_conv_descriptor_lbound_get (src
, dim
);
1711 tmp2
= gfc_conv_descriptor_stride_get (src
, dim
);
1712 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, TREE_TYPE (tmp
),
1714 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
1715 TREE_TYPE (offset
), offset
, tmp
);
1716 offset
= gfc_evaluate_now (offset
, block
);
1719 gfc_conv_descriptor_offset_set (block
, dst
, offset
);
1723 /* Do proper initialization for ASSOCIATE names. */
1726 trans_associate_var (gfc_symbol
*sym
, gfc_wrapped_block
*block
)
1737 bool need_len_assign
;
1738 bool whole_array
= true;
1742 gcc_assert (sym
->assoc
);
1743 e
= sym
->assoc
->target
;
1745 class_target
= (e
->expr_type
== EXPR_VARIABLE
)
1746 && (gfc_is_class_scalar_expr (e
)
1747 || gfc_is_class_array_ref (e
, NULL
));
1749 unlimited
= UNLIMITED_POLY (e
);
1751 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
1752 if (ref
->type
== REF_ARRAY
1753 && ref
->u
.ar
.type
== AR_FULL
1756 whole_array
= false;
1760 /* Assignments to the string length need to be generated, when
1761 ( sym is a char array or
1762 sym has a _len component)
1763 and the associated expression is unlimited polymorphic, which is
1764 not (yet) correctly in 'unlimited', because for an already associated
1765 BT_DERIVED the u-poly flag is not set, i.e.,
1766 __tmp_CHARACTER_0_1 => w => arg
1767 ^ generated temp ^ from code, the w does not have the u-poly
1768 flag set, where UNLIMITED_POLY(e) expects it. */
1769 need_len_assign
= ((unlimited
|| (e
->ts
.type
== BT_DERIVED
1770 && e
->ts
.u
.derived
->attr
.unlimited_polymorphic
))
1771 && (sym
->ts
.type
== BT_CHARACTER
1772 || ((sym
->ts
.type
== BT_CLASS
|| sym
->ts
.type
== BT_DERIVED
)
1773 && class_has_len_component (sym
)))
1774 && !sym
->attr
.select_rank_temporary
);
1776 /* Do a `pointer assignment' with updated descriptor (or assign descriptor
1777 to array temporary) for arrays with either unknown shape or if associating
1778 to a variable. Select rank temporaries need somewhat different treatment
1779 to other associate names and case temporaries. This because the selector
1780 is assumed rank and so the offset in particular has to be changed. Also,
1781 the case temporaries carry both allocatable and target attributes if
1782 present in the selector. This means that an allocatation or change of
1783 association can occur and so has to be dealt with. */
1784 if (sym
->attr
.select_rank_temporary
)
1787 tree class_decl
= NULL_TREE
;
1791 sym2
= e
->symtree
->n
.sym
;
1792 gfc_init_se (&se
, NULL
);
1793 if (e
->ts
.type
== BT_CLASS
)
1795 /* Go straight to the class data. */
1796 if (sym2
->attr
.dummy
&& !sym2
->attr
.optional
)
1798 class_decl
= sym2
->backend_decl
;
1799 if (DECL_LANG_SPECIFIC (class_decl
)
1800 && GFC_DECL_SAVED_DESCRIPTOR (class_decl
))
1801 class_decl
= GFC_DECL_SAVED_DESCRIPTOR (class_decl
);
1802 if (POINTER_TYPE_P (TREE_TYPE (class_decl
)))
1803 class_decl
= build_fold_indirect_ref_loc (input_location
,
1805 gcc_assert (GFC_CLASS_TYPE_P (TREE_TYPE (class_decl
)));
1806 se
.expr
= gfc_class_data_get (class_decl
);
1810 class_decl
= sym2
->backend_decl
;
1811 gfc_conv_expr_descriptor (&se
, e
);
1812 if (POINTER_TYPE_P (TREE_TYPE (se
.expr
)))
1813 se
.expr
= build_fold_indirect_ref_loc (input_location
,
1817 if (CLASS_DATA (sym
)->as
&& CLASS_DATA (sym
)->as
->rank
> 0)
1818 rank
= CLASS_DATA (sym
)->as
->rank
;
1822 gfc_conv_expr_descriptor (&se
, e
);
1823 if (sym
->as
&& sym
->as
->rank
> 0)
1824 rank
= sym
->as
->rank
;
1827 desc
= sym
->backend_decl
;
1829 /* The SELECT TYPE mechanisms turn class temporaries into pointers, which
1830 point to the selector. */
1831 class_ptr
= class_decl
!= NULL_TREE
&& POINTER_TYPE_P (TREE_TYPE (desc
));
1834 tmp
= gfc_create_var (TREE_TYPE (TREE_TYPE (desc
)), "class");
1835 tmp
= gfc_build_addr_expr (NULL
, tmp
);
1836 gfc_add_modify (&se
.pre
, desc
, tmp
);
1838 tmp
= gfc_class_vptr_get (class_decl
);
1839 gfc_add_modify (&se
.pre
, gfc_class_vptr_get (desc
), tmp
);
1840 if (UNLIMITED_POLY (sym
))
1841 gfc_add_modify (&se
.pre
, gfc_class_len_get (desc
),
1842 gfc_class_len_get (class_decl
));
1844 desc
= gfc_class_data_get (desc
);
1847 /* SELECT RANK temporaries can carry the allocatable and pointer
1848 attributes so the selector descriptor must be copied in and
1851 copy_descriptor (&se
.pre
, desc
, se
.expr
, rank
);
1854 tmp
= gfc_conv_descriptor_data_get (se
.expr
);
1855 gfc_add_modify (&se
.pre
, desc
,
1856 fold_convert (TREE_TYPE (desc
), tmp
));
1859 /* Deal with associate_name => selector. Class associate names are
1860 treated in the same way as in SELECT TYPE. */
1861 sym2
= sym
->assoc
->target
->symtree
->n
.sym
;
1862 if (sym2
->assoc
&& sym
->assoc
->target
&& sym2
->ts
.type
!= BT_CLASS
)
1864 sym2
= sym2
->assoc
->target
->symtree
->n
.sym
;
1865 se
.expr
= sym2
->backend_decl
;
1867 if (POINTER_TYPE_P (TREE_TYPE (se
.expr
)))
1868 se
.expr
= build_fold_indirect_ref_loc (input_location
,
1872 /* There could have been reallocation. Copy descriptor back to the
1873 selector and update the offset. */
1874 if (sym
->attr
.allocatable
|| sym
->attr
.pointer
1875 || (sym
->ts
.type
== BT_CLASS
1876 && (CLASS_DATA (sym
)->attr
.allocatable
1877 || CLASS_DATA (sym
)->attr
.pointer
)))
1880 copy_descriptor (&se
.post
, se
.expr
, desc
, rank
);
1882 gfc_conv_descriptor_data_set (&se
.post
, se
.expr
, desc
);
1884 /* The dynamic type could have changed too. */
1885 if (sym
->ts
.type
== BT_CLASS
)
1887 tmp
= sym
->backend_decl
;
1889 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
1890 gfc_add_modify (&se
.post
, gfc_class_vptr_get (class_decl
),
1891 gfc_class_vptr_get (tmp
));
1892 if (UNLIMITED_POLY (sym
))
1893 gfc_add_modify (&se
.post
, gfc_class_len_get (class_decl
),
1894 gfc_class_len_get (tmp
));
1898 tmp
= gfc_finish_block (&se
.post
);
1900 gfc_add_init_cleanup (block
, gfc_finish_block (&se
.pre
), tmp
);
1902 /* Now all the other kinds of associate variable. */
1903 else if (sym
->attr
.dimension
&& !class_target
1904 && (sym
->as
->type
== AS_DEFERRED
|| sym
->assoc
->variable
))
1908 bool cst_array_ctor
;
1910 desc
= sym
->backend_decl
;
1911 cst_array_ctor
= e
->expr_type
== EXPR_ARRAY
1912 && gfc_constant_array_constructor_p (e
->value
.constructor
)
1913 && e
->ts
.type
!= BT_CHARACTER
;
1915 /* If association is to an expression, evaluate it and create temporary.
1916 Otherwise, get descriptor of target for pointer assignment. */
1917 gfc_init_se (&se
, NULL
);
1919 if (sym
->assoc
->variable
|| cst_array_ctor
)
1921 se
.direct_byref
= 1;
1924 GFC_DECL_PTR_ARRAY_P (sym
->backend_decl
) = 1;
1927 gfc_conv_expr_descriptor (&se
, e
);
1929 if (sym
->ts
.type
== BT_CHARACTER
1931 && !sym
->attr
.select_type_temporary
1932 && VAR_P (sym
->ts
.u
.cl
->backend_decl
)
1933 && se
.string_length
!= sym
->ts
.u
.cl
->backend_decl
)
1935 gfc_add_modify (&se
.pre
, sym
->ts
.u
.cl
->backend_decl
,
1936 fold_convert (TREE_TYPE (sym
->ts
.u
.cl
->backend_decl
),
1940 /* If we didn't already do the pointer assignment, set associate-name
1941 descriptor to the one generated for the temporary. */
1942 if ((!sym
->assoc
->variable
&& !cst_array_ctor
)
1948 gfc_add_modify (&se
.pre
, desc
, se
.expr
);
1950 /* The generated descriptor has lower bound zero (as array
1951 temporary), shift bounds so we get lower bounds of 1. */
1952 for (dim
= 0; dim
< e
->rank
; ++dim
)
1953 gfc_conv_shift_descriptor_lbound (&se
.pre
, desc
,
1954 dim
, gfc_index_one_node
);
1957 /* If this is a subreference array pointer associate name use the
1958 associate variable element size for the value of 'span'. */
1959 if (sym
->attr
.subref_array_pointer
&& !se
.direct_byref
)
1961 gcc_assert (e
->expr_type
== EXPR_VARIABLE
);
1962 tmp
= gfc_get_array_span (se
.expr
, e
);
1964 gfc_conv_descriptor_span_set (&se
.pre
, desc
, tmp
);
1967 if (e
->expr_type
== EXPR_FUNCTION
1968 && sym
->ts
.type
== BT_DERIVED
1969 && sym
->ts
.u
.derived
1970 && sym
->ts
.u
.derived
->attr
.pdt_type
)
1972 tmp
= gfc_deallocate_pdt_comp (sym
->ts
.u
.derived
, se
.expr
,
1974 gfc_add_expr_to_block (&se
.post
, tmp
);
1977 /* Done, register stuff as init / cleanup code. */
1978 gfc_add_init_cleanup (block
, gfc_finish_block (&se
.pre
),
1979 gfc_finish_block (&se
.post
));
1982 /* Temporaries, arising from TYPE IS, just need the descriptor of class
1983 arrays to be assigned directly. */
1984 else if (class_target
&& sym
->attr
.dimension
1985 && (sym
->ts
.type
== BT_DERIVED
|| unlimited
))
1989 gfc_init_se (&se
, NULL
);
1990 se
.descriptor_only
= 1;
1991 /* In a select type the (temporary) associate variable shall point to
1992 a standard fortran array (lower bound == 1), but conv_expr ()
1993 just maps to the input array in the class object, whose lbound may
1994 be arbitrary. conv_expr_descriptor solves this by inserting a
1995 temporary array descriptor. */
1996 gfc_conv_expr_descriptor (&se
, e
);
1998 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se
.expr
))
1999 || GFC_ARRAY_TYPE_P (TREE_TYPE (se
.expr
)));
2000 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (sym
->backend_decl
)));
2002 if (GFC_ARRAY_TYPE_P (TREE_TYPE (se
.expr
)))
2004 if (INDIRECT_REF_P (se
.expr
))
2005 tmp
= TREE_OPERAND (se
.expr
, 0);
2009 gfc_add_modify (&se
.pre
, sym
->backend_decl
,
2010 gfc_class_data_get (GFC_DECL_SAVED_DESCRIPTOR (tmp
)));
2013 gfc_add_modify (&se
.pre
, sym
->backend_decl
, se
.expr
);
2017 /* Recover the dtype, which has been overwritten by the
2018 assignment from an unlimited polymorphic object. */
2019 tmp
= gfc_conv_descriptor_dtype (sym
->backend_decl
);
2020 gfc_add_modify (&se
.pre
, tmp
,
2021 gfc_get_dtype (TREE_TYPE (sym
->backend_decl
)));
2024 gfc_add_init_cleanup (block
, gfc_finish_block (&se
.pre
),
2025 gfc_finish_block (&se
.post
));
2028 /* Do a scalar pointer assignment; this is for scalar variable targets. */
2029 else if (gfc_is_associate_pointer (sym
))
2033 gcc_assert (!sym
->attr
.dimension
);
2035 gfc_init_se (&se
, NULL
);
2037 /* Class associate-names come this way because they are
2038 unconditionally associate pointers and the symbol is scalar. */
2039 if (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)->attr
.dimension
)
2042 /* For a class array we need a descriptor for the selector. */
2043 gfc_conv_expr_descriptor (&se
, e
);
2044 /* Needed to get/set the _len component below. */
2045 target_expr
= se
.expr
;
2047 /* Obtain a temporary class container for the result. */
2048 gfc_conv_class_to_class (&se
, e
, sym
->ts
, false, true, false, false);
2049 se
.expr
= build_fold_indirect_ref_loc (input_location
, se
.expr
);
2051 /* Set the offset. */
2052 desc
= gfc_class_data_get (se
.expr
);
2053 offset
= gfc_index_zero_node
;
2054 for (n
= 0; n
< e
->rank
; n
++)
2056 dim
= gfc_rank_cst
[n
];
2057 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
2058 gfc_array_index_type
,
2059 gfc_conv_descriptor_stride_get (desc
, dim
),
2060 gfc_conv_descriptor_lbound_get (desc
, dim
));
2061 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
2062 gfc_array_index_type
,
2065 if (need_len_assign
)
2068 && DECL_LANG_SPECIFIC (e
->symtree
->n
.sym
->backend_decl
)
2069 && GFC_DECL_SAVED_DESCRIPTOR (e
->symtree
->n
.sym
->backend_decl
)
2070 && TREE_CODE (target_expr
) != COMPONENT_REF
)
2071 /* Use the original class descriptor stored in the saved
2072 descriptor to get the target_expr. */
2074 GFC_DECL_SAVED_DESCRIPTOR (e
->symtree
->n
.sym
->backend_decl
);
2076 /* Strip the _data component from the target_expr. */
2077 target_expr
= TREE_OPERAND (target_expr
, 0);
2078 /* Add a reference to the _len comp to the target expr. */
2079 tmp
= gfc_class_len_get (target_expr
);
2080 /* Get the component-ref for the temp structure's _len comp. */
2081 charlen
= gfc_class_len_get (se
.expr
);
2082 /* Add the assign to the beginning of the block... */
2083 gfc_add_modify (&se
.pre
, charlen
,
2084 fold_convert (TREE_TYPE (charlen
), tmp
));
2085 /* and the oposite way at the end of the block, to hand changes
2086 on the string length back. */
2087 gfc_add_modify (&se
.post
, tmp
,
2088 fold_convert (TREE_TYPE (tmp
), charlen
));
2089 /* Length assignment done, prevent adding it again below. */
2090 need_len_assign
= false;
2092 gfc_conv_descriptor_offset_set (&se
.pre
, desc
, offset
);
2094 else if (sym
->ts
.type
== BT_CLASS
&& e
->ts
.type
== BT_CLASS
2095 && CLASS_DATA (e
)->attr
.dimension
)
2097 /* This is bound to be a class array element. */
2098 gfc_conv_expr_reference (&se
, e
);
2099 /* Get the _vptr component of the class object. */
2100 tmp
= gfc_get_vptr_from_expr (se
.expr
);
2101 /* Obtain a temporary class container for the result. */
2102 gfc_conv_derived_to_class (&se
, e
, sym
->ts
, tmp
, false, false);
2103 se
.expr
= build_fold_indirect_ref_loc (input_location
, se
.expr
);
2104 need_len_assign
= false;
2108 /* For BT_CLASS and BT_DERIVED, this boils down to a pointer assign,
2109 which has the string length included. For CHARACTERS it is still
2110 needed and will be done at the end of this routine. */
2111 gfc_conv_expr (&se
, e
);
2112 need_len_assign
= need_len_assign
&& sym
->ts
.type
== BT_CHARACTER
;
2115 if (sym
->ts
.type
== BT_CHARACTER
2116 && !sym
->attr
.select_type_temporary
2117 && VAR_P (sym
->ts
.u
.cl
->backend_decl
)
2118 && se
.string_length
!= sym
->ts
.u
.cl
->backend_decl
)
2120 gfc_add_modify (&se
.pre
, sym
->ts
.u
.cl
->backend_decl
,
2121 fold_convert (TREE_TYPE (sym
->ts
.u
.cl
->backend_decl
),
2123 if (e
->expr_type
== EXPR_FUNCTION
)
2125 tmp
= gfc_call_free (sym
->backend_decl
);
2126 gfc_add_expr_to_block (&se
.post
, tmp
);
2130 if (sym
->ts
.type
== BT_CHARACTER
&& e
->ts
.type
== BT_CHARACTER
2131 && POINTER_TYPE_P (TREE_TYPE (se
.expr
)))
2133 /* These are pointer types already. */
2134 tmp
= fold_convert (TREE_TYPE (sym
->backend_decl
), se
.expr
);
2138 tree ctree
= gfc_get_class_from_expr (se
.expr
);
2139 tmp
= TREE_TYPE (sym
->backend_decl
);
2141 /* Coarray scalar component expressions can emerge from
2142 the front end as array elements of the _data field. */
2143 if (sym
->ts
.type
== BT_CLASS
2144 && e
->ts
.type
== BT_CLASS
&& e
->rank
== 0
2145 && !GFC_CLASS_TYPE_P (TREE_TYPE (se
.expr
)) && ctree
)
2151 dtmp
= TREE_TYPE (TREE_TYPE (sym
->backend_decl
));
2152 ctree
= gfc_create_var (dtmp
, "class");
2154 stmp
= gfc_class_data_get (se
.expr
);
2155 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (stmp
)));
2157 /* Set the fields of the target class variable. */
2158 stmp
= gfc_conv_descriptor_data_get (stmp
);
2159 dtmp
= gfc_class_data_get (ctree
);
2160 stmp
= fold_convert (TREE_TYPE (dtmp
), stmp
);
2161 gfc_add_modify (&se
.pre
, dtmp
, stmp
);
2162 stmp
= gfc_class_vptr_get (se
.expr
);
2163 dtmp
= gfc_class_vptr_get (ctree
);
2164 stmp
= fold_convert (TREE_TYPE (dtmp
), stmp
);
2165 gfc_add_modify (&se
.pre
, dtmp
, stmp
);
2166 if (UNLIMITED_POLY (sym
))
2168 stmp
= gfc_class_len_get (se
.expr
);
2169 dtmp
= gfc_class_len_get (ctree
);
2170 stmp
= fold_convert (TREE_TYPE (dtmp
), stmp
);
2171 gfc_add_modify (&se
.pre
, dtmp
, stmp
);
2175 tmp
= gfc_build_addr_expr (tmp
, se
.expr
);
2178 gfc_add_modify (&se
.pre
, sym
->backend_decl
, tmp
);
2180 gfc_add_init_cleanup (block
, gfc_finish_block( &se
.pre
),
2181 gfc_finish_block (&se
.post
));
2184 /* Do a simple assignment. This is for scalar expressions, where we
2185 can simply use expression assignment. */
2192 gfc_init_se (&se
, NULL
);
2194 /* resolve.cc converts some associate names to allocatable so that
2195 allocation can take place automatically in gfc_trans_assignment.
2196 The frontend prevents them from being either allocated,
2197 deallocated or reallocated. */
2198 if (sym
->attr
.allocatable
)
2200 tmp
= sym
->backend_decl
;
2201 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp
)))
2202 tmp
= gfc_conv_descriptor_data_get (tmp
);
2203 gfc_add_modify (&se
.pre
, tmp
, fold_convert (TREE_TYPE (tmp
),
2204 null_pointer_node
));
2207 lhs
= gfc_lval_expr_from_sym (sym
);
2208 res
= gfc_trans_assignment (lhs
, e
, false, true);
2209 gfc_add_expr_to_block (&se
.pre
, res
);
2211 tmp
= sym
->backend_decl
;
2212 if (e
->expr_type
== EXPR_FUNCTION
2213 && sym
->ts
.type
== BT_DERIVED
2214 && sym
->ts
.u
.derived
2215 && sym
->ts
.u
.derived
->attr
.pdt_type
)
2217 tmp
= gfc_deallocate_pdt_comp (sym
->ts
.u
.derived
, tmp
,
2220 else if (e
->expr_type
== EXPR_FUNCTION
2221 && sym
->ts
.type
== BT_CLASS
2222 && CLASS_DATA (sym
)->ts
.u
.derived
2223 && CLASS_DATA (sym
)->ts
.u
.derived
->attr
.pdt_type
)
2225 tmp
= gfc_class_data_get (tmp
);
2226 tmp
= gfc_deallocate_pdt_comp (CLASS_DATA (sym
)->ts
.u
.derived
,
2229 else if (sym
->attr
.allocatable
)
2231 tmp
= sym
->backend_decl
;
2233 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp
)))
2234 tmp
= gfc_conv_descriptor_data_get (tmp
);
2236 /* A simple call to free suffices here. */
2237 tmp
= gfc_call_free (tmp
);
2239 /* Make sure that reallocation on assignment cannot occur. */
2240 sym
->attr
.allocatable
= 0;
2245 res
= gfc_finish_block (&se
.pre
);
2246 gfc_add_init_cleanup (block
, res
, tmp
);
2247 gfc_free_expr (lhs
);
2250 /* Set the stringlength, when needed. */
2251 if (need_len_assign
)
2254 gfc_init_se (&se
, NULL
);
2255 if (e
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
)
2257 /* Deferred strings are dealt with in the preceeding. */
2258 gcc_assert (!e
->symtree
->n
.sym
->ts
.deferred
);
2259 tmp
= e
->symtree
->n
.sym
->ts
.u
.cl
->backend_decl
;
2261 else if (e
->symtree
->n
.sym
->attr
.function
2262 && e
->symtree
->n
.sym
== e
->symtree
->n
.sym
->result
)
2264 tmp
= gfc_get_fake_result_decl (e
->symtree
->n
.sym
, 0);
2265 tmp
= gfc_class_len_get (tmp
);
2268 tmp
= gfc_class_len_get (gfc_get_symbol_decl (e
->symtree
->n
.sym
));
2269 gfc_get_symbol_decl (sym
);
2270 charlen
= sym
->ts
.type
== BT_CHARACTER
? sym
->ts
.u
.cl
->backend_decl
2271 : gfc_class_len_get (sym
->backend_decl
);
2272 /* Prevent adding a noop len= len. */
2275 gfc_add_modify (&se
.pre
, charlen
,
2276 fold_convert (TREE_TYPE (charlen
), tmp
));
2277 gfc_add_init_cleanup (block
, gfc_finish_block (&se
.pre
),
2278 gfc_finish_block (&se
.post
));
2284 /* Translate a BLOCK construct. This is basically what we would do for a
2288 gfc_trans_block_construct (gfc_code
* code
)
2292 gfc_wrapped_block block
;
2295 gfc_association_list
*ass
;
2297 ns
= code
->ext
.block
.ns
;
2299 sym
= ns
->proc_name
;
2302 /* Process local variables. */
2303 gcc_assert (!sym
->tlink
);
2305 gfc_process_block_locals (ns
);
2307 /* Generate code including exit-label. */
2308 gfc_init_block (&body
);
2309 exit_label
= gfc_build_label_decl (NULL_TREE
);
2310 code
->exit_label
= exit_label
;
2312 finish_oacc_declare (ns
, sym
, true);
2314 gfc_add_expr_to_block (&body
, gfc_trans_code (ns
->code
));
2315 gfc_add_expr_to_block (&body
, build1_v (LABEL_EXPR
, exit_label
));
2317 /* Finish everything. */
2318 gfc_start_wrapped_block (&block
, gfc_finish_block (&body
));
2319 gfc_trans_deferred_vars (sym
, &block
);
2320 for (ass
= code
->ext
.block
.assoc
; ass
; ass
= ass
->next
)
2321 trans_associate_var (ass
->st
->n
.sym
, &block
);
2323 return gfc_finish_wrapped_block (&block
);
2326 /* Translate the simple DO construct in a C-style manner.
2327 This is where the loop variable has integer type and step +-1.
2328 Following code will generate infinite loop in case where TO is INT_MAX
2329 (for +1 step) or INT_MIN (for -1 step)
2331 We translate a do loop from:
2333 DO dovar = from, to, step
2339 [Evaluate loop bounds and step]
2351 This helps the optimizers by avoiding the extra pre-header condition and
2352 we save a register as we just compare the updated IV (not a value in
2356 gfc_trans_simple_do (gfc_code
* code
, stmtblock_t
*pblock
, tree dovar
,
2357 tree from
, tree to
, tree step
, tree exit_cond
)
2363 tree saved_dovar
= NULL
;
2367 type
= TREE_TYPE (dovar
);
2368 bool is_step_positive
= tree_int_cst_sgn (step
) > 0;
2370 loc
= gfc_get_location (&code
->ext
.iterator
->start
->where
);
2372 /* Initialize the DO variable: dovar = from. */
2373 gfc_add_modify_loc (loc
, pblock
, dovar
,
2374 fold_convert (TREE_TYPE (dovar
), from
));
2376 /* Save value for do-tinkering checking. */
2377 if (gfc_option
.rtcheck
& GFC_RTCHECK_DO
)
2379 saved_dovar
= gfc_create_var (type
, ".saved_dovar");
2380 gfc_add_modify_loc (loc
, pblock
, saved_dovar
, dovar
);
2383 /* Cycle and exit statements are implemented with gotos. */
2384 cycle_label
= gfc_build_label_decl (NULL_TREE
);
2385 exit_label
= gfc_build_label_decl (NULL_TREE
);
2387 /* Put the labels where they can be found later. See gfc_trans_do(). */
2388 code
->cycle_label
= cycle_label
;
2389 code
->exit_label
= exit_label
;
2392 gfc_start_block (&body
);
2394 /* Exit the loop if there is an I/O result condition or error. */
2397 tmp
= build1_v (GOTO_EXPR
, exit_label
);
2398 tmp
= fold_build3_loc (loc
, COND_EXPR
, void_type_node
,
2400 build_empty_stmt (loc
));
2401 gfc_add_expr_to_block (&body
, tmp
);
2404 /* Evaluate the loop condition. */
2405 if (is_step_positive
)
2406 cond
= fold_build2_loc (loc
, GT_EXPR
, logical_type_node
, dovar
,
2407 fold_convert (type
, to
));
2409 cond
= fold_build2_loc (loc
, LT_EXPR
, logical_type_node
, dovar
,
2410 fold_convert (type
, to
));
2412 cond
= gfc_evaluate_now_loc (loc
, cond
, &body
);
2413 if (code
->ext
.iterator
->unroll
&& cond
!= error_mark_node
)
2415 = build3 (ANNOTATE_EXPR
, TREE_TYPE (cond
), cond
,
2416 build_int_cst (integer_type_node
, annot_expr_unroll_kind
),
2417 build_int_cst (integer_type_node
, code
->ext
.iterator
->unroll
));
2419 if (code
->ext
.iterator
->ivdep
&& cond
!= error_mark_node
)
2420 cond
= build3 (ANNOTATE_EXPR
, TREE_TYPE (cond
), cond
,
2421 build_int_cst (integer_type_node
, annot_expr_ivdep_kind
),
2423 if (code
->ext
.iterator
->vector
&& cond
!= error_mark_node
)
2424 cond
= build3 (ANNOTATE_EXPR
, TREE_TYPE (cond
), cond
,
2425 build_int_cst (integer_type_node
, annot_expr_vector_kind
),
2427 if (code
->ext
.iterator
->novector
&& cond
!= error_mark_node
)
2428 cond
= build3 (ANNOTATE_EXPR
, TREE_TYPE (cond
), cond
,
2429 build_int_cst (integer_type_node
, annot_expr_no_vector_kind
),
2432 /* The loop exit. */
2433 tmp
= fold_build1_loc (loc
, GOTO_EXPR
, void_type_node
, exit_label
);
2434 TREE_USED (exit_label
) = 1;
2435 tmp
= fold_build3_loc (loc
, COND_EXPR
, void_type_node
,
2436 cond
, tmp
, build_empty_stmt (loc
));
2437 gfc_add_expr_to_block (&body
, tmp
);
2439 /* Check whether the induction variable is equal to INT_MAX
2440 (respectively to INT_MIN). */
2441 if (gfc_option
.rtcheck
& GFC_RTCHECK_DO
)
2443 tree boundary
= is_step_positive
? TYPE_MAX_VALUE (type
)
2444 : TYPE_MIN_VALUE (type
);
2446 tmp
= fold_build2_loc (loc
, EQ_EXPR
, logical_type_node
,
2448 gfc_trans_runtime_check (true, false, tmp
, &body
, &code
->loc
,
2449 "Loop iterates infinitely");
2452 /* Main loop body. */
2453 tmp
= gfc_trans_code_cond (code
->block
->next
, exit_cond
);
2454 gfc_add_expr_to_block (&body
, tmp
);
2456 /* Label for cycle statements (if needed). */
2457 if (TREE_USED (cycle_label
))
2459 tmp
= build1_v (LABEL_EXPR
, cycle_label
);
2460 gfc_add_expr_to_block (&body
, tmp
);
2463 /* Check whether someone has modified the loop variable. */
2464 if (gfc_option
.rtcheck
& GFC_RTCHECK_DO
)
2466 tmp
= fold_build2_loc (loc
, NE_EXPR
, logical_type_node
,
2467 dovar
, saved_dovar
);
2468 gfc_trans_runtime_check (true, false, tmp
, &body
, &code
->loc
,
2469 "Loop variable has been modified");
2472 /* Increment the loop variable. */
2473 tmp
= fold_build2_loc (loc
, PLUS_EXPR
, type
, dovar
, step
);
2474 gfc_add_modify_loc (loc
, &body
, dovar
, tmp
);
2476 if (gfc_option
.rtcheck
& GFC_RTCHECK_DO
)
2477 gfc_add_modify_loc (loc
, &body
, saved_dovar
, dovar
);
2479 /* Finish the loop body. */
2480 tmp
= gfc_finish_block (&body
);
2481 tmp
= fold_build1_loc (loc
, LOOP_EXPR
, void_type_node
, tmp
);
2483 gfc_add_expr_to_block (pblock
, tmp
);
2485 /* Add the exit label. */
2486 tmp
= build1_v (LABEL_EXPR
, exit_label
);
2487 gfc_add_expr_to_block (pblock
, tmp
);
2489 return gfc_finish_block (pblock
);
2492 /* Translate the DO construct. This obviously is one of the most
2493 important ones to get right with any compiler, but especially
2496 We special case some loop forms as described in gfc_trans_simple_do.
2497 For other cases we implement them with a separate loop count,
2498 as described in the standard.
2500 We translate a do loop from:
2502 DO dovar = from, to, step
2508 [evaluate loop bounds and step]
2509 empty = (step > 0 ? to < from : to > from);
2510 countm1 = (to - from) / step;
2512 if (empty) goto exit_label;
2520 if (countm1t == 0) goto exit_label;
2524 countm1 is an unsigned integer. It is equal to the loop count minus one,
2525 because the loop count itself can overflow. */
2528 gfc_trans_do (gfc_code
* code
, tree exit_cond
)
2532 tree saved_dovar
= NULL
;
2547 gfc_start_block (&block
);
2549 loc
= gfc_get_location (&code
->ext
.iterator
->start
->where
);
2551 /* Evaluate all the expressions in the iterator. */
2552 gfc_init_se (&se
, NULL
);
2553 gfc_conv_expr_lhs (&se
, code
->ext
.iterator
->var
);
2554 gfc_add_block_to_block (&block
, &se
.pre
);
2556 type
= TREE_TYPE (dovar
);
2558 gfc_init_se (&se
, NULL
);
2559 gfc_conv_expr_val (&se
, code
->ext
.iterator
->start
);
2560 gfc_add_block_to_block (&block
, &se
.pre
);
2561 from
= gfc_evaluate_now (se
.expr
, &block
);
2563 gfc_init_se (&se
, NULL
);
2564 gfc_conv_expr_val (&se
, code
->ext
.iterator
->end
);
2565 gfc_add_block_to_block (&block
, &se
.pre
);
2566 to
= gfc_evaluate_now (se
.expr
, &block
);
2568 gfc_init_se (&se
, NULL
);
2569 gfc_conv_expr_val (&se
, code
->ext
.iterator
->step
);
2570 gfc_add_block_to_block (&block
, &se
.pre
);
2571 step
= gfc_evaluate_now (se
.expr
, &block
);
2573 if (gfc_option
.rtcheck
& GFC_RTCHECK_DO
)
2575 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
, step
,
2576 build_zero_cst (type
));
2577 gfc_trans_runtime_check (true, false, tmp
, &block
, &code
->loc
,
2578 "DO step value is zero");
2581 /* Special case simple loops. */
2582 if (TREE_CODE (type
) == INTEGER_TYPE
2583 && (integer_onep (step
)
2584 || tree_int_cst_equal (step
, integer_minus_one_node
)))
2585 return gfc_trans_simple_do (code
, &block
, dovar
, from
, to
, step
,
2588 if (TREE_CODE (type
) == INTEGER_TYPE
)
2589 utype
= unsigned_type_for (type
);
2591 utype
= unsigned_type_for (gfc_array_index_type
);
2592 countm1
= gfc_create_var (utype
, "countm1");
2594 /* Cycle and exit statements are implemented with gotos. */
2595 cycle_label
= gfc_build_label_decl (NULL_TREE
);
2596 exit_label
= gfc_build_label_decl (NULL_TREE
);
2597 TREE_USED (exit_label
) = 1;
2599 /* Put these labels where they can be found later. */
2600 code
->cycle_label
= cycle_label
;
2601 code
->exit_label
= exit_label
;
2603 /* Initialize the DO variable: dovar = from. */
2604 gfc_add_modify (&block
, dovar
, from
);
2606 /* Save value for do-tinkering checking. */
2607 if (gfc_option
.rtcheck
& GFC_RTCHECK_DO
)
2609 saved_dovar
= gfc_create_var (type
, ".saved_dovar");
2610 gfc_add_modify_loc (loc
, &block
, saved_dovar
, dovar
);
2613 /* Initialize loop count and jump to exit label if the loop is empty.
2614 This code is executed before we enter the loop body. We generate:
2617 countm1 = (to - from) / step;
2623 countm1 = (from - to) / -step;
2629 if (TREE_CODE (type
) == INTEGER_TYPE
)
2631 tree pos
, neg
, tou
, fromu
, stepu
, tmp2
;
2633 /* The distance from FROM to TO cannot always be represented in a signed
2634 type, thus use unsigned arithmetic, also to avoid any undefined
2636 tou
= fold_convert (utype
, to
);
2637 fromu
= fold_convert (utype
, from
);
2638 stepu
= fold_convert (utype
, step
);
2640 /* For a positive step, when to < from, exit, otherwise compute
2641 countm1 = ((unsigned)to - (unsigned)from) / (unsigned)step */
2642 tmp
= fold_build2_loc (loc
, LT_EXPR
, logical_type_node
, to
, from
);
2643 tmp2
= fold_build2_loc (loc
, TRUNC_DIV_EXPR
, utype
,
2644 fold_build2_loc (loc
, MINUS_EXPR
, utype
,
2647 pos
= build2 (COMPOUND_EXPR
, void_type_node
,
2648 fold_build2 (MODIFY_EXPR
, void_type_node
,
2650 build3_loc (loc
, COND_EXPR
, void_type_node
,
2651 gfc_unlikely (tmp
, PRED_FORTRAN_LOOP_PREHEADER
),
2652 build1_loc (loc
, GOTO_EXPR
, void_type_node
,
2653 exit_label
), NULL_TREE
));
2655 /* For a negative step, when to > from, exit, otherwise compute
2656 countm1 = ((unsigned)from - (unsigned)to) / -(unsigned)step */
2657 tmp
= fold_build2_loc (loc
, GT_EXPR
, logical_type_node
, to
, from
);
2658 tmp2
= fold_build2_loc (loc
, TRUNC_DIV_EXPR
, utype
,
2659 fold_build2_loc (loc
, MINUS_EXPR
, utype
,
2661 fold_build1_loc (loc
, NEGATE_EXPR
, utype
, stepu
));
2662 neg
= build2 (COMPOUND_EXPR
, void_type_node
,
2663 fold_build2 (MODIFY_EXPR
, void_type_node
,
2665 build3_loc (loc
, COND_EXPR
, void_type_node
,
2666 gfc_unlikely (tmp
, PRED_FORTRAN_LOOP_PREHEADER
),
2667 build1_loc (loc
, GOTO_EXPR
, void_type_node
,
2668 exit_label
), NULL_TREE
));
2670 tmp
= fold_build2_loc (loc
, LT_EXPR
, logical_type_node
, step
,
2671 build_int_cst (TREE_TYPE (step
), 0));
2672 tmp
= fold_build3_loc (loc
, COND_EXPR
, void_type_node
, tmp
, neg
, pos
);
2674 gfc_add_expr_to_block (&block
, tmp
);
2680 /* TODO: We could use the same width as the real type.
2681 This would probably cause more problems that it solves
2682 when we implement "long double" types. */
2684 tmp
= fold_build2_loc (loc
, MINUS_EXPR
, type
, to
, from
);
2685 tmp
= fold_build2_loc (loc
, RDIV_EXPR
, type
, tmp
, step
);
2686 tmp
= fold_build1_loc (loc
, FIX_TRUNC_EXPR
, utype
, tmp
);
2687 gfc_add_modify (&block
, countm1
, tmp
);
2689 /* We need a special check for empty loops:
2690 empty = (step > 0 ? to < from : to > from); */
2691 pos_step
= fold_build2_loc (loc
, GT_EXPR
, logical_type_node
, step
,
2692 build_zero_cst (type
));
2693 tmp
= fold_build3_loc (loc
, COND_EXPR
, logical_type_node
, pos_step
,
2694 fold_build2_loc (loc
, LT_EXPR
,
2695 logical_type_node
, to
, from
),
2696 fold_build2_loc (loc
, GT_EXPR
,
2697 logical_type_node
, to
, from
));
2698 /* If the loop is empty, go directly to the exit label. */
2699 tmp
= fold_build3_loc (loc
, COND_EXPR
, void_type_node
, tmp
,
2700 build1_v (GOTO_EXPR
, exit_label
),
2701 build_empty_stmt (input_location
));
2702 gfc_add_expr_to_block (&block
, tmp
);
2706 gfc_start_block (&body
);
2708 /* Main loop body. */
2709 tmp
= gfc_trans_code_cond (code
->block
->next
, exit_cond
);
2710 gfc_add_expr_to_block (&body
, tmp
);
2712 /* Label for cycle statements (if needed). */
2713 if (TREE_USED (cycle_label
))
2715 tmp
= build1_v (LABEL_EXPR
, cycle_label
);
2716 gfc_add_expr_to_block (&body
, tmp
);
2719 /* Check whether someone has modified the loop variable. */
2720 if (gfc_option
.rtcheck
& GFC_RTCHECK_DO
)
2722 tmp
= fold_build2_loc (loc
, NE_EXPR
, logical_type_node
, dovar
,
2724 gfc_trans_runtime_check (true, false, tmp
, &body
, &code
->loc
,
2725 "Loop variable has been modified");
2728 /* Exit the loop if there is an I/O result condition or error. */
2731 tmp
= build1_v (GOTO_EXPR
, exit_label
);
2732 tmp
= fold_build3_loc (loc
, COND_EXPR
, void_type_node
,
2734 build_empty_stmt (input_location
));
2735 gfc_add_expr_to_block (&body
, tmp
);
2738 /* Increment the loop variable. */
2739 tmp
= fold_build2_loc (loc
, PLUS_EXPR
, type
, dovar
, step
);
2740 gfc_add_modify_loc (loc
, &body
, dovar
, tmp
);
2742 if (gfc_option
.rtcheck
& GFC_RTCHECK_DO
)
2743 gfc_add_modify_loc (loc
, &body
, saved_dovar
, dovar
);
2745 /* Initialize countm1t. */
2746 tree countm1t
= gfc_create_var (utype
, "countm1t");
2747 gfc_add_modify_loc (loc
, &body
, countm1t
, countm1
);
2749 /* Decrement the loop count. */
2750 tmp
= fold_build2_loc (loc
, MINUS_EXPR
, utype
, countm1
,
2751 build_int_cst (utype
, 1));
2752 gfc_add_modify_loc (loc
, &body
, countm1
, tmp
);
2754 /* End with the loop condition. Loop until countm1t == 0. */
2755 cond
= fold_build2_loc (loc
, EQ_EXPR
, logical_type_node
, countm1t
,
2756 build_int_cst (utype
, 0));
2757 if (code
->ext
.iterator
->unroll
&& cond
!= error_mark_node
)
2759 = build3 (ANNOTATE_EXPR
, TREE_TYPE (cond
), cond
,
2760 build_int_cst (integer_type_node
, annot_expr_unroll_kind
),
2761 build_int_cst (integer_type_node
, code
->ext
.iterator
->unroll
));
2763 if (code
->ext
.iterator
->ivdep
&& cond
!= error_mark_node
)
2764 cond
= build3 (ANNOTATE_EXPR
, TREE_TYPE (cond
), cond
,
2765 build_int_cst (integer_type_node
, annot_expr_ivdep_kind
),
2767 if (code
->ext
.iterator
->vector
&& cond
!= error_mark_node
)
2768 cond
= build3 (ANNOTATE_EXPR
, TREE_TYPE (cond
), cond
,
2769 build_int_cst (integer_type_node
, annot_expr_vector_kind
),
2771 if (code
->ext
.iterator
->novector
&& cond
!= error_mark_node
)
2772 cond
= build3 (ANNOTATE_EXPR
, TREE_TYPE (cond
), cond
,
2773 build_int_cst (integer_type_node
, annot_expr_no_vector_kind
),
2776 tmp
= fold_build1_loc (loc
, GOTO_EXPR
, void_type_node
, exit_label
);
2777 tmp
= fold_build3_loc (loc
, COND_EXPR
, void_type_node
,
2778 cond
, tmp
, build_empty_stmt (loc
));
2779 gfc_add_expr_to_block (&body
, tmp
);
2781 /* End of loop body. */
2782 tmp
= gfc_finish_block (&body
);
2784 /* The for loop itself. */
2785 tmp
= fold_build1_loc (loc
, LOOP_EXPR
, void_type_node
, tmp
);
2786 gfc_add_expr_to_block (&block
, tmp
);
2788 /* Add the exit label. */
2789 tmp
= build1_v (LABEL_EXPR
, exit_label
);
2790 gfc_add_expr_to_block (&block
, tmp
);
2792 return gfc_finish_block (&block
);
2796 /* Translate the DO WHILE construct.
2809 if (! cond) goto exit_label;
2815 Because the evaluation of the exit condition `cond' may have side
2816 effects, we can't do much for empty loop bodies. The backend optimizers
2817 should be smart enough to eliminate any dead loops. */
2820 gfc_trans_do_while (gfc_code
* code
)
2828 /* Everything we build here is part of the loop body. */
2829 gfc_start_block (&block
);
2831 /* Cycle and exit statements are implemented with gotos. */
2832 cycle_label
= gfc_build_label_decl (NULL_TREE
);
2833 exit_label
= gfc_build_label_decl (NULL_TREE
);
2835 /* Put the labels where they can be found later. See gfc_trans_do(). */
2836 code
->cycle_label
= cycle_label
;
2837 code
->exit_label
= exit_label
;
2839 /* Create a GIMPLE version of the exit condition. */
2840 gfc_init_se (&cond
, NULL
);
2841 gfc_conv_expr_val (&cond
, code
->expr1
);
2842 gfc_add_block_to_block (&block
, &cond
.pre
);
2843 cond
.expr
= fold_build1_loc (gfc_get_location (&code
->expr1
->where
),
2844 TRUTH_NOT_EXPR
, TREE_TYPE (cond
.expr
),
2847 /* Build "IF (! cond) GOTO exit_label". */
2848 tmp
= build1_v (GOTO_EXPR
, exit_label
);
2849 TREE_USED (exit_label
) = 1;
2850 tmp
= fold_build3_loc (gfc_get_location (&code
->expr1
->where
), COND_EXPR
,
2851 void_type_node
, cond
.expr
, tmp
,
2852 build_empty_stmt (gfc_get_location (
2853 &code
->expr1
->where
)));
2854 gfc_add_expr_to_block (&block
, tmp
);
2856 /* The main body of the loop. */
2857 tmp
= gfc_trans_code (code
->block
->next
);
2858 gfc_add_expr_to_block (&block
, tmp
);
2860 /* Label for cycle statements (if needed). */
2861 if (TREE_USED (cycle_label
))
2863 tmp
= build1_v (LABEL_EXPR
, cycle_label
);
2864 gfc_add_expr_to_block (&block
, tmp
);
2867 /* End of loop body. */
2868 tmp
= gfc_finish_block (&block
);
2870 gfc_init_block (&block
);
2871 /* Build the loop. */
2872 tmp
= fold_build1_loc (gfc_get_location (&code
->expr1
->where
), LOOP_EXPR
,
2873 void_type_node
, tmp
);
2874 gfc_add_expr_to_block (&block
, tmp
);
2876 /* Add the exit label. */
2877 tmp
= build1_v (LABEL_EXPR
, exit_label
);
2878 gfc_add_expr_to_block (&block
, tmp
);
2880 return gfc_finish_block (&block
);
2884 /* Deal with the particular case of SELECT_TYPE, where the vtable
2885 addresses are used for the selection. Since these are not sorted,
2886 the selection has to be made by a series of if statements. */
2889 gfc_trans_select_type_cases (gfc_code
* code
)
2903 gfc_start_block (&block
);
2905 /* Calculate the switch expression. */
2906 gfc_init_se (&se
, NULL
);
2907 gfc_conv_expr_val (&se
, code
->expr1
);
2908 gfc_add_block_to_block (&block
, &se
.pre
);
2910 /* Generate an expression for the selector hash value, for
2911 use to resolve character cases. */
2912 e
= gfc_copy_expr (code
->expr1
->value
.function
.actual
->expr
);
2913 gfc_add_hash_component (e
);
2915 TREE_USED (code
->exit_label
) = 0;
2918 for (c
= code
->block
; c
; c
= c
->block
)
2920 cp
= c
->ext
.block
.case_list
;
2922 /* Assume it's the default case. */
2927 /* Put the default case at the end. */
2928 if ((!def
&& !cp
->low
) || (def
&& cp
->low
))
2931 if (cp
->low
&& (cp
->ts
.type
== BT_CLASS
2932 || cp
->ts
.type
== BT_DERIVED
))
2934 gfc_init_se (&cse
, NULL
);
2935 gfc_conv_expr_val (&cse
, cp
->low
);
2936 gfc_add_block_to_block (&block
, &cse
.pre
);
2939 else if (cp
->ts
.type
!= BT_UNKNOWN
)
2941 gcc_assert (cp
->high
);
2942 gfc_init_se (&cse
, NULL
);
2943 gfc_conv_expr_val (&cse
, cp
->high
);
2944 gfc_add_block_to_block (&block
, &cse
.pre
);
2948 gfc_init_block (&body
);
2950 /* Add the statements for this case. */
2951 tmp
= gfc_trans_code (c
->next
);
2952 gfc_add_expr_to_block (&body
, tmp
);
2954 /* Break to the end of the SELECT TYPE construct. The default
2955 case just falls through. */
2958 TREE_USED (code
->exit_label
) = 1;
2959 tmp
= build1_v (GOTO_EXPR
, code
->exit_label
);
2960 gfc_add_expr_to_block (&body
, tmp
);
2963 tmp
= gfc_finish_block (&body
);
2965 if (low
!= NULL_TREE
)
2967 /* Compare vtable pointers. */
2968 cond
= fold_build2_loc (input_location
, EQ_EXPR
,
2969 TREE_TYPE (se
.expr
), se
.expr
, low
);
2970 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
2972 build_empty_stmt (input_location
));
2974 else if (high
!= NULL_TREE
)
2976 /* Compare hash values for character cases. */
2977 gfc_init_se (&cse
, NULL
);
2978 gfc_conv_expr_val (&cse
, e
);
2979 gfc_add_block_to_block (&block
, &cse
.pre
);
2981 cond
= fold_build2_loc (input_location
, EQ_EXPR
,
2982 TREE_TYPE (se
.expr
), high
, cse
.expr
);
2983 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
2985 build_empty_stmt (input_location
));
2988 gfc_add_expr_to_block (&block
, tmp
);
2999 return gfc_finish_block (&block
);
3003 /* Translate the SELECT CASE construct for INTEGER case expressions,
3004 without killing all potential optimizations. The problem is that
3005 Fortran allows unbounded cases, but the back-end does not, so we
3006 need to intercept those before we enter the equivalent SWITCH_EXPR
3009 For example, we translate this,
3012 CASE (:100,101,105:115)
3022 to the GENERIC equivalent,
3026 case (minimum value for typeof(expr) ... 100:
3032 case 200 ... (maximum value for typeof(expr):
3049 gfc_trans_integer_select (gfc_code
* code
)
3059 gfc_start_block (&block
);
3061 /* Calculate the switch expression. */
3062 gfc_init_se (&se
, NULL
);
3063 gfc_conv_expr_val (&se
, code
->expr1
);
3064 gfc_add_block_to_block (&block
, &se
.pre
);
3066 end_label
= gfc_build_label_decl (NULL_TREE
);
3068 gfc_init_block (&body
);
3070 for (c
= code
->block
; c
; c
= c
->block
)
3072 for (cp
= c
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
3077 /* Assume it's the default case. */
3078 low
= high
= NULL_TREE
;
3082 low
= gfc_conv_mpz_to_tree (cp
->low
->value
.integer
,
3085 /* If there's only a lower bound, set the high bound to the
3086 maximum value of the case expression. */
3088 high
= TYPE_MAX_VALUE (TREE_TYPE (se
.expr
));
3093 /* Three cases are possible here:
3095 1) There is no lower bound, e.g. CASE (:N).
3096 2) There is a lower bound .NE. high bound, that is
3097 a case range, e.g. CASE (N:M) where M>N (we make
3098 sure that M>N during type resolution).
3099 3) There is a lower bound, and it has the same value
3100 as the high bound, e.g. CASE (N:N). This is our
3101 internal representation of CASE(N).
3103 In the first and second case, we need to set a value for
3104 high. In the third case, we don't because the GCC middle
3105 end represents a single case value by just letting high be
3106 a NULL_TREE. We can't do that because we need to be able
3107 to represent unbounded cases. */
3110 || (mpz_cmp (cp
->low
->value
.integer
,
3111 cp
->high
->value
.integer
) != 0))
3112 high
= gfc_conv_mpz_to_tree (cp
->high
->value
.integer
,
3115 /* Unbounded case. */
3117 low
= TYPE_MIN_VALUE (TREE_TYPE (se
.expr
));
3120 /* Build a label. */
3121 label
= gfc_build_label_decl (NULL_TREE
);
3123 /* Add this case label.
3124 Add parameter 'label', make it match GCC backend. */
3125 tmp
= build_case_label (low
, high
, label
);
3126 gfc_add_expr_to_block (&body
, tmp
);
3129 /* Add the statements for this case. */
3130 tmp
= gfc_trans_code (c
->next
);
3131 gfc_add_expr_to_block (&body
, tmp
);
3133 /* Break to the end of the construct. */
3134 tmp
= build1_v (GOTO_EXPR
, end_label
);
3135 gfc_add_expr_to_block (&body
, tmp
);
3138 tmp
= gfc_finish_block (&body
);
3139 tmp
= fold_build2_loc (input_location
, SWITCH_EXPR
, NULL_TREE
, se
.expr
, tmp
);
3140 gfc_add_expr_to_block (&block
, tmp
);
3142 tmp
= build1_v (LABEL_EXPR
, end_label
);
3143 gfc_add_expr_to_block (&block
, tmp
);
3145 return gfc_finish_block (&block
);
3149 /* Translate the SELECT CASE construct for LOGICAL case expressions.
3151 There are only two cases possible here, even though the standard
3152 does allow three cases in a LOGICAL SELECT CASE construct: .TRUE.,
3153 .FALSE., and DEFAULT.
3155 We never generate more than two blocks here. Instead, we always
3156 try to eliminate the DEFAULT case. This way, we can translate this
3157 kind of SELECT construct to a simple
3161 expression in GENERIC. */
3164 gfc_trans_logical_select (gfc_code
* code
)
3167 gfc_code
*t
, *f
, *d
;
3172 /* Assume we don't have any cases at all. */
3175 /* Now see which ones we actually do have. We can have at most two
3176 cases in a single case list: one for .TRUE. and one for .FALSE.
3177 The default case is always separate. If the cases for .TRUE. and
3178 .FALSE. are in the same case list, the block for that case list
3179 always executed, and we don't generate code a COND_EXPR. */
3180 for (c
= code
->block
; c
; c
= c
->block
)
3182 for (cp
= c
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
3186 if (cp
->low
->value
.logical
== 0) /* .FALSE. */
3188 else /* if (cp->value.logical != 0), thus .TRUE. */
3196 /* Start a new block. */
3197 gfc_start_block (&block
);
3199 /* Calculate the switch expression. We always need to do this
3200 because it may have side effects. */
3201 gfc_init_se (&se
, NULL
);
3202 gfc_conv_expr_val (&se
, code
->expr1
);
3203 gfc_add_block_to_block (&block
, &se
.pre
);
3205 if (t
== f
&& t
!= NULL
)
3207 /* Cases for .TRUE. and .FALSE. are in the same block. Just
3208 translate the code for these cases, append it to the current
3210 gfc_add_expr_to_block (&block
, gfc_trans_code (t
->next
));
3214 tree true_tree
, false_tree
, stmt
;
3216 true_tree
= build_empty_stmt (input_location
);
3217 false_tree
= build_empty_stmt (input_location
);
3219 /* If we have a case for .TRUE. and for .FALSE., discard the default case.
3220 Otherwise, if .TRUE. or .FALSE. is missing and there is a default case,
3221 make the missing case the default case. */
3222 if (t
!= NULL
&& f
!= NULL
)
3232 /* Translate the code for each of these blocks, and append it to
3233 the current block. */
3235 true_tree
= gfc_trans_code (t
->next
);
3238 false_tree
= gfc_trans_code (f
->next
);
3240 stmt
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
3241 se
.expr
, true_tree
, false_tree
);
3242 gfc_add_expr_to_block (&block
, stmt
);
3245 return gfc_finish_block (&block
);
3249 /* The jump table types are stored in static variables to avoid
3250 constructing them from scratch every single time. */
3251 static GTY(()) tree select_struct
[2];
3253 /* Translate the SELECT CASE construct for CHARACTER case expressions.
3254 Instead of generating compares and jumps, it is far simpler to
3255 generate a data structure describing the cases in order and call a
3256 library subroutine that locates the right case.
3257 This is particularly true because this is the only case where we
3258 might have to dispose of a temporary.
3259 The library subroutine returns a pointer to jump to or NULL if no
3260 branches are to be taken. */
3263 gfc_trans_character_select (gfc_code
*code
)
3265 tree init
, end_label
, tmp
, type
, case_num
, label
, fndecl
;
3266 stmtblock_t block
, body
;
3271 vec
<constructor_elt
, va_gc
> *inits
= NULL
;
3273 tree pchartype
= gfc_get_pchar_type (code
->expr1
->ts
.kind
);
3275 /* The jump table types are stored in static variables to avoid
3276 constructing them from scratch every single time. */
3277 static tree ss_string1
[2], ss_string1_len
[2];
3278 static tree ss_string2
[2], ss_string2_len
[2];
3279 static tree ss_target
[2];
3281 cp
= code
->block
->ext
.block
.case_list
;
3282 while (cp
->left
!= NULL
)
3285 /* Generate the body */
3286 gfc_start_block (&block
);
3287 gfc_init_se (&expr1se
, NULL
);
3288 gfc_conv_expr_reference (&expr1se
, code
->expr1
);
3290 gfc_add_block_to_block (&block
, &expr1se
.pre
);
3292 end_label
= gfc_build_label_decl (NULL_TREE
);
3294 gfc_init_block (&body
);
3296 /* Attempt to optimize length 1 selects. */
3297 if (integer_onep (expr1se
.string_length
))
3299 for (d
= cp
; d
; d
= d
->right
)
3304 gcc_assert (d
->low
->expr_type
== EXPR_CONSTANT
3305 && d
->low
->ts
.type
== BT_CHARACTER
);
3306 if (d
->low
->value
.character
.length
> 1)
3308 for (i
= 1; i
< d
->low
->value
.character
.length
; i
++)
3309 if (d
->low
->value
.character
.string
[i
] != ' ')
3311 if (i
!= d
->low
->value
.character
.length
)
3313 if (optimize
&& d
->high
&& i
== 1)
3315 gcc_assert (d
->high
->expr_type
== EXPR_CONSTANT
3316 && d
->high
->ts
.type
== BT_CHARACTER
);
3317 if (d
->high
->value
.character
.length
> 1
3318 && (d
->low
->value
.character
.string
[0]
3319 == d
->high
->value
.character
.string
[0])
3320 && d
->high
->value
.character
.string
[1] != ' '
3321 && ((d
->low
->value
.character
.string
[1] < ' ')
3322 == (d
->high
->value
.character
.string
[1]
3332 gcc_assert (d
->high
->expr_type
== EXPR_CONSTANT
3333 && d
->high
->ts
.type
== BT_CHARACTER
);
3334 if (d
->high
->value
.character
.length
> 1)
3336 for (i
= 1; i
< d
->high
->value
.character
.length
; i
++)
3337 if (d
->high
->value
.character
.string
[i
] != ' ')
3339 if (i
!= d
->high
->value
.character
.length
)
3346 tree ctype
= gfc_get_char_type (code
->expr1
->ts
.kind
);
3348 for (c
= code
->block
; c
; c
= c
->block
)
3350 for (cp
= c
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
3356 /* Assume it's the default case. */
3357 low
= high
= NULL_TREE
;
3361 /* CASE ('ab') or CASE ('ab':'az') will never match
3362 any length 1 character. */
3363 if (cp
->low
->value
.character
.length
> 1
3364 && cp
->low
->value
.character
.string
[1] != ' ')
3367 if (cp
->low
->value
.character
.length
> 0)
3368 r
= cp
->low
->value
.character
.string
[0];
3371 low
= build_int_cst (ctype
, r
);
3373 /* If there's only a lower bound, set the high bound
3374 to the maximum value of the case expression. */
3376 high
= TYPE_MAX_VALUE (ctype
);
3382 || (cp
->low
->value
.character
.string
[0]
3383 != cp
->high
->value
.character
.string
[0]))
3385 if (cp
->high
->value
.character
.length
> 0)
3386 r
= cp
->high
->value
.character
.string
[0];
3389 high
= build_int_cst (ctype
, r
);
3392 /* Unbounded case. */
3394 low
= TYPE_MIN_VALUE (ctype
);
3397 /* Build a label. */
3398 label
= gfc_build_label_decl (NULL_TREE
);
3400 /* Add this case label.
3401 Add parameter 'label', make it match GCC backend. */
3402 tmp
= build_case_label (low
, high
, label
);
3403 gfc_add_expr_to_block (&body
, tmp
);
3406 /* Add the statements for this case. */
3407 tmp
= gfc_trans_code (c
->next
);
3408 gfc_add_expr_to_block (&body
, tmp
);
3410 /* Break to the end of the construct. */
3411 tmp
= build1_v (GOTO_EXPR
, end_label
);
3412 gfc_add_expr_to_block (&body
, tmp
);
3415 tmp
= gfc_string_to_single_character (expr1se
.string_length
,
3417 code
->expr1
->ts
.kind
);
3418 case_num
= gfc_create_var (ctype
, "case_num");
3419 gfc_add_modify (&block
, case_num
, tmp
);
3421 gfc_add_block_to_block (&block
, &expr1se
.post
);
3423 tmp
= gfc_finish_block (&body
);
3424 tmp
= fold_build2_loc (input_location
, SWITCH_EXPR
, NULL_TREE
,
3426 gfc_add_expr_to_block (&block
, tmp
);
3428 tmp
= build1_v (LABEL_EXPR
, end_label
);
3429 gfc_add_expr_to_block (&block
, tmp
);
3431 return gfc_finish_block (&block
);
3435 if (code
->expr1
->ts
.kind
== 1)
3437 else if (code
->expr1
->ts
.kind
== 4)
3442 if (select_struct
[k
] == NULL
)
3445 select_struct
[k
] = make_node (RECORD_TYPE
);
3447 if (code
->expr1
->ts
.kind
== 1)
3448 TYPE_NAME (select_struct
[k
]) = get_identifier ("_jump_struct_char1");
3449 else if (code
->expr1
->ts
.kind
== 4)
3450 TYPE_NAME (select_struct
[k
]) = get_identifier ("_jump_struct_char4");
3455 #define ADD_FIELD(NAME, TYPE) \
3456 ss_##NAME[k] = gfc_add_field_to_struct (select_struct[k], \
3457 get_identifier (stringize(NAME)), \
3461 ADD_FIELD (string1
, pchartype
);
3462 ADD_FIELD (string1_len
, gfc_charlen_type_node
);
3464 ADD_FIELD (string2
, pchartype
);
3465 ADD_FIELD (string2_len
, gfc_charlen_type_node
);
3467 ADD_FIELD (target
, integer_type_node
);
3470 gfc_finish_type (select_struct
[k
]);
3474 for (d
= cp
; d
; d
= d
->right
)
3477 for (c
= code
->block
; c
; c
= c
->block
)
3479 for (d
= c
->ext
.block
.case_list
; d
; d
= d
->next
)
3481 label
= gfc_build_label_decl (NULL_TREE
);
3482 tmp
= build_case_label ((d
->low
== NULL
&& d
->high
== NULL
)
3484 : build_int_cst (integer_type_node
, d
->n
),
3486 gfc_add_expr_to_block (&body
, tmp
);
3489 tmp
= gfc_trans_code (c
->next
);
3490 gfc_add_expr_to_block (&body
, tmp
);
3492 tmp
= build1_v (GOTO_EXPR
, end_label
);
3493 gfc_add_expr_to_block (&body
, tmp
);
3496 /* Generate the structure describing the branches */
3497 for (d
= cp
; d
; d
= d
->right
)
3499 vec
<constructor_elt
, va_gc
> *node
= NULL
;
3501 gfc_init_se (&se
, NULL
);
3505 CONSTRUCTOR_APPEND_ELT (node
, ss_string1
[k
], null_pointer_node
);
3506 CONSTRUCTOR_APPEND_ELT (node
, ss_string1_len
[k
], build_zero_cst (gfc_charlen_type_node
));
3510 gfc_conv_expr_reference (&se
, d
->low
);
3512 CONSTRUCTOR_APPEND_ELT (node
, ss_string1
[k
], se
.expr
);
3513 CONSTRUCTOR_APPEND_ELT (node
, ss_string1_len
[k
], se
.string_length
);
3516 if (d
->high
== NULL
)
3518 CONSTRUCTOR_APPEND_ELT (node
, ss_string2
[k
], null_pointer_node
);
3519 CONSTRUCTOR_APPEND_ELT (node
, ss_string2_len
[k
], build_zero_cst (gfc_charlen_type_node
));
3523 gfc_init_se (&se
, NULL
);
3524 gfc_conv_expr_reference (&se
, d
->high
);
3526 CONSTRUCTOR_APPEND_ELT (node
, ss_string2
[k
], se
.expr
);
3527 CONSTRUCTOR_APPEND_ELT (node
, ss_string2_len
[k
], se
.string_length
);
3530 CONSTRUCTOR_APPEND_ELT (node
, ss_target
[k
],
3531 build_int_cst (integer_type_node
, d
->n
));
3533 tmp
= build_constructor (select_struct
[k
], node
);
3534 CONSTRUCTOR_APPEND_ELT (inits
, NULL_TREE
, tmp
);
3537 type
= build_array_type (select_struct
[k
],
3538 build_index_type (size_int (n
-1)));
3540 init
= build_constructor (type
, inits
);
3541 TREE_CONSTANT (init
) = 1;
3542 TREE_STATIC (init
) = 1;
3543 /* Create a static variable to hold the jump table. */
3544 tmp
= gfc_create_var (type
, "jumptable");
3545 TREE_CONSTANT (tmp
) = 1;
3546 TREE_STATIC (tmp
) = 1;
3547 TREE_READONLY (tmp
) = 1;
3548 DECL_INITIAL (tmp
) = init
;
3551 /* Build the library call */
3552 init
= gfc_build_addr_expr (pvoid_type_node
, init
);
3554 if (code
->expr1
->ts
.kind
== 1)
3555 fndecl
= gfor_fndecl_select_string
;
3556 else if (code
->expr1
->ts
.kind
== 4)
3557 fndecl
= gfor_fndecl_select_string_char4
;
3561 tmp
= build_call_expr_loc (input_location
,
3563 build_int_cst (gfc_charlen_type_node
, n
),
3564 expr1se
.expr
, expr1se
.string_length
);
3565 case_num
= gfc_create_var (integer_type_node
, "case_num");
3566 gfc_add_modify (&block
, case_num
, tmp
);
3568 gfc_add_block_to_block (&block
, &expr1se
.post
);
3570 tmp
= gfc_finish_block (&body
);
3571 tmp
= fold_build2_loc (input_location
, SWITCH_EXPR
, NULL_TREE
,
3573 gfc_add_expr_to_block (&block
, tmp
);
3575 tmp
= build1_v (LABEL_EXPR
, end_label
);
3576 gfc_add_expr_to_block (&block
, tmp
);
3578 return gfc_finish_block (&block
);
3582 /* Translate the three variants of the SELECT CASE construct.
3584 SELECT CASEs with INTEGER case expressions can be translated to an
3585 equivalent GENERIC switch statement, and for LOGICAL case
3586 expressions we build one or two if-else compares.
3588 SELECT CASEs with CHARACTER case expressions are a whole different
3589 story, because they don't exist in GENERIC. So we sort them and
3590 do a binary search at runtime.
3592 Fortran has no BREAK statement, and it does not allow jumps from
3593 one case block to another. That makes things a lot easier for
3597 gfc_trans_select (gfc_code
* code
)
3603 gcc_assert (code
&& code
->expr1
);
3604 gfc_init_block (&block
);
3606 /* Build the exit label and hang it in. */
3607 exit_label
= gfc_build_label_decl (NULL_TREE
);
3608 code
->exit_label
= exit_label
;
3610 /* Empty SELECT constructs are legal. */
3611 if (code
->block
== NULL
)
3612 body
= build_empty_stmt (input_location
);
3614 /* Select the correct translation function. */
3616 switch (code
->expr1
->ts
.type
)
3619 body
= gfc_trans_logical_select (code
);
3623 body
= gfc_trans_integer_select (code
);
3627 body
= gfc_trans_character_select (code
);
3631 gfc_internal_error ("gfc_trans_select(): Bad type for case expr.");
3635 /* Build everything together. */
3636 gfc_add_expr_to_block (&block
, body
);
3637 gfc_add_expr_to_block (&block
, build1_v (LABEL_EXPR
, exit_label
));
3639 return gfc_finish_block (&block
);
3643 gfc_trans_select_type (gfc_code
* code
)
3649 gcc_assert (code
&& code
->expr1
);
3650 gfc_init_block (&block
);
3652 /* Build the exit label and hang it in. */
3653 exit_label
= gfc_build_label_decl (NULL_TREE
);
3654 code
->exit_label
= exit_label
;
3656 /* Empty SELECT constructs are legal. */
3657 if (code
->block
== NULL
)
3658 body
= build_empty_stmt (input_location
);
3660 body
= gfc_trans_select_type_cases (code
);
3662 /* Build everything together. */
3663 gfc_add_expr_to_block (&block
, body
);
3665 if (TREE_USED (exit_label
))
3666 gfc_add_expr_to_block (&block
, build1_v (LABEL_EXPR
, exit_label
));
3668 return gfc_finish_block (&block
);
3673 gfc_trans_select_rank_cases (gfc_code
* code
)
3687 gfc_start_block (&block
);
3689 /* Calculate the switch expression. */
3690 gfc_init_se (&se
, NULL
);
3691 gfc_conv_expr_descriptor (&se
, code
->expr1
);
3692 rank
= gfc_conv_descriptor_rank (se
.expr
);
3693 rank
= gfc_evaluate_now (rank
, &block
);
3694 symbol_attribute attr
= gfc_expr_attr (code
->expr1
);
3695 if (!attr
.pointer
&& !attr
.allocatable
)
3697 /* Special case for assumed-rank ('rank(*)', internally -1):
3698 rank = (rank == 0 || ubound[rank-1] != -1) ? rank : -1. */
3699 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
3700 rank
, build_int_cst (TREE_TYPE (rank
), 0));
3701 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
3702 fold_convert (gfc_array_index_type
, rank
),
3703 gfc_index_one_node
);
3704 tmp
= gfc_conv_descriptor_ubound_get (se
.expr
, tmp
);
3705 tmp
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
3706 tmp
, build_int_cst (TREE_TYPE (tmp
), -1));
3707 cond
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
3708 logical_type_node
, cond
, tmp
);
3709 tmp
= fold_build3_loc (input_location
, COND_EXPR
, TREE_TYPE (rank
),
3710 cond
, rank
, build_int_cst (TREE_TYPE (rank
), -1));
3711 rank
= gfc_evaluate_now (tmp
, &block
);
3713 TREE_USED (code
->exit_label
) = 0;
3716 for (c
= code
->block
; c
; c
= c
->block
)
3718 cp
= c
->ext
.block
.case_list
;
3720 /* Assume it's the default case. */
3724 /* Put the default case at the end. */
3725 if ((!def
&& !cp
->low
) || (def
&& cp
->low
))
3730 gfc_init_se (&cse
, NULL
);
3731 gfc_conv_expr_val (&cse
, cp
->low
);
3732 gfc_add_block_to_block (&block
, &cse
.pre
);
3736 gfc_init_block (&body
);
3738 /* Add the statements for this case. */
3739 tmp
= gfc_trans_code (c
->next
);
3740 gfc_add_expr_to_block (&body
, tmp
);
3742 /* Break to the end of the SELECT RANK construct. The default
3743 case just falls through. */
3746 TREE_USED (code
->exit_label
) = 1;
3747 tmp
= build1_v (GOTO_EXPR
, code
->exit_label
);
3748 gfc_add_expr_to_block (&body
, tmp
);
3751 tmp
= gfc_finish_block (&body
);
3753 if (low
!= NULL_TREE
)
3755 cond
= fold_build2_loc (input_location
, EQ_EXPR
,
3756 TREE_TYPE (rank
), rank
,
3757 fold_convert (TREE_TYPE (rank
), low
));
3758 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
3760 build_empty_stmt (input_location
));
3763 gfc_add_expr_to_block (&block
, tmp
);
3772 return gfc_finish_block (&block
);
3777 gfc_trans_select_rank (gfc_code
* code
)
3783 gcc_assert (code
&& code
->expr1
);
3784 gfc_init_block (&block
);
3786 /* Build the exit label and hang it in. */
3787 exit_label
= gfc_build_label_decl (NULL_TREE
);
3788 code
->exit_label
= exit_label
;
3790 /* Empty SELECT constructs are legal. */
3791 if (code
->block
== NULL
)
3792 body
= build_empty_stmt (input_location
);
3794 body
= gfc_trans_select_rank_cases (code
);
3796 /* Build everything together. */
3797 gfc_add_expr_to_block (&block
, body
);
3799 if (TREE_USED (exit_label
))
3800 gfc_add_expr_to_block (&block
, build1_v (LABEL_EXPR
, exit_label
));
3802 return gfc_finish_block (&block
);
3806 /* Traversal function to substitute a replacement symtree if the symbol
3807 in the expression is the same as that passed. f == 2 signals that
3808 that variable itself is not to be checked - only the references.
3809 This group of functions is used when the variable expression in a
3810 FORALL assignment has internal references. For example:
3811 FORALL (i = 1:4) p(p(i)) = i
3812 The only recourse here is to store a copy of 'p' for the index
3815 static gfc_symtree
*new_symtree
;
3816 static gfc_symtree
*old_symtree
;
3819 forall_replace (gfc_expr
*expr
, gfc_symbol
*sym
, int *f
)
3821 if (expr
->expr_type
!= EXPR_VARIABLE
)
3826 else if (expr
->symtree
->n
.sym
== sym
)
3827 expr
->symtree
= new_symtree
;
3833 forall_replace_symtree (gfc_expr
*e
, gfc_symbol
*sym
, int f
)
3835 gfc_traverse_expr (e
, sym
, forall_replace
, f
);
3839 forall_restore (gfc_expr
*expr
,
3840 gfc_symbol
*sym ATTRIBUTE_UNUSED
,
3841 int *f ATTRIBUTE_UNUSED
)
3843 if (expr
->expr_type
!= EXPR_VARIABLE
)
3846 if (expr
->symtree
== new_symtree
)
3847 expr
->symtree
= old_symtree
;
3853 forall_restore_symtree (gfc_expr
*e
)
3855 gfc_traverse_expr (e
, NULL
, forall_restore
, 0);
3859 forall_make_variable_temp (gfc_code
*c
, stmtblock_t
*pre
, stmtblock_t
*post
)
3864 gfc_symbol
*new_sym
;
3865 gfc_symbol
*old_sym
;
3869 /* Build a copy of the lvalue. */
3870 old_symtree
= c
->expr1
->symtree
;
3871 old_sym
= old_symtree
->n
.sym
;
3872 e
= gfc_lval_expr_from_sym (old_sym
);
3873 if (old_sym
->attr
.dimension
)
3875 gfc_init_se (&tse
, NULL
);
3876 gfc_conv_subref_array_arg (&tse
, e
, 0, INTENT_IN
, false);
3877 gfc_add_block_to_block (pre
, &tse
.pre
);
3878 gfc_add_block_to_block (post
, &tse
.post
);
3879 tse
.expr
= build_fold_indirect_ref_loc (input_location
, tse
.expr
);
3881 if (c
->expr1
->ref
->u
.ar
.type
!= AR_SECTION
)
3883 /* Use the variable offset for the temporary. */
3884 tmp
= gfc_conv_array_offset (old_sym
->backend_decl
);
3885 gfc_conv_descriptor_offset_set (pre
, tse
.expr
, tmp
);
3890 gfc_init_se (&tse
, NULL
);
3891 gfc_init_se (&rse
, NULL
);
3892 gfc_conv_expr (&rse
, e
);
3893 if (e
->ts
.type
== BT_CHARACTER
)
3895 tse
.string_length
= rse
.string_length
;
3896 tmp
= gfc_get_character_type_len (gfc_default_character_kind
,
3898 tse
.expr
= gfc_conv_string_tmp (&tse
, build_pointer_type (tmp
),
3900 gfc_add_block_to_block (pre
, &tse
.pre
);
3901 gfc_add_block_to_block (post
, &tse
.post
);
3905 tmp
= gfc_typenode_for_spec (&e
->ts
);
3906 tse
.expr
= gfc_create_var (tmp
, "temp");
3909 tmp
= gfc_trans_scalar_assign (&tse
, &rse
, e
->ts
,
3910 e
->expr_type
== EXPR_VARIABLE
, false);
3911 gfc_add_expr_to_block (pre
, tmp
);
3915 /* Create a new symbol to represent the lvalue. */
3916 new_sym
= gfc_new_symbol (old_sym
->name
, NULL
);
3917 new_sym
->ts
= old_sym
->ts
;
3918 new_sym
->attr
.referenced
= 1;
3919 new_sym
->attr
.temporary
= 1;
3920 new_sym
->attr
.dimension
= old_sym
->attr
.dimension
;
3921 new_sym
->attr
.flavor
= old_sym
->attr
.flavor
;
3923 /* Use the temporary as the backend_decl. */
3924 new_sym
->backend_decl
= tse
.expr
;
3926 /* Create a fake symtree for it. */
3928 new_symtree
= gfc_new_symtree (&root
, old_sym
->name
);
3929 new_symtree
->n
.sym
= new_sym
;
3930 gcc_assert (new_symtree
== root
);
3932 /* Go through the expression reference replacing the old_symtree
3934 forall_replace_symtree (c
->expr1
, old_sym
, 2);
3936 /* Now we have made this temporary, we might as well use it for
3937 the right hand side. */
3938 forall_replace_symtree (c
->expr2
, old_sym
, 1);
3942 /* Handles dependencies in forall assignments. */
3944 check_forall_dependencies (gfc_code
*c
, stmtblock_t
*pre
, stmtblock_t
*post
)
3951 lsym
= c
->expr1
->symtree
->n
.sym
;
3952 need_temp
= gfc_check_dependency (c
->expr1
, c
->expr2
, 0);
3954 /* Now check for dependencies within the 'variable'
3955 expression itself. These are treated by making a complete
3956 copy of variable and changing all the references to it
3957 point to the copy instead. Note that the shallow copy of
3958 the variable will not suffice for derived types with
3959 pointer components. We therefore leave these to their
3960 own devices. Likewise for allocatable components. */
3961 if (lsym
->ts
.type
== BT_DERIVED
3962 && (lsym
->ts
.u
.derived
->attr
.pointer_comp
3963 || lsym
->ts
.u
.derived
->attr
.alloc_comp
))
3967 if (find_forall_index (c
->expr1
, lsym
, 2))
3969 forall_make_variable_temp (c
, pre
, post
);
3973 /* Substrings with dependencies are treated in the same
3975 if (c
->expr1
->ts
.type
== BT_CHARACTER
3977 && c
->expr2
->expr_type
== EXPR_VARIABLE
3978 && lsym
== c
->expr2
->symtree
->n
.sym
)
3980 for (lref
= c
->expr1
->ref
; lref
; lref
= lref
->next
)
3981 if (lref
->type
== REF_SUBSTRING
)
3983 for (rref
= c
->expr2
->ref
; rref
; rref
= rref
->next
)
3984 if (rref
->type
== REF_SUBSTRING
)
3988 && gfc_dep_compare_expr (rref
->u
.ss
.start
, lref
->u
.ss
.start
) < 0)
3990 forall_make_variable_temp (c
, pre
, post
);
3999 cleanup_forall_symtrees (gfc_code
*c
)
4001 forall_restore_symtree (c
->expr1
);
4002 forall_restore_symtree (c
->expr2
);
4003 free (new_symtree
->n
.sym
);
4008 /* Generate the loops for a FORALL block, specified by FORALL_TMP. BODY
4009 is the contents of the FORALL block/stmt to be iterated. MASK_FLAG
4010 indicates whether we should generate code to test the FORALLs mask
4011 array. OUTER is the loop header to be used for initializing mask
4014 The generated loop format is:
4015 count = (end - start + step) / step
4028 gfc_trans_forall_loop (forall_info
*forall_tmp
, tree body
,
4029 int mask_flag
, stmtblock_t
*outer
)
4037 tree var
, start
, end
, step
;
4040 /* Initialize the mask index outside the FORALL nest. */
4041 if (mask_flag
&& forall_tmp
->mask
)
4042 gfc_add_modify (outer
, forall_tmp
->maskindex
, gfc_index_zero_node
);
4044 iter
= forall_tmp
->this_loop
;
4045 nvar
= forall_tmp
->nvar
;
4046 for (n
= 0; n
< nvar
; n
++)
4049 start
= iter
->start
;
4053 exit_label
= gfc_build_label_decl (NULL_TREE
);
4054 TREE_USED (exit_label
) = 1;
4056 /* The loop counter. */
4057 count
= gfc_create_var (TREE_TYPE (var
), "count");
4059 /* The body of the loop. */
4060 gfc_init_block (&block
);
4062 /* The exit condition. */
4063 cond
= fold_build2_loc (input_location
, LE_EXPR
, logical_type_node
,
4064 count
, build_int_cst (TREE_TYPE (count
), 0));
4066 /* PR 83064 means that we cannot use annot_expr_parallel_kind until
4067 the autoparallelizer can hande this. */
4068 if (forall_tmp
->do_concurrent
)
4069 cond
= build3 (ANNOTATE_EXPR
, TREE_TYPE (cond
), cond
,
4070 build_int_cst (integer_type_node
,
4071 annot_expr_ivdep_kind
),
4074 tmp
= build1_v (GOTO_EXPR
, exit_label
);
4075 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
4076 cond
, tmp
, build_empty_stmt (input_location
));
4077 gfc_add_expr_to_block (&block
, tmp
);
4079 /* The main loop body. */
4080 gfc_add_expr_to_block (&block
, body
);
4082 /* Increment the loop variable. */
4083 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (var
), var
,
4085 gfc_add_modify (&block
, var
, tmp
);
4087 /* Advance to the next mask element. Only do this for the
4089 if (n
== 0 && mask_flag
&& forall_tmp
->mask
)
4091 tree maskindex
= forall_tmp
->maskindex
;
4092 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
4093 maskindex
, gfc_index_one_node
);
4094 gfc_add_modify (&block
, maskindex
, tmp
);
4097 /* Decrement the loop counter. */
4098 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (var
), count
,
4099 build_int_cst (TREE_TYPE (var
), 1));
4100 gfc_add_modify (&block
, count
, tmp
);
4102 body
= gfc_finish_block (&block
);
4104 /* Loop var initialization. */
4105 gfc_init_block (&block
);
4106 gfc_add_modify (&block
, var
, start
);
4109 /* Initialize the loop counter. */
4110 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (var
), step
,
4112 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (var
), end
,
4114 tmp
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
, TREE_TYPE (var
),
4116 gfc_add_modify (&block
, count
, tmp
);
4118 /* The loop expression. */
4119 tmp
= build1_v (LOOP_EXPR
, body
);
4120 gfc_add_expr_to_block (&block
, tmp
);
4122 /* The exit label. */
4123 tmp
= build1_v (LABEL_EXPR
, exit_label
);
4124 gfc_add_expr_to_block (&block
, tmp
);
4126 body
= gfc_finish_block (&block
);
4133 /* Generate the body and loops according to MASK_FLAG. If MASK_FLAG
4134 is nonzero, the body is controlled by all masks in the forall nest.
4135 Otherwise, the innermost loop is not controlled by it's mask. This
4136 is used for initializing that mask. */
4139 gfc_trans_nested_forall_loop (forall_info
* nested_forall_info
, tree body
,
4144 forall_info
*forall_tmp
;
4145 tree mask
, maskindex
;
4147 gfc_start_block (&header
);
4149 forall_tmp
= nested_forall_info
;
4150 while (forall_tmp
!= NULL
)
4152 /* Generate body with masks' control. */
4155 mask
= forall_tmp
->mask
;
4156 maskindex
= forall_tmp
->maskindex
;
4158 /* If a mask was specified make the assignment conditional. */
4161 tmp
= gfc_build_array_ref (mask
, maskindex
, NULL
);
4162 body
= build3_v (COND_EXPR
, tmp
, body
,
4163 build_empty_stmt (input_location
));
4166 body
= gfc_trans_forall_loop (forall_tmp
, body
, mask_flag
, &header
);
4167 forall_tmp
= forall_tmp
->prev_nest
;
4171 gfc_add_expr_to_block (&header
, body
);
4172 return gfc_finish_block (&header
);
4176 /* Allocate data for holding a temporary array. Returns either a local
4177 temporary array or a pointer variable. */
4180 gfc_do_allocate (tree bytesize
, tree size
, tree
* pdata
, stmtblock_t
* pblock
,
4187 if (INTEGER_CST_P (size
))
4188 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
4189 size
, gfc_index_one_node
);
4193 type
= build_range_type (gfc_array_index_type
, gfc_index_zero_node
, tmp
);
4194 type
= build_array_type (elem_type
, type
);
4195 if (gfc_can_put_var_on_stack (bytesize
) && INTEGER_CST_P (size
))
4197 tmpvar
= gfc_create_var (type
, "temp");
4202 tmpvar
= gfc_create_var (build_pointer_type (type
), "temp");
4203 *pdata
= convert (pvoid_type_node
, tmpvar
);
4205 tmp
= gfc_call_malloc (pblock
, TREE_TYPE (tmpvar
), bytesize
);
4206 gfc_add_modify (pblock
, tmpvar
, tmp
);
4212 /* Generate codes to copy the temporary to the actual lhs. */
4215 generate_loop_for_temp_to_lhs (gfc_expr
*expr
, tree tmp1
, tree count3
,
4217 gfc_ss
*lss
, gfc_ss
*rss
,
4218 tree wheremask
, bool invert
)
4220 stmtblock_t block
, body1
;
4227 (void) rss
; /* TODO: unused. */
4229 gfc_start_block (&block
);
4231 gfc_init_se (&rse
, NULL
);
4232 gfc_init_se (&lse
, NULL
);
4234 if (lss
== gfc_ss_terminator
)
4236 gfc_init_block (&body1
);
4237 gfc_conv_expr (&lse
, expr
);
4238 rse
.expr
= gfc_build_array_ref (tmp1
, count1
, NULL
);
4242 /* Initialize the loop. */
4243 gfc_init_loopinfo (&loop
);
4245 /* We may need LSS to determine the shape of the expression. */
4246 gfc_add_ss_to_loop (&loop
, lss
);
4248 gfc_conv_ss_startstride (&loop
);
4249 gfc_conv_loop_setup (&loop
, &expr
->where
);
4251 gfc_mark_ss_chain_used (lss
, 1);
4252 /* Start the loop body. */
4253 gfc_start_scalarized_body (&loop
, &body1
);
4255 /* Translate the expression. */
4256 gfc_copy_loopinfo_to_se (&lse
, &loop
);
4258 gfc_conv_expr (&lse
, expr
);
4260 /* Form the expression of the temporary. */
4261 rse
.expr
= gfc_build_array_ref (tmp1
, count1
, NULL
);
4264 /* Use the scalar assignment. */
4265 rse
.string_length
= lse
.string_length
;
4266 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
,
4267 expr
->expr_type
== EXPR_VARIABLE
, false);
4269 /* Form the mask expression according to the mask tree list. */
4272 wheremaskexpr
= gfc_build_array_ref (wheremask
, count3
, NULL
);
4274 wheremaskexpr
= fold_build1_loc (input_location
, TRUTH_NOT_EXPR
,
4275 TREE_TYPE (wheremaskexpr
),
4277 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
4279 build_empty_stmt (input_location
));
4282 gfc_add_expr_to_block (&body1
, tmp
);
4284 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (count1
),
4285 count1
, gfc_index_one_node
);
4286 gfc_add_modify (&body1
, count1
, tmp
);
4288 if (lss
== gfc_ss_terminator
)
4289 gfc_add_block_to_block (&block
, &body1
);
4292 /* Increment count3. */
4295 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
4296 gfc_array_index_type
,
4297 count3
, gfc_index_one_node
);
4298 gfc_add_modify (&body1
, count3
, tmp
);
4301 /* Generate the copying loops. */
4302 gfc_trans_scalarizing_loops (&loop
, &body1
);
4304 gfc_add_block_to_block (&block
, &loop
.pre
);
4305 gfc_add_block_to_block (&block
, &loop
.post
);
4307 gfc_cleanup_loop (&loop
);
4308 /* TODO: Reuse lss and rss when copying temp->lhs. Need to be careful
4309 as tree nodes in SS may not be valid in different scope. */
4312 tmp
= gfc_finish_block (&block
);
4317 /* Generate codes to copy rhs to the temporary. TMP1 is the address of
4318 temporary, LSS and RSS are formed in function compute_inner_temp_size(),
4319 and should not be freed. WHEREMASK is the conditional execution mask
4320 whose sense may be inverted by INVERT. */
4323 generate_loop_for_rhs_to_temp (gfc_expr
*expr2
, tree tmp1
, tree count3
,
4324 tree count1
, gfc_ss
*lss
, gfc_ss
*rss
,
4325 tree wheremask
, bool invert
)
4327 stmtblock_t block
, body1
;
4334 gfc_start_block (&block
);
4336 gfc_init_se (&rse
, NULL
);
4337 gfc_init_se (&lse
, NULL
);
4339 if (lss
== gfc_ss_terminator
)
4341 gfc_init_block (&body1
);
4342 gfc_conv_expr (&rse
, expr2
);
4343 lse
.expr
= gfc_build_array_ref (tmp1
, count1
, NULL
);
4347 /* Initialize the loop. */
4348 gfc_init_loopinfo (&loop
);
4350 /* We may need LSS to determine the shape of the expression. */
4351 gfc_add_ss_to_loop (&loop
, lss
);
4352 gfc_add_ss_to_loop (&loop
, rss
);
4354 gfc_conv_ss_startstride (&loop
);
4355 gfc_conv_loop_setup (&loop
, &expr2
->where
);
4357 gfc_mark_ss_chain_used (rss
, 1);
4358 /* Start the loop body. */
4359 gfc_start_scalarized_body (&loop
, &body1
);
4361 /* Translate the expression. */
4362 gfc_copy_loopinfo_to_se (&rse
, &loop
);
4364 gfc_conv_expr (&rse
, expr2
);
4366 /* Form the expression of the temporary. */
4367 lse
.expr
= gfc_build_array_ref (tmp1
, count1
, NULL
);
4370 /* Use the scalar assignment. */
4371 lse
.string_length
= rse
.string_length
;
4372 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr2
->ts
,
4373 expr2
->expr_type
== EXPR_VARIABLE
, false);
4375 /* Form the mask expression according to the mask tree list. */
4378 wheremaskexpr
= gfc_build_array_ref (wheremask
, count3
, NULL
);
4380 wheremaskexpr
= fold_build1_loc (input_location
, TRUTH_NOT_EXPR
,
4381 TREE_TYPE (wheremaskexpr
),
4383 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
4385 build_empty_stmt (input_location
));
4388 gfc_add_expr_to_block (&body1
, tmp
);
4390 if (lss
== gfc_ss_terminator
)
4392 gfc_add_block_to_block (&block
, &body1
);
4394 /* Increment count1. */
4395 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (count1
),
4396 count1
, gfc_index_one_node
);
4397 gfc_add_modify (&block
, count1
, tmp
);
4401 /* Increment count1. */
4402 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
4403 count1
, gfc_index_one_node
);
4404 gfc_add_modify (&body1
, count1
, tmp
);
4406 /* Increment count3. */
4409 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
4410 gfc_array_index_type
,
4411 count3
, gfc_index_one_node
);
4412 gfc_add_modify (&body1
, count3
, tmp
);
4415 /* Generate the copying loops. */
4416 gfc_trans_scalarizing_loops (&loop
, &body1
);
4418 gfc_add_block_to_block (&block
, &loop
.pre
);
4419 gfc_add_block_to_block (&block
, &loop
.post
);
4421 gfc_cleanup_loop (&loop
);
4422 /* TODO: Reuse lss and rss when copying temp->lhs. Need to be careful
4423 as tree nodes in SS may not be valid in different scope. */
4426 tmp
= gfc_finish_block (&block
);
4431 /* Calculate the size of temporary needed in the assignment inside forall.
4432 LSS and RSS are filled in this function. */
4435 compute_inner_temp_size (gfc_expr
*expr1
, gfc_expr
*expr2
,
4436 stmtblock_t
* pblock
,
4437 gfc_ss
**lss
, gfc_ss
**rss
)
4445 *lss
= gfc_walk_expr (expr1
);
4448 size
= gfc_index_one_node
;
4449 if (*lss
!= gfc_ss_terminator
)
4451 gfc_init_loopinfo (&loop
);
4453 /* Walk the RHS of the expression. */
4454 *rss
= gfc_walk_expr (expr2
);
4455 if (*rss
== gfc_ss_terminator
)
4456 /* The rhs is scalar. Add a ss for the expression. */
4457 *rss
= gfc_get_scalar_ss (gfc_ss_terminator
, expr2
);
4459 /* Associate the SS with the loop. */
4460 gfc_add_ss_to_loop (&loop
, *lss
);
4461 /* We don't actually need to add the rhs at this point, but it might
4462 make guessing the loop bounds a bit easier. */
4463 gfc_add_ss_to_loop (&loop
, *rss
);
4465 /* We only want the shape of the expression, not rest of the junk
4466 generated by the scalarizer. */
4467 loop
.array_parameter
= 1;
4469 /* Calculate the bounds of the scalarization. */
4470 save_flag
= gfc_option
.rtcheck
;
4471 gfc_option
.rtcheck
&= ~GFC_RTCHECK_BOUNDS
;
4472 gfc_conv_ss_startstride (&loop
);
4473 gfc_option
.rtcheck
= save_flag
;
4474 gfc_conv_loop_setup (&loop
, &expr2
->where
);
4476 /* Figure out how many elements we need. */
4477 for (i
= 0; i
< loop
.dimen
; i
++)
4479 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4480 gfc_array_index_type
,
4481 gfc_index_one_node
, loop
.from
[i
]);
4482 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
4483 gfc_array_index_type
, tmp
, loop
.to
[i
]);
4484 size
= fold_build2_loc (input_location
, MULT_EXPR
,
4485 gfc_array_index_type
, size
, tmp
);
4487 gfc_add_block_to_block (pblock
, &loop
.pre
);
4488 size
= gfc_evaluate_now (size
, pblock
);
4489 gfc_add_block_to_block (pblock
, &loop
.post
);
4491 /* TODO: write a function that cleans up a loopinfo without freeing
4492 the SS chains. Currently a NOP. */
4499 /* Calculate the overall iterator number of the nested forall construct.
4500 This routine actually calculates the number of times the body of the
4501 nested forall specified by NESTED_FORALL_INFO is executed and multiplies
4502 that by the expression INNER_SIZE. The BLOCK argument specifies the
4503 block in which to calculate the result, and the optional INNER_SIZE_BODY
4504 argument contains any statements that need to executed (inside the loop)
4505 to initialize or calculate INNER_SIZE. */
4508 compute_overall_iter_number (forall_info
*nested_forall_info
, tree inner_size
,
4509 stmtblock_t
*inner_size_body
, stmtblock_t
*block
)
4511 forall_info
*forall_tmp
= nested_forall_info
;
4515 /* We can eliminate the innermost unconditional loops with constant
4517 if (INTEGER_CST_P (inner_size
))
4520 && !forall_tmp
->mask
4521 && INTEGER_CST_P (forall_tmp
->size
))
4523 inner_size
= fold_build2_loc (input_location
, MULT_EXPR
,
4524 gfc_array_index_type
,
4525 inner_size
, forall_tmp
->size
);
4526 forall_tmp
= forall_tmp
->prev_nest
;
4529 /* If there are no loops left, we have our constant result. */
4534 /* Otherwise, create a temporary variable to compute the result. */
4535 number
= gfc_create_var (gfc_array_index_type
, "num");
4536 gfc_add_modify (block
, number
, gfc_index_zero_node
);
4538 gfc_start_block (&body
);
4539 if (inner_size_body
)
4540 gfc_add_block_to_block (&body
, inner_size_body
);
4542 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
4543 gfc_array_index_type
, number
, inner_size
);
4546 gfc_add_modify (&body
, number
, tmp
);
4547 tmp
= gfc_finish_block (&body
);
4549 /* Generate loops. */
4550 if (forall_tmp
!= NULL
)
4551 tmp
= gfc_trans_nested_forall_loop (forall_tmp
, tmp
, 1);
4553 gfc_add_expr_to_block (block
, tmp
);
4559 /* Allocate temporary for forall construct. SIZE is the size of temporary
4560 needed. PTEMP1 is returned for space free. */
4563 allocate_temp_for_forall_nest_1 (tree type
, tree size
, stmtblock_t
* block
,
4570 unit
= fold_convert (gfc_array_index_type
, TYPE_SIZE_UNIT (type
));
4571 if (!integer_onep (unit
))
4572 bytesize
= fold_build2_loc (input_location
, MULT_EXPR
,
4573 gfc_array_index_type
, size
, unit
);
4578 tmp
= gfc_do_allocate (bytesize
, size
, ptemp1
, block
, type
);
4581 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
4586 /* Allocate temporary for forall construct according to the information in
4587 nested_forall_info. INNER_SIZE is the size of temporary needed in the
4588 assignment inside forall. PTEMP1 is returned for space free. */
4591 allocate_temp_for_forall_nest (forall_info
* nested_forall_info
, tree type
,
4592 tree inner_size
, stmtblock_t
* inner_size_body
,
4593 stmtblock_t
* block
, tree
* ptemp1
)
4597 /* Calculate the total size of temporary needed in forall construct. */
4598 size
= compute_overall_iter_number (nested_forall_info
, inner_size
,
4599 inner_size_body
, block
);
4601 return allocate_temp_for_forall_nest_1 (type
, size
, block
, ptemp1
);
4605 /* Handle assignments inside forall which need temporary.
4607 forall (i=start:end:stride; maskexpr)
4610 (where e,f<i> are arbitrary expressions possibly involving i
4611 and there is a dependency between e<i> and f<i>)
4613 masktmp(:) = maskexpr(:)
4618 for (i = start; i <= end; i += stride)
4622 for (i = start; i <= end; i += stride)
4624 if (masktmp[maskindex++])
4625 tmp[count1++] = f<i>
4629 for (i = start; i <= end; i += stride)
4631 if (masktmp[maskindex++])
4632 e<i> = tmp[count1++]
4637 gfc_trans_assign_need_temp (gfc_expr
* expr1
, gfc_expr
* expr2
,
4638 tree wheremask
, bool invert
,
4639 forall_info
* nested_forall_info
,
4640 stmtblock_t
* block
)
4648 stmtblock_t inner_size_body
;
4650 /* Create vars. count1 is the current iterator number of the nested
4652 count1
= gfc_create_var (gfc_array_index_type
, "count1");
4654 /* Count is the wheremask index. */
4657 count
= gfc_create_var (gfc_array_index_type
, "count");
4658 gfc_add_modify (block
, count
, gfc_index_zero_node
);
4663 /* Initialize count1. */
4664 gfc_add_modify (block
, count1
, gfc_index_zero_node
);
4666 /* Calculate the size of temporary needed in the assignment. Return loop, lss
4667 and rss which are used in function generate_loop_for_rhs_to_temp(). */
4668 /* The type of LHS. Used in function allocate_temp_for_forall_nest */
4669 if (expr1
->ts
.type
== BT_CHARACTER
)
4672 if (expr1
->ref
&& expr1
->ref
->type
== REF_SUBSTRING
)
4675 gfc_init_se (&ssse
, NULL
);
4676 gfc_conv_expr (&ssse
, expr1
);
4677 type
= gfc_get_character_type_len (gfc_default_character_kind
,
4678 ssse
.string_length
);
4682 if (!expr1
->ts
.u
.cl
->backend_decl
)
4685 gcc_assert (expr1
->ts
.u
.cl
->length
);
4686 gfc_init_se (&tse
, NULL
);
4687 gfc_conv_expr (&tse
, expr1
->ts
.u
.cl
->length
);
4688 expr1
->ts
.u
.cl
->backend_decl
= tse
.expr
;
4690 type
= gfc_get_character_type_len (gfc_default_character_kind
,
4691 expr1
->ts
.u
.cl
->backend_decl
);
4695 type
= gfc_typenode_for_spec (&expr1
->ts
);
4697 gfc_init_block (&inner_size_body
);
4698 inner_size
= compute_inner_temp_size (expr1
, expr2
, &inner_size_body
,
4701 /* Allocate temporary for nested forall construct according to the
4702 information in nested_forall_info and inner_size. */
4703 tmp1
= allocate_temp_for_forall_nest (nested_forall_info
, type
, inner_size
,
4704 &inner_size_body
, block
, &ptemp1
);
4706 /* Generate codes to copy rhs to the temporary . */
4707 tmp
= generate_loop_for_rhs_to_temp (expr2
, tmp1
, count
, count1
, lss
, rss
,
4710 /* Generate body and loops according to the information in
4711 nested_forall_info. */
4712 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, tmp
, 1);
4713 gfc_add_expr_to_block (block
, tmp
);
4716 gfc_add_modify (block
, count1
, gfc_index_zero_node
);
4720 gfc_add_modify (block
, count
, gfc_index_zero_node
);
4722 /* TODO: Second call to compute_inner_temp_size to initialize lss and
4723 rss; there must be a better way. */
4724 inner_size
= compute_inner_temp_size (expr1
, expr2
, &inner_size_body
,
4727 /* Generate codes to copy the temporary to lhs. */
4728 tmp
= generate_loop_for_temp_to_lhs (expr1
, tmp1
, count
, count1
,
4732 /* Generate body and loops according to the information in
4733 nested_forall_info. */
4734 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, tmp
, 1);
4735 gfc_add_expr_to_block (block
, tmp
);
4739 /* Free the temporary. */
4740 tmp
= gfc_call_free (ptemp1
);
4741 gfc_add_expr_to_block (block
, tmp
);
4746 /* Translate pointer assignment inside FORALL which need temporary. */
4749 gfc_trans_pointer_assign_need_temp (gfc_expr
* expr1
, gfc_expr
* expr2
,
4750 forall_info
* nested_forall_info
,
4751 stmtblock_t
* block
)
4758 gfc_array_info
*info
;
4765 tree tmp
, tmp1
, ptemp1
;
4767 count
= gfc_create_var (gfc_array_index_type
, "count");
4768 gfc_add_modify (block
, count
, gfc_index_zero_node
);
4770 inner_size
= gfc_index_one_node
;
4771 lss
= gfc_walk_expr (expr1
);
4772 rss
= gfc_walk_expr (expr2
);
4773 if (lss
== gfc_ss_terminator
)
4775 type
= gfc_typenode_for_spec (&expr1
->ts
);
4776 type
= build_pointer_type (type
);
4778 /* Allocate temporary for nested forall construct according to the
4779 information in nested_forall_info and inner_size. */
4780 tmp1
= allocate_temp_for_forall_nest (nested_forall_info
, type
,
4781 inner_size
, NULL
, block
, &ptemp1
);
4782 gfc_start_block (&body
);
4783 gfc_init_se (&lse
, NULL
);
4784 lse
.expr
= gfc_build_array_ref (tmp1
, count
, NULL
);
4785 gfc_init_se (&rse
, NULL
);
4786 rse
.want_pointer
= 1;
4787 gfc_conv_expr (&rse
, expr2
);
4788 gfc_add_block_to_block (&body
, &rse
.pre
);
4789 gfc_add_modify (&body
, lse
.expr
,
4790 fold_convert (TREE_TYPE (lse
.expr
), rse
.expr
));
4791 gfc_add_block_to_block (&body
, &rse
.post
);
4793 /* Increment count. */
4794 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
4795 count
, gfc_index_one_node
);
4796 gfc_add_modify (&body
, count
, tmp
);
4798 tmp
= gfc_finish_block (&body
);
4800 /* Generate body and loops according to the information in
4801 nested_forall_info. */
4802 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, tmp
, 1);
4803 gfc_add_expr_to_block (block
, tmp
);
4806 gfc_add_modify (block
, count
, gfc_index_zero_node
);
4808 gfc_start_block (&body
);
4809 gfc_init_se (&lse
, NULL
);
4810 gfc_init_se (&rse
, NULL
);
4811 rse
.expr
= gfc_build_array_ref (tmp1
, count
, NULL
);
4812 lse
.want_pointer
= 1;
4813 gfc_conv_expr (&lse
, expr1
);
4814 gfc_add_block_to_block (&body
, &lse
.pre
);
4815 gfc_add_modify (&body
, lse
.expr
, rse
.expr
);
4816 gfc_add_block_to_block (&body
, &lse
.post
);
4817 /* Increment count. */
4818 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
4819 count
, gfc_index_one_node
);
4820 gfc_add_modify (&body
, count
, tmp
);
4821 tmp
= gfc_finish_block (&body
);
4823 /* Generate body and loops according to the information in
4824 nested_forall_info. */
4825 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, tmp
, 1);
4826 gfc_add_expr_to_block (block
, tmp
);
4830 gfc_init_loopinfo (&loop
);
4832 /* Associate the SS with the loop. */
4833 gfc_add_ss_to_loop (&loop
, rss
);
4835 /* Setup the scalarizing loops and bounds. */
4836 gfc_conv_ss_startstride (&loop
);
4838 gfc_conv_loop_setup (&loop
, &expr2
->where
);
4840 info
= &rss
->info
->data
.array
;
4841 desc
= info
->descriptor
;
4843 /* Make a new descriptor. */
4844 parmtype
= gfc_get_element_type (TREE_TYPE (desc
));
4845 parmtype
= gfc_get_array_type_bounds (parmtype
, loop
.dimen
, 0,
4846 loop
.from
, loop
.to
, 1,
4847 GFC_ARRAY_UNKNOWN
, true);
4849 /* Allocate temporary for nested forall construct. */
4850 tmp1
= allocate_temp_for_forall_nest (nested_forall_info
, parmtype
,
4851 inner_size
, NULL
, block
, &ptemp1
);
4852 gfc_start_block (&body
);
4853 gfc_init_se (&lse
, NULL
);
4854 lse
.expr
= gfc_build_array_ref (tmp1
, count
, NULL
);
4855 lse
.direct_byref
= 1;
4856 gfc_conv_expr_descriptor (&lse
, expr2
);
4858 gfc_add_block_to_block (&body
, &lse
.pre
);
4859 gfc_add_block_to_block (&body
, &lse
.post
);
4861 /* Increment count. */
4862 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
4863 count
, gfc_index_one_node
);
4864 gfc_add_modify (&body
, count
, tmp
);
4866 tmp
= gfc_finish_block (&body
);
4868 /* Generate body and loops according to the information in
4869 nested_forall_info. */
4870 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, tmp
, 1);
4871 gfc_add_expr_to_block (block
, tmp
);
4874 gfc_add_modify (block
, count
, gfc_index_zero_node
);
4876 parm
= gfc_build_array_ref (tmp1
, count
, NULL
);
4877 gfc_init_se (&lse
, NULL
);
4878 gfc_conv_expr_descriptor (&lse
, expr1
);
4879 gfc_add_modify (&lse
.pre
, lse
.expr
, parm
);
4880 gfc_start_block (&body
);
4881 gfc_add_block_to_block (&body
, &lse
.pre
);
4882 gfc_add_block_to_block (&body
, &lse
.post
);
4884 /* Increment count. */
4885 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
4886 count
, gfc_index_one_node
);
4887 gfc_add_modify (&body
, count
, tmp
);
4889 tmp
= gfc_finish_block (&body
);
4891 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, tmp
, 1);
4892 gfc_add_expr_to_block (block
, tmp
);
4894 /* Free the temporary. */
4897 tmp
= gfc_call_free (ptemp1
);
4898 gfc_add_expr_to_block (block
, tmp
);
4903 /* FORALL and WHERE statements are really nasty, especially when you nest
4904 them. All the rhs of a forall assignment must be evaluated before the
4905 actual assignments are performed. Presumably this also applies to all the
4906 assignments in an inner where statement. */
4908 /* Generate code for a FORALL statement. Any temporaries are allocated as a
4909 linear array, relying on the fact that we process in the same order in all
4912 forall (i=start:end:stride; maskexpr)
4916 (where e,f,g,h<i> are arbitrary expressions possibly involving i)
4918 count = ((end + 1 - start) / stride)
4919 masktmp(:) = maskexpr(:)
4922 for (i = start; i <= end; i += stride)
4924 if (masktmp[maskindex++])
4928 for (i = start; i <= end; i += stride)
4930 if (masktmp[maskindex++])
4934 Note that this code only works when there are no dependencies.
4935 Forall loop with array assignments and data dependencies are a real pain,
4936 because the size of the temporary cannot always be determined before the
4937 loop is executed. This problem is compounded by the presence of nested
4942 gfc_trans_forall_1 (gfc_code
* code
, forall_info
* nested_forall_info
)
4959 tree cycle_label
= NULL_TREE
;
4963 gfc_forall_iterator
*fa
;
4966 gfc_saved_var
*saved_vars
;
4967 iter_info
*this_forall
;
4971 /* Do nothing if the mask is false. */
4973 && code
->expr1
->expr_type
== EXPR_CONSTANT
4974 && !code
->expr1
->value
.logical
)
4975 return build_empty_stmt (input_location
);
4978 /* Count the FORALL index number. */
4979 for (fa
= code
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
4983 /* Allocate the space for var, start, end, step, varexpr. */
4984 var
= XCNEWVEC (tree
, nvar
);
4985 start
= XCNEWVEC (tree
, nvar
);
4986 end
= XCNEWVEC (tree
, nvar
);
4987 step
= XCNEWVEC (tree
, nvar
);
4988 varexpr
= XCNEWVEC (gfc_expr
*, nvar
);
4989 saved_vars
= XCNEWVEC (gfc_saved_var
, nvar
);
4991 /* Allocate the space for info. */
4992 info
= XCNEW (forall_info
);
4994 gfc_start_block (&pre
);
4995 gfc_init_block (&post
);
4996 gfc_init_block (&block
);
4999 for (fa
= code
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
5001 gfc_symbol
*sym
= fa
->var
->symtree
->n
.sym
;
5003 /* Allocate space for this_forall. */
5004 this_forall
= XCNEW (iter_info
);
5006 /* Create a temporary variable for the FORALL index. */
5007 tmp
= gfc_typenode_for_spec (&sym
->ts
);
5008 var
[n
] = gfc_create_var (tmp
, sym
->name
);
5009 gfc_shadow_sym (sym
, var
[n
], &saved_vars
[n
]);
5011 /* Record it in this_forall. */
5012 this_forall
->var
= var
[n
];
5014 /* Replace the index symbol's backend_decl with the temporary decl. */
5015 sym
->backend_decl
= var
[n
];
5017 /* Work out the start, end and stride for the loop. */
5018 gfc_init_se (&se
, NULL
);
5019 gfc_conv_expr_val (&se
, fa
->start
);
5020 /* Record it in this_forall. */
5021 this_forall
->start
= se
.expr
;
5022 gfc_add_block_to_block (&block
, &se
.pre
);
5025 gfc_init_se (&se
, NULL
);
5026 gfc_conv_expr_val (&se
, fa
->end
);
5027 /* Record it in this_forall. */
5028 this_forall
->end
= se
.expr
;
5029 gfc_make_safe_expr (&se
);
5030 gfc_add_block_to_block (&block
, &se
.pre
);
5033 gfc_init_se (&se
, NULL
);
5034 gfc_conv_expr_val (&se
, fa
->stride
);
5035 /* Record it in this_forall. */
5036 this_forall
->step
= se
.expr
;
5037 gfc_make_safe_expr (&se
);
5038 gfc_add_block_to_block (&block
, &se
.pre
);
5041 /* Set the NEXT field of this_forall to NULL. */
5042 this_forall
->next
= NULL
;
5043 /* Link this_forall to the info construct. */
5044 if (info
->this_loop
)
5046 iter_info
*iter_tmp
= info
->this_loop
;
5047 while (iter_tmp
->next
!= NULL
)
5048 iter_tmp
= iter_tmp
->next
;
5049 iter_tmp
->next
= this_forall
;
5052 info
->this_loop
= this_forall
;
5058 /* Calculate the size needed for the current forall level. */
5059 size
= gfc_index_one_node
;
5060 for (n
= 0; n
< nvar
; n
++)
5062 /* size = (end + step - start) / step. */
5063 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (start
[n
]),
5065 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (end
[n
]),
5067 tmp
= fold_build2_loc (input_location
, FLOOR_DIV_EXPR
, TREE_TYPE (tmp
),
5069 tmp
= convert (gfc_array_index_type
, tmp
);
5071 size
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
5075 /* Record the nvar and size of current forall level. */
5081 /* If the mask is .true., consider the FORALL unconditional. */
5082 if (code
->expr1
->expr_type
== EXPR_CONSTANT
5083 && code
->expr1
->value
.logical
)
5091 /* First we need to allocate the mask. */
5094 /* As the mask array can be very big, prefer compact boolean types. */
5095 tree mask_type
= gfc_get_logical_type (gfc_logical_kinds
[0].kind
);
5096 mask
= allocate_temp_for_forall_nest (nested_forall_info
, mask_type
,
5097 size
, NULL
, &block
, &pmask
);
5098 maskindex
= gfc_create_var_np (gfc_array_index_type
, "mi");
5100 /* Record them in the info structure. */
5101 info
->maskindex
= maskindex
;
5106 /* No mask was specified. */
5107 maskindex
= NULL_TREE
;
5108 mask
= pmask
= NULL_TREE
;
5111 /* Link the current forall level to nested_forall_info. */
5112 info
->prev_nest
= nested_forall_info
;
5113 nested_forall_info
= info
;
5115 /* Copy the mask into a temporary variable if required.
5116 For now we assume a mask temporary is needed. */
5119 /* As the mask array can be very big, prefer compact boolean types. */
5120 tree mask_type
= gfc_get_logical_type (gfc_logical_kinds
[0].kind
);
5122 gfc_add_modify (&block
, maskindex
, gfc_index_zero_node
);
5124 /* Start of mask assignment loop body. */
5125 gfc_start_block (&body
);
5127 /* Evaluate the mask expression. */
5128 gfc_init_se (&se
, NULL
);
5129 gfc_conv_expr_val (&se
, code
->expr1
);
5130 gfc_add_block_to_block (&body
, &se
.pre
);
5132 /* Store the mask. */
5133 se
.expr
= convert (mask_type
, se
.expr
);
5135 tmp
= gfc_build_array_ref (mask
, maskindex
, NULL
);
5136 gfc_add_modify (&body
, tmp
, se
.expr
);
5138 /* Advance to the next mask element. */
5139 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
5140 maskindex
, gfc_index_one_node
);
5141 gfc_add_modify (&body
, maskindex
, tmp
);
5143 /* Generate the loops. */
5144 tmp
= gfc_finish_block (&body
);
5145 tmp
= gfc_trans_nested_forall_loop (info
, tmp
, 0);
5146 gfc_add_expr_to_block (&block
, tmp
);
5149 if (code
->op
== EXEC_DO_CONCURRENT
)
5151 gfc_init_block (&body
);
5152 cycle_label
= gfc_build_label_decl (NULL_TREE
);
5153 code
->cycle_label
= cycle_label
;
5154 tmp
= gfc_trans_code (code
->block
->next
);
5155 gfc_add_expr_to_block (&body
, tmp
);
5157 if (TREE_USED (cycle_label
))
5159 tmp
= build1_v (LABEL_EXPR
, cycle_label
);
5160 gfc_add_expr_to_block (&body
, tmp
);
5163 tmp
= gfc_finish_block (&body
);
5164 nested_forall_info
->do_concurrent
= true;
5165 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, tmp
, 1);
5166 gfc_add_expr_to_block (&block
, tmp
);
5170 c
= code
->block
->next
;
5172 /* TODO: loop merging in FORALL statements. */
5173 /* Now that we've got a copy of the mask, generate the assignment loops. */
5179 /* A scalar or array assignment. DO the simple check for
5180 lhs to rhs dependencies. These make a temporary for the
5181 rhs and form a second forall block to copy to variable. */
5182 need_temp
= check_forall_dependencies(c
, &pre
, &post
);
5184 /* Temporaries due to array assignment data dependencies introduce
5185 no end of problems. */
5186 if (need_temp
|| flag_test_forall_temp
)
5187 gfc_trans_assign_need_temp (c
->expr1
, c
->expr2
, NULL
, false,
5188 nested_forall_info
, &block
);
5191 /* Use the normal assignment copying routines. */
5192 assign
= gfc_trans_assignment (c
->expr1
, c
->expr2
, false, true);
5194 /* Generate body and loops. */
5195 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
,
5197 gfc_add_expr_to_block (&block
, tmp
);
5200 /* Cleanup any temporary symtrees that have been made to deal
5201 with dependencies. */
5203 cleanup_forall_symtrees (c
);
5208 /* Translate WHERE or WHERE construct nested in FORALL. */
5209 gfc_trans_where_2 (c
, NULL
, false, nested_forall_info
, &block
);
5212 /* Pointer assignment inside FORALL. */
5213 case EXEC_POINTER_ASSIGN
:
5214 need_temp
= gfc_check_dependency (c
->expr1
, c
->expr2
, 0);
5215 /* Avoid cases where a temporary would never be needed and where
5216 the temp code is guaranteed to fail. */
5218 || (flag_test_forall_temp
5219 && c
->expr2
->expr_type
!= EXPR_CONSTANT
5220 && c
->expr2
->expr_type
!= EXPR_NULL
))
5221 gfc_trans_pointer_assign_need_temp (c
->expr1
, c
->expr2
,
5222 nested_forall_info
, &block
);
5225 /* Use the normal assignment copying routines. */
5226 assign
= gfc_trans_pointer_assignment (c
->expr1
, c
->expr2
);
5228 /* Generate body and loops. */
5229 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
,
5231 gfc_add_expr_to_block (&block
, tmp
);
5236 tmp
= gfc_trans_forall_1 (c
, nested_forall_info
);
5237 gfc_add_expr_to_block (&block
, tmp
);
5240 /* Explicit subroutine calls are prevented by the frontend but interface
5241 assignments can legitimately produce them. */
5242 case EXEC_ASSIGN_CALL
:
5243 assign
= gfc_trans_call (c
, true, NULL_TREE
, NULL_TREE
, false);
5244 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, assign
, 1);
5245 gfc_add_expr_to_block (&block
, tmp
);
5256 /* Restore the original index variables. */
5257 for (fa
= code
->ext
.forall_iterator
, n
= 0; fa
; fa
= fa
->next
, n
++)
5258 gfc_restore_sym (fa
->var
->symtree
->n
.sym
, &saved_vars
[n
]);
5260 /* Free the space for var, start, end, step, varexpr. */
5268 for (this_forall
= info
->this_loop
; this_forall
;)
5270 iter_info
*next
= this_forall
->next
;
5275 /* Free the space for this forall_info. */
5280 /* Free the temporary for the mask. */
5281 tmp
= gfc_call_free (pmask
);
5282 gfc_add_expr_to_block (&block
, tmp
);
5285 pushdecl (maskindex
);
5287 gfc_add_block_to_block (&pre
, &block
);
5288 gfc_add_block_to_block (&pre
, &post
);
5290 return gfc_finish_block (&pre
);
5294 /* Translate the FORALL statement or construct. */
5296 tree
gfc_trans_forall (gfc_code
* code
)
5298 return gfc_trans_forall_1 (code
, NULL
);
5302 /* Translate the DO CONCURRENT construct. */
5304 tree
gfc_trans_do_concurrent (gfc_code
* code
)
5306 return gfc_trans_forall_1 (code
, NULL
);
5310 /* Evaluate the WHERE mask expression, copy its value to a temporary.
5311 If the WHERE construct is nested in FORALL, compute the overall temporary
5312 needed by the WHERE mask expression multiplied by the iterator number of
5314 ME is the WHERE mask expression.
5315 MASK is the current execution mask upon input, whose sense may or may
5316 not be inverted as specified by the INVERT argument.
5317 CMASK is the updated execution mask on output, or NULL if not required.
5318 PMASK is the pending execution mask on output, or NULL if not required.
5319 BLOCK is the block in which to place the condition evaluation loops. */
5322 gfc_evaluate_where_mask (gfc_expr
* me
, forall_info
* nested_forall_info
,
5323 tree mask
, bool invert
, tree cmask
, tree pmask
,
5324 tree mask_type
, stmtblock_t
* block
)
5329 stmtblock_t body
, body1
;
5330 tree count
, cond
, mtmp
;
5333 gfc_init_loopinfo (&loop
);
5335 lss
= gfc_walk_expr (me
);
5336 rss
= gfc_walk_expr (me
);
5338 /* Variable to index the temporary. */
5339 count
= gfc_create_var (gfc_array_index_type
, "count");
5340 /* Initialize count. */
5341 gfc_add_modify (block
, count
, gfc_index_zero_node
);
5343 gfc_start_block (&body
);
5345 gfc_init_se (&rse
, NULL
);
5346 gfc_init_se (&lse
, NULL
);
5348 if (lss
== gfc_ss_terminator
)
5350 gfc_init_block (&body1
);
5354 /* Initialize the loop. */
5355 gfc_init_loopinfo (&loop
);
5357 /* We may need LSS to determine the shape of the expression. */
5358 gfc_add_ss_to_loop (&loop
, lss
);
5359 gfc_add_ss_to_loop (&loop
, rss
);
5361 gfc_conv_ss_startstride (&loop
);
5362 gfc_conv_loop_setup (&loop
, &me
->where
);
5364 gfc_mark_ss_chain_used (rss
, 1);
5365 /* Start the loop body. */
5366 gfc_start_scalarized_body (&loop
, &body1
);
5368 /* Translate the expression. */
5369 gfc_copy_loopinfo_to_se (&rse
, &loop
);
5371 gfc_conv_expr (&rse
, me
);
5374 /* Variable to evaluate mask condition. */
5375 cond
= gfc_create_var (mask_type
, "cond");
5376 if (mask
&& (cmask
|| pmask
))
5377 mtmp
= gfc_create_var (mask_type
, "mask");
5378 else mtmp
= NULL_TREE
;
5380 gfc_add_block_to_block (&body1
, &lse
.pre
);
5381 gfc_add_block_to_block (&body1
, &rse
.pre
);
5383 gfc_add_modify (&body1
, cond
, fold_convert (mask_type
, rse
.expr
));
5385 if (mask
&& (cmask
|| pmask
))
5387 tmp
= gfc_build_array_ref (mask
, count
, NULL
);
5389 tmp
= fold_build1_loc (input_location
, TRUTH_NOT_EXPR
, mask_type
, tmp
);
5390 gfc_add_modify (&body1
, mtmp
, tmp
);
5395 tmp1
= gfc_build_array_ref (cmask
, count
, NULL
);
5398 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
, mask_type
,
5400 gfc_add_modify (&body1
, tmp1
, tmp
);
5405 tmp1
= gfc_build_array_ref (pmask
, count
, NULL
);
5406 tmp
= fold_build1_loc (input_location
, TRUTH_NOT_EXPR
, mask_type
, cond
);
5408 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
, mask_type
, mtmp
,
5410 gfc_add_modify (&body1
, tmp1
, tmp
);
5413 gfc_add_block_to_block (&body1
, &lse
.post
);
5414 gfc_add_block_to_block (&body1
, &rse
.post
);
5416 if (lss
== gfc_ss_terminator
)
5418 gfc_add_block_to_block (&body
, &body1
);
5422 /* Increment count. */
5423 tmp1
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
5424 count
, gfc_index_one_node
);
5425 gfc_add_modify (&body1
, count
, tmp1
);
5427 /* Generate the copying loops. */
5428 gfc_trans_scalarizing_loops (&loop
, &body1
);
5430 gfc_add_block_to_block (&body
, &loop
.pre
);
5431 gfc_add_block_to_block (&body
, &loop
.post
);
5433 gfc_cleanup_loop (&loop
);
5434 /* TODO: Reuse lss and rss when copying temp->lhs. Need to be careful
5435 as tree nodes in SS may not be valid in different scope. */
5438 tmp1
= gfc_finish_block (&body
);
5439 /* If the WHERE construct is inside FORALL, fill the full temporary. */
5440 if (nested_forall_info
!= NULL
)
5441 tmp1
= gfc_trans_nested_forall_loop (nested_forall_info
, tmp1
, 1);
5443 gfc_add_expr_to_block (block
, tmp1
);
5447 /* Translate an assignment statement in a WHERE statement or construct
5448 statement. The MASK expression is used to control which elements
5449 of EXPR1 shall be assigned. The sense of MASK is specified by
5453 gfc_trans_where_assign (gfc_expr
*expr1
, gfc_expr
*expr2
,
5454 tree mask
, bool invert
,
5455 tree count1
, tree count2
,
5461 gfc_ss
*lss_section
;
5468 tree index
, maskexpr
;
5470 /* A defined assignment. */
5471 if (cnext
&& cnext
->resolved_sym
)
5472 return gfc_trans_call (cnext
, true, mask
, count1
, invert
);
5475 /* TODO: handle this special case.
5476 Special case a single function returning an array. */
5477 if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->rank
> 0)
5479 tmp
= gfc_trans_arrayfunc_assign (expr1
, expr2
);
5485 /* Assignment of the form lhs = rhs. */
5486 gfc_start_block (&block
);
5488 gfc_init_se (&lse
, NULL
);
5489 gfc_init_se (&rse
, NULL
);
5492 lss
= gfc_walk_expr (expr1
);
5495 /* In each where-assign-stmt, the mask-expr and the variable being
5496 defined shall be arrays of the same shape. */
5497 gcc_assert (lss
!= gfc_ss_terminator
);
5499 /* The assignment needs scalarization. */
5502 /* Find a non-scalar SS from the lhs. */
5503 while (lss_section
!= gfc_ss_terminator
5504 && lss_section
->info
->type
!= GFC_SS_SECTION
)
5505 lss_section
= lss_section
->next
;
5507 gcc_assert (lss_section
!= gfc_ss_terminator
);
5509 /* Initialize the scalarizer. */
5510 gfc_init_loopinfo (&loop
);
5513 rss
= gfc_walk_expr (expr2
);
5514 if (rss
== gfc_ss_terminator
)
5516 /* The rhs is scalar. Add a ss for the expression. */
5517 rss
= gfc_get_scalar_ss (gfc_ss_terminator
, expr2
);
5518 rss
->info
->where
= 1;
5521 /* Associate the SS with the loop. */
5522 gfc_add_ss_to_loop (&loop
, lss
);
5523 gfc_add_ss_to_loop (&loop
, rss
);
5525 /* Calculate the bounds of the scalarization. */
5526 gfc_conv_ss_startstride (&loop
);
5528 /* Resolve any data dependencies in the statement. */
5529 gfc_conv_resolve_dependencies (&loop
, lss_section
, rss
);
5531 /* Setup the scalarizing loops. */
5532 gfc_conv_loop_setup (&loop
, &expr2
->where
);
5534 /* Setup the gfc_se structures. */
5535 gfc_copy_loopinfo_to_se (&lse
, &loop
);
5536 gfc_copy_loopinfo_to_se (&rse
, &loop
);
5539 gfc_mark_ss_chain_used (rss
, 1);
5540 if (loop
.temp_ss
== NULL
)
5543 gfc_mark_ss_chain_used (lss
, 1);
5547 lse
.ss
= loop
.temp_ss
;
5548 gfc_mark_ss_chain_used (lss
, 3);
5549 gfc_mark_ss_chain_used (loop
.temp_ss
, 3);
5552 /* Start the scalarized loop body. */
5553 gfc_start_scalarized_body (&loop
, &body
);
5555 /* Translate the expression. */
5556 gfc_conv_expr (&rse
, expr2
);
5557 if (lss
!= gfc_ss_terminator
&& loop
.temp_ss
!= NULL
)
5558 gfc_conv_tmp_array_ref (&lse
);
5560 gfc_conv_expr (&lse
, expr1
);
5562 /* Form the mask expression according to the mask. */
5564 maskexpr
= gfc_build_array_ref (mask
, index
, NULL
);
5566 maskexpr
= fold_build1_loc (input_location
, TRUTH_NOT_EXPR
,
5567 TREE_TYPE (maskexpr
), maskexpr
);
5569 /* Use the scalar assignment as is. */
5570 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
,
5571 false, loop
.temp_ss
== NULL
);
5573 tmp
= build3_v (COND_EXPR
, maskexpr
, tmp
, build_empty_stmt (input_location
));
5575 gfc_add_expr_to_block (&body
, tmp
);
5577 if (lss
== gfc_ss_terminator
)
5579 /* Increment count1. */
5580 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
5581 count1
, gfc_index_one_node
);
5582 gfc_add_modify (&body
, count1
, tmp
);
5584 /* Use the scalar assignment as is. */
5585 gfc_add_block_to_block (&block
, &body
);
5589 gcc_assert (lse
.ss
== gfc_ss_terminator
5590 && rse
.ss
== gfc_ss_terminator
);
5592 if (loop
.temp_ss
!= NULL
)
5594 /* Increment count1 before finish the main body of a scalarized
5596 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
5597 gfc_array_index_type
, count1
, gfc_index_one_node
);
5598 gfc_add_modify (&body
, count1
, tmp
);
5599 gfc_trans_scalarized_loop_boundary (&loop
, &body
);
5601 /* We need to copy the temporary to the actual lhs. */
5602 gfc_init_se (&lse
, NULL
);
5603 gfc_init_se (&rse
, NULL
);
5604 gfc_copy_loopinfo_to_se (&lse
, &loop
);
5605 gfc_copy_loopinfo_to_se (&rse
, &loop
);
5607 rse
.ss
= loop
.temp_ss
;
5610 gfc_conv_tmp_array_ref (&rse
);
5611 gfc_conv_expr (&lse
, expr1
);
5613 gcc_assert (lse
.ss
== gfc_ss_terminator
5614 && rse
.ss
== gfc_ss_terminator
);
5616 /* Form the mask expression according to the mask tree list. */
5618 maskexpr
= gfc_build_array_ref (mask
, index
, NULL
);
5620 maskexpr
= fold_build1_loc (input_location
, TRUTH_NOT_EXPR
,
5621 TREE_TYPE (maskexpr
), maskexpr
);
5623 /* Use the scalar assignment as is. */
5624 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
, false, true);
5625 tmp
= build3_v (COND_EXPR
, maskexpr
, tmp
,
5626 build_empty_stmt (input_location
));
5627 gfc_add_expr_to_block (&body
, tmp
);
5629 /* Increment count2. */
5630 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
5631 gfc_array_index_type
, count2
,
5632 gfc_index_one_node
);
5633 gfc_add_modify (&body
, count2
, tmp
);
5637 /* Increment count1. */
5638 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
5639 gfc_array_index_type
, count1
,
5640 gfc_index_one_node
);
5641 gfc_add_modify (&body
, count1
, tmp
);
5644 /* Generate the copying loops. */
5645 gfc_trans_scalarizing_loops (&loop
, &body
);
5647 /* Wrap the whole thing up. */
5648 gfc_add_block_to_block (&block
, &loop
.pre
);
5649 gfc_add_block_to_block (&block
, &loop
.post
);
5650 gfc_cleanup_loop (&loop
);
5653 return gfc_finish_block (&block
);
5657 /* Translate the WHERE construct or statement.
5658 This function can be called iteratively to translate the nested WHERE
5659 construct or statement.
5660 MASK is the control mask. */
5663 gfc_trans_where_2 (gfc_code
* code
, tree mask
, bool invert
,
5664 forall_info
* nested_forall_info
, stmtblock_t
* block
)
5666 stmtblock_t inner_size_body
;
5667 tree inner_size
, size
;
5676 tree count1
, count2
;
5680 tree pcmask
= NULL_TREE
;
5681 tree ppmask
= NULL_TREE
;
5682 tree cmask
= NULL_TREE
;
5683 tree pmask
= NULL_TREE
;
5684 gfc_actual_arglist
*arg
;
5686 /* the WHERE statement or the WHERE construct statement. */
5687 cblock
= code
->block
;
5689 /* As the mask array can be very big, prefer compact boolean types. */
5690 mask_type
= gfc_get_logical_type (gfc_logical_kinds
[0].kind
);
5692 /* Determine which temporary masks are needed. */
5695 /* One clause: No ELSEWHEREs. */
5696 need_cmask
= (cblock
->next
!= 0);
5699 else if (cblock
->block
->block
)
5701 /* Three or more clauses: Conditional ELSEWHEREs. */
5705 else if (cblock
->next
)
5707 /* Two clauses, the first non-empty. */
5709 need_pmask
= (mask
!= NULL_TREE
5710 && cblock
->block
->next
!= 0);
5712 else if (!cblock
->block
->next
)
5714 /* Two clauses, both empty. */
5718 /* Two clauses, the first empty, the second non-empty. */
5721 need_cmask
= (cblock
->block
->expr1
!= 0);
5730 if (need_cmask
|| need_pmask
)
5732 /* Calculate the size of temporary needed by the mask-expr. */
5733 gfc_init_block (&inner_size_body
);
5734 inner_size
= compute_inner_temp_size (cblock
->expr1
, cblock
->expr1
,
5735 &inner_size_body
, &lss
, &rss
);
5737 gfc_free_ss_chain (lss
);
5738 gfc_free_ss_chain (rss
);
5740 /* Calculate the total size of temporary needed. */
5741 size
= compute_overall_iter_number (nested_forall_info
, inner_size
,
5742 &inner_size_body
, block
);
5744 /* Check whether the size is negative. */
5745 cond
= fold_build2_loc (input_location
, LE_EXPR
, logical_type_node
, size
,
5746 gfc_index_zero_node
);
5747 size
= fold_build3_loc (input_location
, COND_EXPR
, gfc_array_index_type
,
5748 cond
, gfc_index_zero_node
, size
);
5749 size
= gfc_evaluate_now (size
, block
);
5751 /* Allocate temporary for WHERE mask if needed. */
5753 cmask
= allocate_temp_for_forall_nest_1 (mask_type
, size
, block
,
5756 /* Allocate temporary for !mask if needed. */
5758 pmask
= allocate_temp_for_forall_nest_1 (mask_type
, size
, block
,
5764 /* Each time around this loop, the where clause is conditional
5765 on the value of mask and invert, which are updated at the
5766 bottom of the loop. */
5768 /* Has mask-expr. */
5771 /* Ensure that the WHERE mask will be evaluated exactly once.
5772 If there are no statements in this WHERE/ELSEWHERE clause,
5773 then we don't need to update the control mask (cmask).
5774 If this is the last clause of the WHERE construct, then
5775 we don't need to update the pending control mask (pmask). */
5777 gfc_evaluate_where_mask (cblock
->expr1
, nested_forall_info
,
5779 cblock
->next
? cmask
: NULL_TREE
,
5780 cblock
->block
? pmask
: NULL_TREE
,
5783 gfc_evaluate_where_mask (cblock
->expr1
, nested_forall_info
,
5785 (cblock
->next
|| cblock
->block
)
5786 ? cmask
: NULL_TREE
,
5787 NULL_TREE
, mask_type
, block
);
5791 /* It's a final elsewhere-stmt. No mask-expr is present. */
5795 /* The body of this where clause are controlled by cmask with
5796 sense specified by invert. */
5798 /* Get the assignment statement of a WHERE statement, or the first
5799 statement in where-body-construct of a WHERE construct. */
5800 cnext
= cblock
->next
;
5805 /* WHERE assignment statement. */
5806 case EXEC_ASSIGN_CALL
:
5808 arg
= cnext
->ext
.actual
;
5809 expr1
= expr2
= NULL
;
5810 for (; arg
; arg
= arg
->next
)
5822 expr1
= cnext
->expr1
;
5823 expr2
= cnext
->expr2
;
5825 if (nested_forall_info
!= NULL
)
5827 need_temp
= gfc_check_dependency (expr1
, expr2
, 0);
5828 if ((need_temp
|| flag_test_forall_temp
)
5829 && cnext
->op
!= EXEC_ASSIGN_CALL
)
5830 gfc_trans_assign_need_temp (expr1
, expr2
,
5832 nested_forall_info
, block
);
5835 /* Variables to control maskexpr. */
5836 count1
= gfc_create_var (gfc_array_index_type
, "count1");
5837 count2
= gfc_create_var (gfc_array_index_type
, "count2");
5838 gfc_add_modify (block
, count1
, gfc_index_zero_node
);
5839 gfc_add_modify (block
, count2
, gfc_index_zero_node
);
5841 tmp
= gfc_trans_where_assign (expr1
, expr2
,
5846 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
,
5848 gfc_add_expr_to_block (block
, tmp
);
5853 /* Variables to control maskexpr. */
5854 count1
= gfc_create_var (gfc_array_index_type
, "count1");
5855 count2
= gfc_create_var (gfc_array_index_type
, "count2");
5856 gfc_add_modify (block
, count1
, gfc_index_zero_node
);
5857 gfc_add_modify (block
, count2
, gfc_index_zero_node
);
5859 tmp
= gfc_trans_where_assign (expr1
, expr2
,
5863 gfc_add_expr_to_block (block
, tmp
);
5868 /* WHERE or WHERE construct is part of a where-body-construct. */
5870 gfc_trans_where_2 (cnext
, cmask
, invert
,
5871 nested_forall_info
, block
);
5878 /* The next statement within the same where-body-construct. */
5879 cnext
= cnext
->next
;
5881 /* The next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt. */
5882 cblock
= cblock
->block
;
5883 if (mask
== NULL_TREE
)
5885 /* If we're the initial WHERE, we can simply invert the sense
5886 of the current mask to obtain the "mask" for the remaining
5893 /* Otherwise, for nested WHERE's we need to use the pending mask. */
5899 /* If we allocated a pending mask array, deallocate it now. */
5902 tmp
= gfc_call_free (ppmask
);
5903 gfc_add_expr_to_block (block
, tmp
);
5906 /* If we allocated a current mask array, deallocate it now. */
5909 tmp
= gfc_call_free (pcmask
);
5910 gfc_add_expr_to_block (block
, tmp
);
5914 /* Translate a simple WHERE construct or statement without dependencies.
5915 CBLOCK is the "then" clause of the WHERE statement, where CBLOCK->EXPR
5916 is the mask condition, and EBLOCK if non-NULL is the "else" clause.
5917 Currently both CBLOCK and EBLOCK are restricted to single assignments. */
5920 gfc_trans_where_3 (gfc_code
* cblock
, gfc_code
* eblock
)
5922 stmtblock_t block
, body
;
5923 gfc_expr
*cond
, *tdst
, *tsrc
, *edst
, *esrc
;
5924 tree tmp
, cexpr
, tstmt
, estmt
;
5925 gfc_ss
*css
, *tdss
, *tsss
;
5926 gfc_se cse
, tdse
, tsse
, edse
, esse
;
5930 bool maybe_workshare
= false;
5932 /* Allow the scalarizer to workshare simple where loops. */
5933 if ((ompws_flags
& (OMPWS_WORKSHARE_FLAG
| OMPWS_SCALARIZER_BODY
))
5934 == OMPWS_WORKSHARE_FLAG
)
5936 maybe_workshare
= true;
5937 ompws_flags
|= OMPWS_SCALARIZER_WS
| OMPWS_SCALARIZER_BODY
;
5940 cond
= cblock
->expr1
;
5941 tdst
= cblock
->next
->expr1
;
5942 tsrc
= cblock
->next
->expr2
;
5943 edst
= eblock
? eblock
->next
->expr1
: NULL
;
5944 esrc
= eblock
? eblock
->next
->expr2
: NULL
;
5946 gfc_start_block (&block
);
5947 gfc_init_loopinfo (&loop
);
5949 /* Handle the condition. */
5950 gfc_init_se (&cse
, NULL
);
5951 css
= gfc_walk_expr (cond
);
5952 gfc_add_ss_to_loop (&loop
, css
);
5954 /* Handle the then-clause. */
5955 gfc_init_se (&tdse
, NULL
);
5956 gfc_init_se (&tsse
, NULL
);
5957 tdss
= gfc_walk_expr (tdst
);
5958 tsss
= gfc_walk_expr (tsrc
);
5959 if (tsss
== gfc_ss_terminator
)
5961 tsss
= gfc_get_scalar_ss (gfc_ss_terminator
, tsrc
);
5962 tsss
->info
->where
= 1;
5964 gfc_add_ss_to_loop (&loop
, tdss
);
5965 gfc_add_ss_to_loop (&loop
, tsss
);
5969 /* Handle the else clause. */
5970 gfc_init_se (&edse
, NULL
);
5971 gfc_init_se (&esse
, NULL
);
5972 edss
= gfc_walk_expr (edst
);
5973 esss
= gfc_walk_expr (esrc
);
5974 if (esss
== gfc_ss_terminator
)
5976 esss
= gfc_get_scalar_ss (gfc_ss_terminator
, esrc
);
5977 esss
->info
->where
= 1;
5979 gfc_add_ss_to_loop (&loop
, edss
);
5980 gfc_add_ss_to_loop (&loop
, esss
);
5983 gfc_conv_ss_startstride (&loop
);
5984 gfc_conv_loop_setup (&loop
, &tdst
->where
);
5986 gfc_mark_ss_chain_used (css
, 1);
5987 gfc_mark_ss_chain_used (tdss
, 1);
5988 gfc_mark_ss_chain_used (tsss
, 1);
5991 gfc_mark_ss_chain_used (edss
, 1);
5992 gfc_mark_ss_chain_used (esss
, 1);
5995 gfc_start_scalarized_body (&loop
, &body
);
5997 gfc_copy_loopinfo_to_se (&cse
, &loop
);
5998 gfc_copy_loopinfo_to_se (&tdse
, &loop
);
5999 gfc_copy_loopinfo_to_se (&tsse
, &loop
);
6005 gfc_copy_loopinfo_to_se (&edse
, &loop
);
6006 gfc_copy_loopinfo_to_se (&esse
, &loop
);
6011 gfc_conv_expr (&cse
, cond
);
6012 gfc_add_block_to_block (&body
, &cse
.pre
);
6015 gfc_conv_expr (&tsse
, tsrc
);
6016 if (tdss
!= gfc_ss_terminator
&& loop
.temp_ss
!= NULL
)
6017 gfc_conv_tmp_array_ref (&tdse
);
6019 gfc_conv_expr (&tdse
, tdst
);
6023 gfc_conv_expr (&esse
, esrc
);
6024 if (edss
!= gfc_ss_terminator
&& loop
.temp_ss
!= NULL
)
6025 gfc_conv_tmp_array_ref (&edse
);
6027 gfc_conv_expr (&edse
, edst
);
6030 tstmt
= gfc_trans_scalar_assign (&tdse
, &tsse
, tdst
->ts
, false, true);
6031 estmt
= eblock
? gfc_trans_scalar_assign (&edse
, &esse
, edst
->ts
,
6033 : build_empty_stmt (input_location
);
6034 tmp
= build3_v (COND_EXPR
, cexpr
, tstmt
, estmt
);
6035 gfc_add_expr_to_block (&body
, tmp
);
6036 gfc_add_block_to_block (&body
, &cse
.post
);
6038 if (maybe_workshare
)
6039 ompws_flags
&= ~OMPWS_SCALARIZER_BODY
;
6040 gfc_trans_scalarizing_loops (&loop
, &body
);
6041 gfc_add_block_to_block (&block
, &loop
.pre
);
6042 gfc_add_block_to_block (&block
, &loop
.post
);
6043 gfc_cleanup_loop (&loop
);
6045 return gfc_finish_block (&block
);
6048 /* As the WHERE or WHERE construct statement can be nested, we call
6049 gfc_trans_where_2 to do the translation, and pass the initial
6050 NULL values for both the control mask and the pending control mask. */
6053 gfc_trans_where (gfc_code
* code
)
6059 cblock
= code
->block
;
6061 && cblock
->next
->op
== EXEC_ASSIGN
6062 && !cblock
->next
->next
)
6064 eblock
= cblock
->block
;
6067 /* A simple "WHERE (cond) x = y" statement or block is
6068 dependence free if cond is not dependent upon writing x,
6069 and the source y is unaffected by the destination x. */
6070 if (!gfc_check_dependency (cblock
->next
->expr1
,
6072 && !gfc_check_dependency (cblock
->next
->expr1
,
6073 cblock
->next
->expr2
, 0))
6074 return gfc_trans_where_3 (cblock
, NULL
);
6076 else if (!eblock
->expr1
6079 && eblock
->next
->op
== EXEC_ASSIGN
6080 && !eblock
->next
->next
)
6082 /* A simple "WHERE (cond) x1 = y1 ELSEWHERE x2 = y2 ENDWHERE"
6083 block is dependence free if cond is not dependent on writes
6084 to x1 and x2, y1 is not dependent on writes to x2, and y2
6085 is not dependent on writes to x1, and both y's are not
6086 dependent upon their own x's. In addition to this, the
6087 final two dependency checks below exclude all but the same
6088 array reference if the where and elswhere destinations
6089 are the same. In short, this is VERY conservative and this
6090 is needed because the two loops, required by the standard
6091 are coalesced in gfc_trans_where_3. */
6092 if (!gfc_check_dependency (cblock
->next
->expr1
,
6094 && !gfc_check_dependency (eblock
->next
->expr1
,
6096 && !gfc_check_dependency (cblock
->next
->expr1
,
6097 eblock
->next
->expr2
, 1)
6098 && !gfc_check_dependency (eblock
->next
->expr1
,
6099 cblock
->next
->expr2
, 1)
6100 && !gfc_check_dependency (cblock
->next
->expr1
,
6101 cblock
->next
->expr2
, 1)
6102 && !gfc_check_dependency (eblock
->next
->expr1
,
6103 eblock
->next
->expr2
, 1)
6104 && !gfc_check_dependency (cblock
->next
->expr1
,
6105 eblock
->next
->expr1
, 0)
6106 && !gfc_check_dependency (eblock
->next
->expr1
,
6107 cblock
->next
->expr1
, 0))
6108 return gfc_trans_where_3 (cblock
, eblock
);
6112 gfc_start_block (&block
);
6114 gfc_trans_where_2 (code
, NULL
, false, NULL
, &block
);
6116 return gfc_finish_block (&block
);
6120 /* CYCLE a DO loop. The label decl has already been created by
6121 gfc_trans_do(), it's in TREE_PURPOSE (backend_decl) of the gfc_code
6122 node at the head of the loop. We must mark the label as used. */
6125 gfc_trans_cycle (gfc_code
* code
)
6129 cycle_label
= code
->ext
.which_construct
->cycle_label
;
6130 gcc_assert (cycle_label
);
6132 TREE_USED (cycle_label
) = 1;
6133 return build1_v (GOTO_EXPR
, cycle_label
);
6137 /* EXIT a DO loop. Similar to CYCLE, but now the label is in
6138 TREE_VALUE (backend_decl) of the gfc_code node at the head of the
6142 gfc_trans_exit (gfc_code
* code
)
6146 exit_label
= code
->ext
.which_construct
->exit_label
;
6147 gcc_assert (exit_label
);
6149 TREE_USED (exit_label
) = 1;
6150 return build1_v (GOTO_EXPR
, exit_label
);
6154 /* Get the initializer expression for the code and expr of an allocate.
6155 When no initializer is needed return NULL. */
6158 allocate_get_initializer (gfc_code
* code
, gfc_expr
* expr
)
6160 if (!gfc_bt_struct (expr
->ts
.type
) && expr
->ts
.type
!= BT_CLASS
)
6163 /* An explicit type was given in allocate ( T:: object). */
6164 if (code
->ext
.alloc
.ts
.type
== BT_DERIVED
6165 && (code
->ext
.alloc
.ts
.u
.derived
->attr
.alloc_comp
6166 || gfc_has_default_initializer (code
->ext
.alloc
.ts
.u
.derived
)))
6167 return gfc_default_initializer (&code
->ext
.alloc
.ts
);
6169 if (gfc_bt_struct (expr
->ts
.type
)
6170 && (expr
->ts
.u
.derived
->attr
.alloc_comp
6171 || gfc_has_default_initializer (expr
->ts
.u
.derived
)))
6172 return gfc_default_initializer (&expr
->ts
);
6174 if (expr
->ts
.type
== BT_CLASS
6175 && (CLASS_DATA (expr
)->ts
.u
.derived
->attr
.alloc_comp
6176 || gfc_has_default_initializer (CLASS_DATA (expr
)->ts
.u
.derived
)))
6177 return gfc_default_initializer (&CLASS_DATA (expr
)->ts
);
6182 /* Translate the ALLOCATE statement. */
6185 gfc_trans_allocate (gfc_code
* code
)
6188 gfc_expr
*expr
, *e3rhs
= NULL
, *init_expr
;
6198 tree al_vptr
, al_len
;
6199 /* If an expr3 is present, then store the tree for accessing its
6200 _vptr, and _len components in the variables, respectively. The
6201 element size, i.e. _vptr%size, is stored in expr3_esize. Any of
6202 the trees may be the NULL_TREE indicating that this is not
6203 available for expr3's type. */
6204 tree expr3
, expr3_vptr
, expr3_len
, expr3_esize
;
6205 /* Classify what expr3 stores. */
6206 enum { E3_UNSET
= 0, E3_SOURCE
, E3_MOLD
, E3_DESC
} e3_is
;
6209 stmtblock_t final_block
;
6211 bool upoly_expr
, tmp_expr3_len_flag
= false, al_len_needs_set
, is_coarray
;
6212 bool needs_caf_sync
, caf_refs_comp
;
6213 bool e3_has_nodescriptor
= false;
6214 gfc_symtree
*newsym
= NULL
;
6215 symbol_attribute caf_attr
;
6216 gfc_actual_arglist
*param_list
;
6218 if (!code
->ext
.alloc
.list
)
6221 stat
= tmp
= memsz
= al_vptr
= al_len
= NULL_TREE
;
6222 expr3
= expr3_vptr
= expr3_len
= expr3_esize
= NULL_TREE
;
6223 label_errmsg
= label_finish
= errmsg
= errlen
= NULL_TREE
;
6225 is_coarray
= needs_caf_sync
= false;
6227 gfc_init_block (&block
);
6228 gfc_init_block (&post
);
6229 gfc_init_block (&final_block
);
6231 /* STAT= (and maybe ERRMSG=) is present. */
6235 tree gfc_int4_type_node
= gfc_get_int_type (4);
6236 stat
= gfc_create_var (gfc_int4_type_node
, "stat");
6238 /* ERRMSG= only makes sense with STAT=. */
6241 gfc_init_se (&se
, NULL
);
6242 se
.want_pointer
= 1;
6243 gfc_conv_expr_lhs (&se
, code
->expr2
);
6245 errlen
= se
.string_length
;
6249 errmsg
= null_pointer_node
;
6250 errlen
= build_int_cst (gfc_charlen_type_node
, 0);
6253 /* GOTO destinations. */
6254 label_errmsg
= gfc_build_label_decl (NULL_TREE
);
6255 label_finish
= gfc_build_label_decl (NULL_TREE
);
6256 TREE_USED (label_finish
) = 0;
6259 /* When an expr3 is present evaluate it only once. The standards prevent a
6260 dependency of expr3 on the objects in the allocate list. An expr3 can
6261 be pre-evaluated in all cases. One just has to make sure, to use the
6262 correct way, i.e., to get the descriptor or to get a reference
6266 bool vtab_needed
= false, temp_var_needed
= false,
6267 temp_obj_created
= false;
6269 is_coarray
= gfc_is_coarray (code
->expr3
);
6271 if (code
->expr3
->expr_type
== EXPR_FUNCTION
&& !code
->expr3
->mold
6272 && (gfc_is_class_array_function (code
->expr3
)
6273 || gfc_is_alloc_class_scalar_function (code
->expr3
)))
6274 code
->expr3
->must_finalize
= 1;
6276 /* Figure whether we need the vtab from expr3. */
6277 for (al
= code
->ext
.alloc
.list
; !vtab_needed
&& al
!= NULL
;
6279 vtab_needed
= (al
->expr
->ts
.type
== BT_CLASS
);
6281 gfc_init_se (&se
, NULL
);
6282 /* When expr3 is a variable, i.e., a very simple expression,
6283 then convert it once here. */
6284 if (code
->expr3
->expr_type
== EXPR_VARIABLE
6285 || code
->expr3
->expr_type
== EXPR_ARRAY
6286 || code
->expr3
->expr_type
== EXPR_CONSTANT
)
6288 if (!code
->expr3
->mold
6289 || code
->expr3
->ts
.type
== BT_CHARACTER
6291 || code
->ext
.alloc
.arr_spec_from_expr3
)
6293 /* Convert expr3 to a tree. For all "simple" expression just
6294 get the descriptor or the reference, respectively, depending
6295 on the rank of the expr. */
6296 if (code
->ext
.alloc
.arr_spec_from_expr3
|| code
->expr3
->rank
!= 0)
6297 gfc_conv_expr_descriptor (&se
, code
->expr3
);
6300 gfc_conv_expr_reference (&se
, code
->expr3
);
6302 /* gfc_conv_expr_reference wraps POINTER_PLUS_EXPR in a
6303 NOP_EXPR, which prevents gfortran from getting the vptr
6304 from the source=-expression. Remove the NOP_EXPR and go
6305 with the POINTER_PLUS_EXPR in this case. */
6306 if (code
->expr3
->ts
.type
== BT_CLASS
6307 && TREE_CODE (se
.expr
) == NOP_EXPR
6308 && (TREE_CODE (TREE_OPERAND (se
.expr
, 0))
6309 == POINTER_PLUS_EXPR
6311 se
.expr
= TREE_OPERAND (se
.expr
, 0);
6313 /* Create a temp variable only for component refs to prevent
6314 having to go through the full deref-chain each time and to
6315 simplfy computation of array properties. */
6316 temp_var_needed
= TREE_CODE (se
.expr
) == COMPONENT_REF
;
6321 /* In all other cases evaluate the expr3. */
6322 symbol_attribute attr
;
6323 /* Get the descriptor for all arrays, that are not allocatable or
6324 pointer, because the latter are descriptors already.
6325 The exception are function calls returning a class object:
6326 The descriptor is stored in their results _data component, which
6327 is easier to access, when first a temporary variable for the
6328 result is created and the descriptor retrieved from there. */
6329 attr
= gfc_expr_attr (code
->expr3
);
6330 if (code
->expr3
->rank
!= 0
6331 && ((!attr
.allocatable
&& !attr
.pointer
)
6332 || (code
->expr3
->expr_type
== EXPR_FUNCTION
6333 && (code
->expr3
->ts
.type
!= BT_CLASS
6334 || (code
->expr3
->value
.function
.isym
6335 && code
->expr3
->value
.function
.isym
6336 ->transformational
)))))
6337 gfc_conv_expr_descriptor (&se
, code
->expr3
);
6339 gfc_conv_expr_reference (&se
, code
->expr3
);
6340 if (code
->expr3
->ts
.type
== BT_CLASS
)
6341 gfc_conv_class_to_class (&se
, code
->expr3
,
6345 temp_obj_created
= temp_var_needed
= !VAR_P (se
.expr
);
6347 gfc_add_block_to_block (&block
, &se
.pre
);
6348 if (code
->expr3
->must_finalize
)
6349 gfc_add_block_to_block (&final_block
, &se
.post
);
6351 gfc_add_block_to_block (&post
, &se
.post
);
6353 /* Special case when string in expr3 is zero. */
6354 if (code
->expr3
->ts
.type
== BT_CHARACTER
6355 && integer_zerop (se
.string_length
))
6357 gfc_init_se (&se
, NULL
);
6358 temp_var_needed
= false;
6359 expr3_len
= build_zero_cst (gfc_charlen_type_node
);
6362 /* Prevent aliasing, i.e., se.expr may be already a
6363 variable declaration. */
6364 else if (se
.expr
!= NULL_TREE
&& temp_var_needed
)
6367 tmp
= GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se
.expr
)) || is_coarray
?
6369 : build_fold_indirect_ref_loc (input_location
, se
.expr
);
6371 /* Get the array descriptor and prepare it to be assigned to the
6372 temporary variable var. For classes the array descriptor is
6373 in the _data component and the object goes into the
6374 GFC_DECL_SAVED_DESCRIPTOR. */
6375 if (code
->expr3
->ts
.type
== BT_CLASS
6376 && code
->expr3
->rank
!= 0)
6378 /* When an array_ref was in expr3, then the descriptor is the
6380 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp
)) || is_coarray
)
6382 desc
= TREE_OPERAND (tmp
, 0);
6387 tmp
= gfc_class_data_get (tmp
);
6389 if (code
->ext
.alloc
.arr_spec_from_expr3
)
6393 desc
= !is_coarray
? se
.expr
6394 : TREE_OPERAND (TREE_OPERAND (se
.expr
, 0), 0);
6395 /* We need a regular (non-UID) symbol here, therefore give a
6397 var
= gfc_create_var (TREE_TYPE (tmp
), "source");
6398 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp
)) || is_coarray
)
6400 gfc_allocate_lang_decl (var
);
6401 GFC_DECL_SAVED_DESCRIPTOR (var
) = desc
;
6403 gfc_add_modify_loc (input_location
, &block
, var
, tmp
);
6406 if (se
.string_length
)
6407 /* Evaluate it assuming that it also is complicated like expr3. */
6408 expr3_len
= gfc_evaluate_now (se
.string_length
, &block
);
6413 expr3_len
= se
.string_length
;
6416 /* Deallocate any allocatable components in expressions that use a
6417 temporary object, i.e. are not a simple alias of to an EXPR_VARIABLE.
6418 E.g. temporaries of a function call need freeing of their components
6420 if ((code
->expr3
->ts
.type
== BT_DERIVED
6421 || code
->expr3
->ts
.type
== BT_CLASS
)
6422 && (code
->expr3
->expr_type
!= EXPR_VARIABLE
|| temp_obj_created
)
6423 && code
->expr3
->ts
.u
.derived
->attr
.alloc_comp
6424 && !code
->expr3
->must_finalize
)
6426 tmp
= gfc_deallocate_alloc_comp (code
->expr3
->ts
.u
.derived
,
6427 expr3
, code
->expr3
->rank
);
6428 gfc_prepend_expr_to_block (&post
, tmp
);
6431 /* Store what the expr3 is to be used for. */
6432 if (e3_is
== E3_UNSET
)
6433 e3_is
= expr3
!= NULL_TREE
?
6434 (code
->ext
.alloc
.arr_spec_from_expr3
?
6436 : (code
->expr3
->mold
? E3_MOLD
: E3_SOURCE
))
6439 /* Figure how to get the _vtab entry. This also obtains the tree
6440 expression for accessing the _len component, because only
6441 unlimited polymorphic objects, which are a subcategory of class
6442 types, have a _len component. */
6443 if (code
->expr3
->ts
.type
== BT_CLASS
)
6446 tmp
= expr3
!= NULL_TREE
&& POINTER_TYPE_P (TREE_TYPE (expr3
)) ?
6447 build_fold_indirect_ref (expr3
): expr3
;
6448 /* Polymorphic SOURCE: VPTR must be determined at run time.
6449 expr3 may be a temporary array declaration, therefore check for
6450 GFC_CLASS_TYPE_P before trying to get the _vptr component. */
6451 if (tmp
!= NULL_TREE
6452 && (e3_is
== E3_DESC
6453 || (GFC_CLASS_TYPE_P (TREE_TYPE (tmp
))
6454 && (VAR_P (tmp
) || !code
->expr3
->ref
))
6455 || (VAR_P (tmp
) && DECL_LANG_SPECIFIC (tmp
))))
6456 tmp
= gfc_class_vptr_get (expr3
);
6459 rhs
= gfc_find_and_cut_at_last_class_ref (code
->expr3
);
6460 gfc_add_vptr_component (rhs
);
6461 gfc_init_se (&se
, NULL
);
6462 se
.want_pointer
= 1;
6463 gfc_conv_expr (&se
, rhs
);
6465 gfc_free_expr (rhs
);
6467 /* Set the element size. */
6468 expr3_esize
= gfc_vptr_size_get (tmp
);
6471 /* Initialize the ref to the _len component. */
6472 if (expr3_len
== NULL_TREE
&& UNLIMITED_POLY (code
->expr3
))
6474 /* Same like for retrieving the _vptr. */
6475 if (expr3
!= NULL_TREE
&& !code
->expr3
->ref
)
6476 expr3_len
= gfc_class_len_get (expr3
);
6479 rhs
= gfc_find_and_cut_at_last_class_ref (code
->expr3
);
6480 gfc_add_len_component (rhs
);
6481 gfc_init_se (&se
, NULL
);
6482 gfc_conv_expr (&se
, rhs
);
6483 expr3_len
= se
.expr
;
6484 gfc_free_expr (rhs
);
6490 /* When the object to allocate is polymorphic type, then it
6491 needs its vtab set correctly, so deduce the required _vtab
6492 and _len from the source expression. */
6495 /* VPTR is fixed at compile time. */
6498 vtab
= gfc_find_vtab (&code
->expr3
->ts
);
6500 expr3_vptr
= gfc_get_symbol_decl (vtab
);
6501 expr3_vptr
= gfc_build_addr_expr (NULL_TREE
,
6504 /* _len component needs to be set, when ts is a character
6506 if (expr3_len
== NULL_TREE
6507 && code
->expr3
->ts
.type
== BT_CHARACTER
)
6509 if (code
->expr3
->ts
.u
.cl
6510 && code
->expr3
->ts
.u
.cl
->length
)
6512 gfc_init_se (&se
, NULL
);
6513 gfc_conv_expr (&se
, code
->expr3
->ts
.u
.cl
->length
);
6514 gfc_add_block_to_block (&block
, &se
.pre
);
6515 expr3_len
= gfc_evaluate_now (se
.expr
, &block
);
6517 gcc_assert (expr3_len
);
6519 /* For character arrays only the kind's size is needed, because
6520 the array mem_size is _len * (elem_size = kind_size).
6521 For all other get the element size in the normal way. */
6522 if (code
->expr3
->ts
.type
== BT_CHARACTER
)
6523 expr3_esize
= TYPE_SIZE_UNIT (
6524 gfc_get_char_type (code
->expr3
->ts
.kind
));
6526 expr3_esize
= TYPE_SIZE_UNIT (
6527 gfc_typenode_for_spec (&code
->expr3
->ts
));
6529 gcc_assert (expr3_esize
);
6530 expr3_esize
= fold_convert (sizetype
, expr3_esize
);
6531 if (e3_is
== E3_MOLD
)
6532 /* The expr3 is no longer valid after this point. */
6535 else if (code
->ext
.alloc
.ts
.type
!= BT_UNKNOWN
)
6537 /* Compute the explicit typespec given only once for all objects
6539 if (code
->ext
.alloc
.ts
.type
!= BT_CHARACTER
)
6540 expr3_esize
= TYPE_SIZE_UNIT (
6541 gfc_typenode_for_spec (&code
->ext
.alloc
.ts
));
6542 else if (code
->ext
.alloc
.ts
.u
.cl
->length
!= NULL
)
6545 sz
= gfc_copy_expr (code
->ext
.alloc
.ts
.u
.cl
->length
);
6546 gfc_init_se (&se_sz
, NULL
);
6547 gfc_conv_expr (&se_sz
, sz
);
6549 tmp
= gfc_get_char_type (code
->ext
.alloc
.ts
.kind
);
6550 tmp
= TYPE_SIZE_UNIT (tmp
);
6551 tmp
= fold_convert (TREE_TYPE (se_sz
.expr
), tmp
);
6552 gfc_add_block_to_block (&block
, &se_sz
.pre
);
6553 expr3_esize
= fold_build2_loc (input_location
, MULT_EXPR
,
6554 TREE_TYPE (se_sz
.expr
),
6556 expr3_esize
= gfc_evaluate_now (expr3_esize
, &block
);
6559 expr3_esize
= NULL_TREE
;
6562 /* The routine gfc_trans_assignment () already implements all
6563 techniques needed. Unfortunately we may have a temporary
6564 variable for the source= expression here. When that is the
6565 case convert this variable into a temporary gfc_expr of type
6566 EXPR_VARIABLE and used it as rhs for the assignment. The
6567 advantage is, that we get scalarizer support for free,
6568 don't have to take care about scalar to array treatment and
6569 will benefit of every enhancements gfc_trans_assignment ()
6571 No need to check whether e3_is is E3_UNSET, because that is
6572 done by expr3 != NULL_TREE.
6573 Exclude variables since the following block does not handle
6574 array sections. In any case, there is no harm in sending
6575 variables to gfc_trans_assignment because there is no
6576 evaluation of variables. */
6579 if (code
->expr3
->expr_type
!= EXPR_VARIABLE
6580 && e3_is
!= E3_MOLD
&& expr3
!= NULL_TREE
6581 && DECL_P (expr3
) && DECL_ARTIFICIAL (expr3
))
6583 /* Build a temporary symtree and symbol. Do not add it to the current
6584 namespace to prevent accidently modifying a colliding
6586 newsym
= XCNEW (gfc_symtree
);
6587 /* The name of the symtree should be unique, because gfc_create_var ()
6588 took care about generating the identifier. */
6590 = gfc_get_string ("%s", IDENTIFIER_POINTER (DECL_NAME (expr3
)));
6591 newsym
->n
.sym
= gfc_new_symbol (newsym
->name
, NULL
);
6592 /* The backend_decl is known. It is expr3, which is inserted
6594 newsym
->n
.sym
->backend_decl
= expr3
;
6595 e3rhs
= gfc_get_expr ();
6596 e3rhs
->rank
= code
->expr3
->rank
;
6597 e3rhs
->symtree
= newsym
;
6598 /* Mark the symbol referenced or gfc_trans_assignment will bug. */
6599 newsym
->n
.sym
->attr
.referenced
= 1;
6600 e3rhs
->expr_type
= EXPR_VARIABLE
;
6601 e3rhs
->where
= code
->expr3
->where
;
6602 /* Set the symbols type, upto it was BT_UNKNOWN. */
6603 if (IS_CLASS_ARRAY (code
->expr3
)
6604 && code
->expr3
->expr_type
== EXPR_FUNCTION
6605 && code
->expr3
->value
.function
.isym
6606 && code
->expr3
->value
.function
.isym
->transformational
)
6608 e3rhs
->ts
= CLASS_DATA (code
->expr3
)->ts
;
6610 else if (code
->expr3
->ts
.type
== BT_CLASS
6611 && !GFC_CLASS_TYPE_P (TREE_TYPE (expr3
)))
6612 e3rhs
->ts
= CLASS_DATA (code
->expr3
)->ts
;
6614 e3rhs
->ts
= code
->expr3
->ts
;
6615 newsym
->n
.sym
->ts
= e3rhs
->ts
;
6616 /* Check whether the expr3 is array valued. */
6619 gfc_array_spec
*arr
;
6620 arr
= gfc_get_array_spec ();
6621 arr
->rank
= e3rhs
->rank
;
6622 arr
->type
= AS_DEFERRED
;
6623 /* Set the dimension and pointer attribute for arrays
6624 to be on the safe side. */
6625 newsym
->n
.sym
->attr
.dimension
= 1;
6626 newsym
->n
.sym
->attr
.pointer
= 1;
6627 newsym
->n
.sym
->as
= arr
;
6628 if (IS_CLASS_ARRAY (code
->expr3
)
6629 && code
->expr3
->expr_type
== EXPR_FUNCTION
6630 && code
->expr3
->value
.function
.isym
6631 && code
->expr3
->value
.function
.isym
->transformational
)
6633 gfc_array_spec
*tarr
;
6634 tarr
= gfc_get_array_spec ();
6636 e3rhs
->ts
.u
.derived
->as
= tarr
;
6638 gfc_add_full_array_ref (e3rhs
, arr
);
6640 else if (POINTER_TYPE_P (TREE_TYPE (expr3
)))
6641 newsym
->n
.sym
->attr
.pointer
= 1;
6642 /* The string length is known, too. Set it for char arrays. */
6643 if (e3rhs
->ts
.type
== BT_CHARACTER
)
6644 newsym
->n
.sym
->ts
.u
.cl
->backend_decl
= expr3_len
;
6645 gfc_commit_symbol (newsym
->n
.sym
);
6648 e3rhs
= gfc_copy_expr (code
->expr3
);
6650 // We need to propagate the bounds of the expr3 for source=/mold=.
6651 // However, for non-named arrays, the lbound has to be 1 and neither the
6652 // bound used inside the called function even when returning an
6653 // allocatable/pointer nor the zero used internally.
6654 if (e3_is
== E3_DESC
6655 && code
->expr3
->expr_type
!= EXPR_VARIABLE
)
6656 e3_has_nodescriptor
= true;
6659 /* Loop over all objects to allocate. */
6660 for (al
= code
->ext
.alloc
.list
; al
!= NULL
; al
= al
->next
)
6662 expr
= gfc_copy_expr (al
->expr
);
6663 /* UNLIMITED_POLY () needs the _data component to be set, when
6664 expr is a unlimited polymorphic object. But the _data component
6665 has not been set yet, so check the derived type's attr for the
6666 unlimited polymorphic flag to be safe. */
6667 upoly_expr
= UNLIMITED_POLY (expr
)
6668 || (expr
->ts
.type
== BT_DERIVED
6669 && expr
->ts
.u
.derived
->attr
.unlimited_polymorphic
);
6670 gfc_init_se (&se
, NULL
);
6672 /* For class types prepare the expressions to ref the _vptr
6673 and the _len component. The latter for unlimited polymorphic
6675 if (expr
->ts
.type
== BT_CLASS
)
6677 gfc_expr
*expr_ref_vptr
, *expr_ref_len
;
6678 gfc_add_data_component (expr
);
6679 /* Prep the vptr handle. */
6680 expr_ref_vptr
= gfc_copy_expr (al
->expr
);
6681 gfc_add_vptr_component (expr_ref_vptr
);
6682 se
.want_pointer
= 1;
6683 gfc_conv_expr (&se
, expr_ref_vptr
);
6685 se
.want_pointer
= 0;
6686 gfc_free_expr (expr_ref_vptr
);
6687 /* Allocated unlimited polymorphic objects always have a _len
6691 expr_ref_len
= gfc_copy_expr (al
->expr
);
6692 gfc_add_len_component (expr_ref_len
);
6693 gfc_conv_expr (&se
, expr_ref_len
);
6695 gfc_free_expr (expr_ref_len
);
6698 /* In a loop ensure that all loop variable dependent variables
6699 are initialized at the same spot in all execution paths. */
6703 al_vptr
= al_len
= NULL_TREE
;
6705 se
.want_pointer
= 1;
6706 se
.descriptor_only
= 1;
6708 gfc_conv_expr (&se
, expr
);
6709 if (expr
->ts
.type
== BT_CHARACTER
&& expr
->ts
.deferred
)
6710 /* se.string_length now stores the .string_length variable of expr
6711 needed to allocate character(len=:) arrays. */
6712 al_len
= se
.string_length
;
6714 al_len_needs_set
= al_len
!= NULL_TREE
;
6715 /* When allocating an array one cannot use much of the
6716 pre-evaluated expr3 expressions, because for most of them the
6717 scalarizer is needed which is not available in the pre-evaluation
6718 step. Therefore gfc_array_allocate () is responsible (and able)
6719 to handle the complete array allocation. Only the element size
6720 needs to be provided, which is done most of the time by the
6721 pre-evaluation step. */
6723 if (expr3_len
&& (code
->expr3
->ts
.type
== BT_CHARACTER
6724 || code
->expr3
->ts
.type
== BT_CLASS
))
6726 /* When al is an array, then the element size for each element
6727 in the array is needed, which is the product of the len and
6728 esize for char arrays. For unlimited polymorphics len can be
6729 zero, therefore take the maximum of len and one. */
6730 tmp
= fold_build2_loc (input_location
, MAX_EXPR
,
6731 TREE_TYPE (expr3_len
),
6732 expr3_len
, fold_convert (TREE_TYPE (expr3_len
),
6734 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
6735 TREE_TYPE (expr3_esize
), expr3_esize
,
6736 fold_convert (TREE_TYPE (expr3_esize
), tmp
));
6741 if (!gfc_array_allocate (&se
, expr
, stat
, errmsg
, errlen
,
6742 label_finish
, tmp
, &nelems
,
6743 e3rhs
? e3rhs
: code
->expr3
,
6744 e3_is
== E3_DESC
? expr3
: NULL_TREE
,
6745 e3_has_nodescriptor
))
6747 /* A scalar or derived type. First compute the size to
6750 expr3_len is set when expr3 is an unlimited polymorphic
6751 object or a deferred length string. */
6752 if (expr3_len
!= NULL_TREE
)
6754 tmp
= fold_convert (TREE_TYPE (expr3_esize
), expr3_len
);
6755 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
6756 TREE_TYPE (expr3_esize
),
6758 if (code
->expr3
->ts
.type
!= BT_CLASS
)
6759 /* expr3 is a deferred length string, i.e., we are
6764 /* For unlimited polymorphic enties build
6765 (len > 0) ? element_size * len : element_size
6766 to compute the number of bytes to allocate.
6767 This allows the allocation of unlimited polymorphic
6768 objects from an expr3 that is also unlimited
6769 polymorphic and stores a _len dependent object,
6771 memsz
= fold_build2_loc (input_location
, GT_EXPR
,
6772 logical_type_node
, expr3_len
,
6774 (TREE_TYPE (expr3_len
)));
6775 memsz
= fold_build3_loc (input_location
, COND_EXPR
,
6776 TREE_TYPE (expr3_esize
),
6777 memsz
, tmp
, expr3_esize
);
6780 else if (expr3_esize
!= NULL_TREE
)
6781 /* Any other object in expr3 just needs element size in
6783 memsz
= expr3_esize
;
6784 else if ((expr
->ts
.type
== BT_CHARACTER
&& expr
->ts
.deferred
)
6786 && code
->ext
.alloc
.ts
.type
== BT_CHARACTER
))
6788 /* Allocating deferred length char arrays need the length
6789 to allocate in the alloc_type_spec. But also unlimited
6790 polymorphic objects may be allocated as char arrays.
6791 Both are handled here. */
6792 gfc_init_se (&se_sz
, NULL
);
6793 gfc_conv_expr (&se_sz
, code
->ext
.alloc
.ts
.u
.cl
->length
);
6794 gfc_add_block_to_block (&se
.pre
, &se_sz
.pre
);
6795 se_sz
.expr
= gfc_evaluate_now (se_sz
.expr
, &se
.pre
);
6796 gfc_add_block_to_block (&se
.pre
, &se_sz
.post
);
6797 expr3_len
= se_sz
.expr
;
6798 tmp_expr3_len_flag
= true;
6799 tmp
= TYPE_SIZE_UNIT (
6800 gfc_get_char_type (code
->ext
.alloc
.ts
.kind
));
6801 memsz
= fold_build2_loc (input_location
, MULT_EXPR
,
6803 fold_convert (TREE_TYPE (tmp
),
6807 else if (expr
->ts
.type
== BT_CHARACTER
)
6809 /* Compute the number of bytes needed to allocate a fixed
6810 length char array. */
6811 gcc_assert (se
.string_length
!= NULL_TREE
);
6812 tmp
= TYPE_SIZE_UNIT (gfc_get_char_type (expr
->ts
.kind
));
6813 memsz
= fold_build2_loc (input_location
, MULT_EXPR
,
6814 TREE_TYPE (tmp
), tmp
,
6815 fold_convert (TREE_TYPE (tmp
),
6818 else if (code
->ext
.alloc
.ts
.type
!= BT_UNKNOWN
)
6819 /* Handle all types, where the alloc_type_spec is set. */
6820 memsz
= TYPE_SIZE_UNIT (gfc_typenode_for_spec (&code
->ext
.alloc
.ts
));
6822 /* Handle size computation of the type declared to alloc. */
6823 memsz
= TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (se
.expr
)));
6825 /* Store the caf-attributes for latter use. */
6826 if (flag_coarray
== GFC_FCOARRAY_LIB
6827 && (caf_attr
= gfc_caf_attr (expr
, true, &caf_refs_comp
))
6830 /* Scalar allocatable components in coarray'ed derived types make
6831 it here and are treated now. */
6832 tree caf_decl
, token
;
6836 /* Set flag, to add synchronize after the allocate. */
6837 needs_caf_sync
= needs_caf_sync
6838 || caf_attr
.coarray_comp
|| !caf_refs_comp
;
6840 gfc_init_se (&caf_se
, NULL
);
6842 caf_decl
= gfc_get_tree_for_caf_expr (expr
);
6843 gfc_get_caf_token_offset (&caf_se
, &token
, NULL
, caf_decl
,
6845 gfc_add_block_to_block (&se
.pre
, &caf_se
.pre
);
6846 gfc_allocate_allocatable (&se
.pre
, se
.expr
, memsz
,
6847 gfc_build_addr_expr (NULL_TREE
, token
),
6848 NULL_TREE
, NULL_TREE
, NULL_TREE
,
6849 label_finish
, expr
, 1);
6851 /* Allocate - for non-pointers with re-alloc checking. */
6852 else if (gfc_expr_attr (expr
).allocatable
)
6853 gfc_allocate_allocatable (&se
.pre
, se
.expr
, memsz
,
6854 NULL_TREE
, stat
, errmsg
, errlen
,
6855 label_finish
, expr
, 0);
6857 gfc_allocate_using_malloc (&se
.pre
, se
.expr
, memsz
, stat
);
6861 /* Allocating coarrays needs a sync after the allocate executed.
6862 Set the flag to add the sync after all objects are allocated. */
6863 if (flag_coarray
== GFC_FCOARRAY_LIB
6864 && (caf_attr
= gfc_caf_attr (expr
, true, &caf_refs_comp
))
6868 needs_caf_sync
= needs_caf_sync
6869 || caf_attr
.coarray_comp
|| !caf_refs_comp
;
6872 if (expr
->ts
.type
== BT_CHARACTER
&& al_len
!= NULL_TREE
6873 && expr3_len
!= NULL_TREE
)
6875 /* Arrays need to have a _len set before the array
6876 descriptor is filled. */
6877 gfc_add_modify (&block
, al_len
,
6878 fold_convert (TREE_TYPE (al_len
), expr3_len
));
6879 /* Prevent setting the length twice. */
6880 al_len_needs_set
= false;
6882 else if (expr
->ts
.type
== BT_CHARACTER
&& al_len
!= NULL_TREE
6883 && code
->ext
.alloc
.ts
.u
.cl
->length
)
6885 /* Cover the cases where a string length is explicitly
6886 specified by a type spec for deferred length character
6887 arrays or unlimited polymorphic objects without a
6888 source= or mold= expression. */
6889 gfc_init_se (&se_sz
, NULL
);
6890 gfc_conv_expr (&se_sz
, code
->ext
.alloc
.ts
.u
.cl
->length
);
6891 gfc_add_block_to_block (&block
, &se_sz
.pre
);
6892 gfc_add_modify (&block
, al_len
,
6893 fold_convert (TREE_TYPE (al_len
),
6895 al_len_needs_set
= false;
6899 gfc_add_block_to_block (&block
, &se
.pre
);
6901 /* Error checking -- Note: ERRMSG only makes sense with STAT. */
6904 tmp
= build1_v (GOTO_EXPR
, label_errmsg
);
6905 parm
= fold_build2_loc (input_location
, NE_EXPR
,
6906 logical_type_node
, stat
,
6907 build_int_cst (TREE_TYPE (stat
), 0));
6908 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
6909 gfc_unlikely (parm
, PRED_FORTRAN_FAIL_ALLOC
),
6910 tmp
, build_empty_stmt (input_location
));
6911 gfc_add_expr_to_block (&block
, tmp
);
6914 /* Set the vptr only when no source= is set. When source= is set, then
6915 the trans_assignment below will set the vptr. */
6916 if (al_vptr
!= NULL_TREE
&& (!code
->expr3
|| code
->expr3
->mold
))
6918 if (expr3_vptr
!= NULL_TREE
)
6919 /* The vtab is already known, so just assign it. */
6920 gfc_add_modify (&block
, al_vptr
,
6921 fold_convert (TREE_TYPE (al_vptr
), expr3_vptr
));
6924 /* VPTR is fixed at compile time. */
6929 /* Although expr3 is pre-evaluated above, it may happen,
6930 that for arrays or in mold= cases the pre-evaluation
6931 was not successful. In these rare cases take the vtab
6932 from the typespec of expr3 here. */
6933 ts
= &code
->expr3
->ts
;
6934 else if (code
->ext
.alloc
.ts
.type
== BT_DERIVED
|| upoly_expr
)
6935 /* The alloc_type_spec gives the type to allocate or the
6936 al is unlimited polymorphic, which enforces the use of
6937 an alloc_type_spec that is not necessarily a BT_DERIVED. */
6938 ts
= &code
->ext
.alloc
.ts
;
6940 /* Prepare for setting the vtab as declared. */
6943 vtab
= gfc_find_vtab (ts
);
6945 tmp
= gfc_build_addr_expr (NULL_TREE
,
6946 gfc_get_symbol_decl (vtab
));
6947 gfc_add_modify (&block
, al_vptr
,
6948 fold_convert (TREE_TYPE (al_vptr
), tmp
));
6952 /* Add assignment for string length. */
6953 if (al_len
!= NULL_TREE
&& al_len_needs_set
)
6955 if (expr3_len
!= NULL_TREE
)
6957 gfc_add_modify (&block
, al_len
,
6958 fold_convert (TREE_TYPE (al_len
),
6960 /* When tmp_expr3_len_flag is set, then expr3_len is
6961 abused to carry the length information from the
6962 alloc_type. Clear it to prevent setting incorrect len
6963 information in future loop iterations. */
6964 if (tmp_expr3_len_flag
)
6965 /* No need to reset tmp_expr3_len_flag, because the
6966 presence of an expr3 cannot change within in the
6968 expr3_len
= NULL_TREE
;
6970 else if (code
->ext
.alloc
.ts
.type
== BT_CHARACTER
6971 && code
->ext
.alloc
.ts
.u
.cl
->length
)
6973 /* Cover the cases where a string length is explicitly
6974 specified by a type spec for deferred length character
6975 arrays or unlimited polymorphic objects without a
6976 source= or mold= expression. */
6977 if (expr3_esize
== NULL_TREE
|| code
->ext
.alloc
.ts
.kind
!= 1)
6979 gfc_init_se (&se_sz
, NULL
);
6980 gfc_conv_expr (&se_sz
, code
->ext
.alloc
.ts
.u
.cl
->length
);
6981 gfc_add_block_to_block (&block
, &se_sz
.pre
);
6982 gfc_add_modify (&block
, al_len
,
6983 fold_convert (TREE_TYPE (al_len
),
6987 gfc_add_modify (&block
, al_len
,
6988 fold_convert (TREE_TYPE (al_len
),
6992 /* No length information needed, because type to allocate
6993 has no length. Set _len to 0. */
6994 gfc_add_modify (&block
, al_len
,
6995 fold_convert (TREE_TYPE (al_len
),
6996 integer_zero_node
));
7000 if (code
->expr3
&& !code
->expr3
->mold
&& e3_is
!= E3_MOLD
)
7002 /* Initialization via SOURCE block (or static default initializer).
7003 Switch off automatic reallocation since we have just done the
7005 int realloc_lhs
= flag_realloc_lhs
;
7006 gfc_expr
*init_expr
= gfc_expr_to_initialize (expr
);
7007 gfc_expr
*rhs
= e3rhs
? e3rhs
: gfc_copy_expr (code
->expr3
);
7008 flag_realloc_lhs
= 0;
7009 tmp
= gfc_trans_assignment (init_expr
, rhs
, true, false, true,
7011 flag_realloc_lhs
= realloc_lhs
;
7012 /* Free the expression allocated for init_expr. */
7013 gfc_free_expr (init_expr
);
7015 gfc_free_expr (rhs
);
7016 gfc_add_expr_to_block (&block
, tmp
);
7018 /* Set KIND and LEN PDT components and allocate those that are
7020 else if (expr
->ts
.type
== BT_DERIVED
7021 && expr
->ts
.u
.derived
->attr
.pdt_type
)
7023 if (code
->expr3
&& code
->expr3
->param_list
)
7024 param_list
= code
->expr3
->param_list
;
7025 else if (expr
->param_list
)
7026 param_list
= expr
->param_list
;
7028 param_list
= expr
->symtree
->n
.sym
->param_list
;
7029 tmp
= gfc_allocate_pdt_comp (expr
->ts
.u
.derived
, se
.expr
,
7030 expr
->rank
, param_list
);
7031 gfc_add_expr_to_block (&block
, tmp
);
7033 /* Ditto for CLASS expressions. */
7034 else if (expr
->ts
.type
== BT_CLASS
7035 && CLASS_DATA (expr
)->ts
.u
.derived
->attr
.pdt_type
)
7037 if (code
->expr3
&& code
->expr3
->param_list
)
7038 param_list
= code
->expr3
->param_list
;
7039 else if (expr
->param_list
)
7040 param_list
= expr
->param_list
;
7042 param_list
= expr
->symtree
->n
.sym
->param_list
;
7043 tmp
= gfc_allocate_pdt_comp (CLASS_DATA (expr
)->ts
.u
.derived
,
7044 se
.expr
, expr
->rank
, param_list
);
7045 gfc_add_expr_to_block (&block
, tmp
);
7047 else if (code
->expr3
&& code
->expr3
->mold
7048 && code
->expr3
->ts
.type
== BT_CLASS
)
7050 /* Use class_init_assign to initialize expr. */
7052 ini
= gfc_get_code (EXEC_INIT_ASSIGN
);
7053 ini
->expr1
= gfc_find_and_cut_at_last_class_ref (expr
, true);
7054 tmp
= gfc_trans_class_init_assign (ini
);
7055 gfc_free_statements (ini
);
7056 gfc_add_expr_to_block (&block
, tmp
);
7058 else if ((init_expr
= allocate_get_initializer (code
, expr
)))
7060 /* Use class_init_assign to initialize expr. */
7062 int realloc_lhs
= flag_realloc_lhs
;
7063 ini
= gfc_get_code (EXEC_INIT_ASSIGN
);
7064 ini
->expr1
= gfc_expr_to_initialize (expr
);
7065 ini
->expr2
= init_expr
;
7066 flag_realloc_lhs
= 0;
7067 tmp
= gfc_trans_init_assign (ini
);
7068 flag_realloc_lhs
= realloc_lhs
;
7069 gfc_free_statements (ini
);
7070 /* Init_expr is freeed by above free_statements, just need to null
7073 gfc_add_expr_to_block (&block
, tmp
);
7076 /* Nullify all pointers in derived type coarrays. This registers a
7077 token for them which allows their allocation. */
7080 gfc_symbol
*type
= NULL
;
7081 symbol_attribute caf_attr
;
7083 if (code
->ext
.alloc
.ts
.type
== BT_DERIVED
7084 && code
->ext
.alloc
.ts
.u
.derived
->attr
.pointer_comp
)
7086 type
= code
->ext
.alloc
.ts
.u
.derived
;
7087 rank
= type
->attr
.dimension
? type
->as
->rank
: 0;
7088 gfc_clear_attr (&caf_attr
);
7090 else if (expr
->ts
.type
== BT_DERIVED
7091 && expr
->ts
.u
.derived
->attr
.pointer_comp
)
7093 type
= expr
->ts
.u
.derived
;
7095 caf_attr
= gfc_caf_attr (expr
, true);
7098 /* Initialize the tokens of pointer components in derived type
7102 tmp
= (caf_attr
.codimension
&& !caf_attr
.dimension
)
7103 ? gfc_conv_descriptor_data_get (se
.expr
) : se
.expr
;
7104 tmp
= gfc_nullify_alloc_comp (type
, tmp
, rank
,
7105 GFC_STRUCTURE_CAF_MODE_IN_COARRAY
);
7106 gfc_add_expr_to_block (&block
, tmp
);
7110 gfc_free_expr (expr
);
7117 gfc_free_symbol (newsym
->n
.sym
);
7120 gfc_free_expr (e3rhs
);
7125 tmp
= build1_v (LABEL_EXPR
, label_errmsg
);
7126 gfc_add_expr_to_block (&block
, tmp
);
7129 /* ERRMSG - only useful if STAT is present. */
7130 if (code
->expr1
&& code
->expr2
)
7132 const char *msg
= "Attempt to allocate an allocated object";
7133 const char *oommsg
= "Insufficient virtual memory";
7134 tree slen
, dlen
, errmsg_str
, oom_str
, oom_loc
;
7135 stmtblock_t errmsg_block
;
7137 gfc_init_block (&errmsg_block
);
7139 errmsg_str
= gfc_create_var (pchar_type_node
, "ERRMSG");
7140 gfc_add_modify (&errmsg_block
, errmsg_str
,
7141 gfc_build_addr_expr (pchar_type_node
,
7142 gfc_build_localized_cstring_const (msg
)));
7144 slen
= build_int_cst (gfc_charlen_type_node
, strlen (msg
));
7145 dlen
= gfc_get_expr_charlen (code
->expr2
);
7146 slen
= fold_build2_loc (input_location
, MIN_EXPR
,
7147 TREE_TYPE (slen
), dlen
, slen
);
7149 gfc_trans_string_copy (&errmsg_block
, dlen
, errmsg
,
7150 code
->expr2
->ts
.kind
,
7152 gfc_default_character_kind
);
7153 dlen
= gfc_finish_block (&errmsg_block
);
7155 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
7156 stat
, build_int_cst (TREE_TYPE (stat
),
7157 LIBERROR_ALLOCATION
));
7159 tmp
= build3_v (COND_EXPR
, tmp
,
7160 dlen
, build_empty_stmt (input_location
));
7162 gfc_add_expr_to_block (&block
, tmp
);
7164 oom_str
= gfc_create_var (pchar_type_node
, "OOMMSG");
7165 oom_loc
= gfc_build_localized_cstring_const (oommsg
);
7166 gfc_add_modify (&errmsg_block
, oom_str
,
7167 gfc_build_addr_expr (pchar_type_node
, oom_loc
));
7169 slen
= build_int_cst (gfc_charlen_type_node
, strlen (oommsg
));
7170 dlen
= gfc_get_expr_charlen (code
->expr2
);
7171 slen
= fold_build2_loc (input_location
, MIN_EXPR
,
7172 TREE_TYPE (slen
), dlen
, slen
);
7174 gfc_trans_string_copy (&errmsg_block
, dlen
, errmsg
,
7175 code
->expr2
->ts
.kind
,
7177 gfc_default_character_kind
);
7178 dlen
= gfc_finish_block (&errmsg_block
);
7180 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
7181 stat
, build_int_cst (TREE_TYPE (stat
),
7182 LIBERROR_NO_MEMORY
));
7184 tmp
= build3_v (COND_EXPR
, tmp
,
7185 dlen
, build_empty_stmt (input_location
));
7187 gfc_add_expr_to_block (&block
, tmp
);
7193 if (TREE_USED (label_finish
))
7195 tmp
= build1_v (LABEL_EXPR
, label_finish
);
7196 gfc_add_expr_to_block (&block
, tmp
);
7199 gfc_init_se (&se
, NULL
);
7200 gfc_conv_expr_lhs (&se
, code
->expr1
);
7201 tmp
= convert (TREE_TYPE (se
.expr
), stat
);
7202 gfc_add_modify (&block
, se
.expr
, tmp
);
7207 /* Add a sync all after the allocation has been executed. */
7208 tree zero_size
= build_zero_cst (size_type_node
);
7209 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_sync_all
,
7210 3, null_pointer_node
, null_pointer_node
,
7212 gfc_add_expr_to_block (&post
, tmp
);
7215 gfc_add_block_to_block (&block
, &se
.post
);
7216 gfc_add_block_to_block (&block
, &post
);
7217 if (code
->expr3
&& code
->expr3
->must_finalize
)
7218 gfc_add_block_to_block (&block
, &final_block
);
7220 return gfc_finish_block (&block
);
7224 /* Translate a DEALLOCATE statement. */
7227 gfc_trans_deallocate (gfc_code
*code
)
7231 tree apstat
, pstat
, stat
, errmsg
, errlen
, tmp
;
7232 tree label_finish
, label_errmsg
;
7235 pstat
= apstat
= stat
= errmsg
= errlen
= tmp
= NULL_TREE
;
7236 label_finish
= label_errmsg
= NULL_TREE
;
7238 gfc_start_block (&block
);
7240 /* Count the number of failed deallocations. If deallocate() was
7241 called with STAT= , then set STAT to the count. If deallocate
7242 was called with ERRMSG, then set ERRMG to a string. */
7245 tree gfc_int4_type_node
= gfc_get_int_type (4);
7247 stat
= gfc_create_var (gfc_int4_type_node
, "stat");
7248 pstat
= gfc_build_addr_expr (NULL_TREE
, stat
);
7250 /* GOTO destinations. */
7251 label_errmsg
= gfc_build_label_decl (NULL_TREE
);
7252 label_finish
= gfc_build_label_decl (NULL_TREE
);
7253 TREE_USED (label_finish
) = 0;
7256 /* Set ERRMSG - only needed if STAT is available. */
7257 if (code
->expr1
&& code
->expr2
)
7259 gfc_init_se (&se
, NULL
);
7260 se
.want_pointer
= 1;
7261 gfc_conv_expr_lhs (&se
, code
->expr2
);
7263 errlen
= se
.string_length
;
7266 for (al
= code
->ext
.alloc
.list
; al
!= NULL
; al
= al
->next
)
7268 gfc_expr
*expr
= gfc_copy_expr (al
->expr
);
7269 bool is_coarray
= false, is_coarray_array
= false;
7272 gcc_assert (expr
->expr_type
== EXPR_VARIABLE
);
7274 if (expr
->ts
.type
== BT_CLASS
)
7275 gfc_add_data_component (expr
);
7277 gfc_init_se (&se
, NULL
);
7278 gfc_start_block (&se
.pre
);
7280 se
.want_pointer
= 1;
7281 se
.descriptor_only
= 1;
7282 gfc_conv_expr (&se
, expr
);
7284 /* Deallocate PDT components that are parameterized. */
7286 if (expr
->ts
.type
== BT_DERIVED
7287 && expr
->ts
.u
.derived
->attr
.pdt_type
7288 && expr
->symtree
->n
.sym
->param_list
)
7289 tmp
= gfc_deallocate_pdt_comp (expr
->ts
.u
.derived
, se
.expr
, expr
->rank
);
7290 else if (expr
->ts
.type
== BT_CLASS
7291 && CLASS_DATA (expr
)->ts
.u
.derived
->attr
.pdt_type
7292 && expr
->symtree
->n
.sym
->param_list
)
7293 tmp
= gfc_deallocate_pdt_comp (CLASS_DATA (expr
)->ts
.u
.derived
,
7294 se
.expr
, expr
->rank
);
7297 gfc_add_expr_to_block (&block
, tmp
);
7299 if (flag_coarray
== GFC_FCOARRAY_LIB
7300 || flag_coarray
== GFC_FCOARRAY_SINGLE
)
7303 symbol_attribute caf_attr
= gfc_caf_attr (expr
, false, &comp_ref
);
7304 if (caf_attr
.codimension
)
7307 is_coarray_array
= caf_attr
.dimension
|| !comp_ref
7308 || caf_attr
.coarray_comp
;
7310 if (flag_coarray
== GFC_FCOARRAY_LIB
)
7311 /* When the expression to deallocate is referencing a
7312 component, then only deallocate it, but do not
7314 caf_mode
= GFC_STRUCTURE_CAF_MODE_IN_COARRAY
7315 | (comp_ref
&& !caf_attr
.coarray_comp
7316 ? GFC_STRUCTURE_CAF_MODE_DEALLOC_ONLY
: 0);
7320 if (expr
->rank
|| is_coarray_array
)
7324 if (gfc_bt_struct (expr
->ts
.type
)
7325 && expr
->ts
.u
.derived
->attr
.alloc_comp
7326 && !gfc_is_finalizable (expr
->ts
.u
.derived
, NULL
))
7328 gfc_ref
*last
= NULL
;
7330 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
7331 if (ref
->type
== REF_COMPONENT
)
7334 /* Do not deallocate the components of a derived type
7335 ultimate pointer component. */
7336 if (!(last
&& last
->u
.c
.component
->attr
.pointer
)
7337 && !(!last
&& expr
->symtree
->n
.sym
->attr
.pointer
))
7339 if (is_coarray
&& expr
->rank
== 0
7340 && (!last
|| !last
->u
.c
.component
->attr
.dimension
)
7341 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se
.expr
)))
7343 /* Add the ref to the data member only, when this is not
7344 a regular array or deallocate_alloc_comp will try to
7346 tmp
= gfc_conv_descriptor_data_get (se
.expr
);
7350 tmp
= gfc_deallocate_alloc_comp (expr
->ts
.u
.derived
, tmp
,
7351 expr
->rank
, caf_mode
);
7352 gfc_add_expr_to_block (&se
.pre
, tmp
);
7356 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se
.expr
)))
7358 gfc_coarray_deregtype caf_dtype
;
7361 caf_dtype
= gfc_caf_is_dealloc_only (caf_mode
)
7362 ? GFC_CAF_COARRAY_DEALLOCATE_ONLY
7363 : GFC_CAF_COARRAY_DEREGISTER
;
7365 caf_dtype
= GFC_CAF_COARRAY_NOCOARRAY
;
7366 tmp
= gfc_deallocate_with_status (se
.expr
, pstat
, errmsg
, errlen
,
7367 label_finish
, false, expr
,
7369 gfc_add_expr_to_block (&se
.pre
, tmp
);
7371 else if (TREE_CODE (se
.expr
) == COMPONENT_REF
7372 && TREE_CODE (TREE_TYPE (se
.expr
)) == ARRAY_TYPE
7373 && TREE_CODE (TREE_TYPE (TREE_TYPE (se
.expr
)))
7376 /* class.cc(finalize_component) generates these, when a
7377 finalizable entity has a non-allocatable derived type array
7378 component, which has allocatable components. Obtain the
7379 derived type of the array and deallocate the allocatable
7381 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
7383 if (ref
->u
.c
.component
->attr
.dimension
7384 && ref
->u
.c
.component
->ts
.type
== BT_DERIVED
)
7388 if (ref
&& ref
->u
.c
.component
->ts
.u
.derived
->attr
.alloc_comp
7389 && !gfc_is_finalizable (ref
->u
.c
.component
->ts
.u
.derived
,
7392 tmp
= gfc_deallocate_alloc_comp
7393 (ref
->u
.c
.component
->ts
.u
.derived
,
7394 se
.expr
, expr
->rank
);
7395 gfc_add_expr_to_block (&se
.pre
, tmp
);
7399 if (al
->expr
->ts
.type
== BT_CLASS
)
7401 gfc_reset_vptr (&se
.pre
, al
->expr
);
7402 if (UNLIMITED_POLY (al
->expr
)
7403 || (al
->expr
->ts
.type
== BT_DERIVED
7404 && al
->expr
->ts
.u
.derived
->attr
.unlimited_polymorphic
))
7405 /* Clear _len, too. */
7406 gfc_reset_len (&se
.pre
, al
->expr
);
7411 tmp
= gfc_deallocate_scalar_with_status (se
.expr
, pstat
, label_finish
,
7413 al
->expr
->ts
, is_coarray
);
7414 gfc_add_expr_to_block (&se
.pre
, tmp
);
7416 /* Set to zero after deallocation. */
7417 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
, void_type_node
,
7419 build_int_cst (TREE_TYPE (se
.expr
), 0));
7420 gfc_add_expr_to_block (&se
.pre
, tmp
);
7422 if (al
->expr
->ts
.type
== BT_CLASS
)
7424 gfc_reset_vptr (&se
.pre
, al
->expr
);
7425 if (UNLIMITED_POLY (al
->expr
)
7426 || (al
->expr
->ts
.type
== BT_DERIVED
7427 && al
->expr
->ts
.u
.derived
->attr
.unlimited_polymorphic
))
7428 /* Clear _len, too. */
7429 gfc_reset_len (&se
.pre
, al
->expr
);
7437 cond
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
, stat
,
7438 build_int_cst (TREE_TYPE (stat
), 0));
7439 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
7440 gfc_unlikely (cond
, PRED_FORTRAN_FAIL_ALLOC
),
7441 build1_v (GOTO_EXPR
, label_errmsg
),
7442 build_empty_stmt (input_location
));
7443 gfc_add_expr_to_block (&se
.pre
, tmp
);
7446 tmp
= gfc_finish_block (&se
.pre
);
7447 gfc_add_expr_to_block (&block
, tmp
);
7448 gfc_free_expr (expr
);
7453 tmp
= build1_v (LABEL_EXPR
, label_errmsg
);
7454 gfc_add_expr_to_block (&block
, tmp
);
7457 /* Set ERRMSG - only needed if STAT is available. */
7458 if (code
->expr1
&& code
->expr2
)
7460 const char *msg
= "Attempt to deallocate an unallocated object";
7461 stmtblock_t errmsg_block
;
7462 tree errmsg_str
, slen
, dlen
, cond
;
7464 gfc_init_block (&errmsg_block
);
7466 errmsg_str
= gfc_create_var (pchar_type_node
, "ERRMSG");
7467 gfc_add_modify (&errmsg_block
, errmsg_str
,
7468 gfc_build_addr_expr (pchar_type_node
,
7469 gfc_build_localized_cstring_const (msg
)));
7470 slen
= build_int_cst (gfc_charlen_type_node
, strlen (msg
));
7471 dlen
= gfc_get_expr_charlen (code
->expr2
);
7473 gfc_trans_string_copy (&errmsg_block
, dlen
, errmsg
, code
->expr2
->ts
.kind
,
7474 slen
, errmsg_str
, gfc_default_character_kind
);
7475 tmp
= gfc_finish_block (&errmsg_block
);
7477 cond
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
, stat
,
7478 build_int_cst (TREE_TYPE (stat
), 0));
7479 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
7480 gfc_unlikely (cond
, PRED_FORTRAN_FAIL_ALLOC
), tmp
,
7481 build_empty_stmt (input_location
));
7483 gfc_add_expr_to_block (&block
, tmp
);
7486 if (code
->expr1
&& TREE_USED (label_finish
))
7488 tmp
= build1_v (LABEL_EXPR
, label_finish
);
7489 gfc_add_expr_to_block (&block
, tmp
);
7495 gfc_init_se (&se
, NULL
);
7496 gfc_conv_expr_lhs (&se
, code
->expr1
);
7497 tmp
= convert (TREE_TYPE (se
.expr
), stat
);
7498 gfc_add_modify (&block
, se
.expr
, tmp
);
7501 return gfc_finish_block (&block
);
7504 #include "gt-fortran-trans-stmt.h"