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
)
656 /* Start a new block for this statement. */
657 gfc_init_se (&se
, NULL
);
658 gfc_start_block (&se
.pre
);
660 if (code
->expr1
== NULL
)
662 tmp
= build_int_cst (size_type_node
, 0);
663 tmp
= build_call_expr_loc (input_location
,
665 ? (flag_coarray
== GFC_FCOARRAY_LIB
666 ? gfor_fndecl_caf_error_stop_str
667 : gfor_fndecl_error_stop_string
)
668 : (flag_coarray
== GFC_FCOARRAY_LIB
669 ? gfor_fndecl_caf_stop_str
670 : gfor_fndecl_stop_string
),
671 3, build_int_cst (pchar_type_node
, 0), tmp
,
674 else if (code
->expr1
->ts
.type
== BT_INTEGER
)
676 gfc_conv_expr (&se
, code
->expr1
);
677 tmp
= build_call_expr_loc (input_location
,
679 ? (flag_coarray
== GFC_FCOARRAY_LIB
680 ? gfor_fndecl_caf_error_stop
681 : gfor_fndecl_error_stop_numeric
)
682 : (flag_coarray
== GFC_FCOARRAY_LIB
683 ? gfor_fndecl_caf_stop_numeric
684 : gfor_fndecl_stop_numeric
), 2,
685 fold_convert (integer_type_node
, se
.expr
),
690 gfc_conv_expr_reference (&se
, code
->expr1
);
691 tmp
= build_call_expr_loc (input_location
,
693 ? (flag_coarray
== GFC_FCOARRAY_LIB
694 ? gfor_fndecl_caf_error_stop_str
695 : gfor_fndecl_error_stop_string
)
696 : (flag_coarray
== GFC_FCOARRAY_LIB
697 ? gfor_fndecl_caf_stop_str
698 : gfor_fndecl_stop_string
),
699 3, se
.expr
, fold_convert (size_type_node
,
704 gfc_add_expr_to_block (&se
.pre
, tmp
);
706 gfc_add_block_to_block (&se
.pre
, &se
.post
);
708 return gfc_finish_block (&se
.pre
);
711 /* Translate the FAIL IMAGE statement. */
714 gfc_trans_fail_image (gfc_code
*code ATTRIBUTE_UNUSED
)
716 if (flag_coarray
== GFC_FCOARRAY_LIB
)
717 return build_call_expr_loc (input_location
,
718 gfor_fndecl_caf_fail_image
, 0);
721 const char *name
= gfc_get_string (PREFIX ("exit_i%d"), 4);
722 gfc_symbol
*exsym
= gfc_get_intrinsic_sub_symbol (name
);
723 tree tmp
= gfc_get_symbol_decl (exsym
);
724 return build_call_expr_loc (input_location
, tmp
, 1, integer_zero_node
);
728 /* Translate the FORM TEAM statement. */
731 gfc_trans_form_team (gfc_code
*code
)
733 if (flag_coarray
== GFC_FCOARRAY_LIB
)
736 gfc_se argse1
, argse2
;
737 tree team_id
, team_type
, tmp
;
739 gfc_init_se (&se
, NULL
);
740 gfc_init_se (&argse1
, NULL
);
741 gfc_init_se (&argse2
, NULL
);
742 gfc_start_block (&se
.pre
);
744 gfc_conv_expr_val (&argse1
, code
->expr1
);
745 gfc_conv_expr_val (&argse2
, code
->expr2
);
746 team_id
= fold_convert (integer_type_node
, argse1
.expr
);
747 team_type
= gfc_build_addr_expr (ppvoid_type_node
, argse2
.expr
);
749 gfc_add_block_to_block (&se
.pre
, &argse1
.pre
);
750 gfc_add_block_to_block (&se
.pre
, &argse2
.pre
);
751 tmp
= build_call_expr_loc (input_location
,
752 gfor_fndecl_caf_form_team
, 3,
754 build_int_cst (integer_type_node
, 0));
755 gfc_add_expr_to_block (&se
.pre
, tmp
);
756 gfc_add_block_to_block (&se
.pre
, &argse1
.post
);
757 gfc_add_block_to_block (&se
.pre
, &argse2
.post
);
758 return gfc_finish_block (&se
.pre
);
762 const char *name
= gfc_get_string (PREFIX ("exit_i%d"), 4);
763 gfc_symbol
*exsym
= gfc_get_intrinsic_sub_symbol (name
);
764 tree tmp
= gfc_get_symbol_decl (exsym
);
765 return build_call_expr_loc (input_location
, tmp
, 1, integer_zero_node
);
769 /* Translate the CHANGE TEAM statement. */
772 gfc_trans_change_team (gfc_code
*code
)
774 if (flag_coarray
== GFC_FCOARRAY_LIB
)
779 gfc_init_se (&argse
, NULL
);
780 gfc_conv_expr_val (&argse
, code
->expr1
);
781 team_type
= gfc_build_addr_expr (ppvoid_type_node
, argse
.expr
);
783 tmp
= build_call_expr_loc (input_location
,
784 gfor_fndecl_caf_change_team
, 2, team_type
,
785 build_int_cst (integer_type_node
, 0));
786 gfc_add_expr_to_block (&argse
.pre
, tmp
);
787 gfc_add_block_to_block (&argse
.pre
, &argse
.post
);
788 return gfc_finish_block (&argse
.pre
);
792 const char *name
= gfc_get_string (PREFIX ("exit_i%d"), 4);
793 gfc_symbol
*exsym
= gfc_get_intrinsic_sub_symbol (name
);
794 tree tmp
= gfc_get_symbol_decl (exsym
);
795 return build_call_expr_loc (input_location
, tmp
, 1, integer_zero_node
);
799 /* Translate the END TEAM statement. */
802 gfc_trans_end_team (gfc_code
*code ATTRIBUTE_UNUSED
)
804 if (flag_coarray
== GFC_FCOARRAY_LIB
)
806 return build_call_expr_loc (input_location
,
807 gfor_fndecl_caf_end_team
, 1,
808 build_int_cst (pchar_type_node
, 0));
812 const char *name
= gfc_get_string (PREFIX ("exit_i%d"), 4);
813 gfc_symbol
*exsym
= gfc_get_intrinsic_sub_symbol (name
);
814 tree tmp
= gfc_get_symbol_decl (exsym
);
815 return build_call_expr_loc (input_location
, tmp
, 1, integer_zero_node
);
819 /* Translate the SYNC TEAM statement. */
822 gfc_trans_sync_team (gfc_code
*code
)
824 if (flag_coarray
== GFC_FCOARRAY_LIB
)
829 gfc_init_se (&argse
, NULL
);
830 gfc_conv_expr_val (&argse
, code
->expr1
);
831 team_type
= gfc_build_addr_expr (ppvoid_type_node
, argse
.expr
);
833 tmp
= build_call_expr_loc (input_location
,
834 gfor_fndecl_caf_sync_team
, 2,
836 build_int_cst (integer_type_node
, 0));
837 gfc_add_expr_to_block (&argse
.pre
, tmp
);
838 gfc_add_block_to_block (&argse
.pre
, &argse
.post
);
839 return gfc_finish_block (&argse
.pre
);
843 const char *name
= gfc_get_string (PREFIX ("exit_i%d"), 4);
844 gfc_symbol
*exsym
= gfc_get_intrinsic_sub_symbol (name
);
845 tree tmp
= gfc_get_symbol_decl (exsym
);
846 return build_call_expr_loc (input_location
, tmp
, 1, integer_zero_node
);
851 gfc_trans_lock_unlock (gfc_code
*code
, gfc_exec_op op
)
854 tree stat
= NULL_TREE
, stat2
= NULL_TREE
;
855 tree lock_acquired
= NULL_TREE
, lock_acquired2
= NULL_TREE
;
857 /* Short cut: For single images without STAT= or LOCK_ACQUIRED
858 return early. (ERRMSG= is always untouched for -fcoarray=single.) */
859 if (!code
->expr2
&& !code
->expr4
&& flag_coarray
!= GFC_FCOARRAY_LIB
)
864 gcc_assert (code
->expr2
->expr_type
== EXPR_VARIABLE
);
865 gfc_init_se (&argse
, NULL
);
866 gfc_conv_expr_val (&argse
, code
->expr2
);
869 else if (flag_coarray
== GFC_FCOARRAY_LIB
)
870 stat
= null_pointer_node
;
874 gcc_assert (code
->expr4
->expr_type
== EXPR_VARIABLE
);
875 gfc_init_se (&argse
, NULL
);
876 gfc_conv_expr_val (&argse
, code
->expr4
);
877 lock_acquired
= argse
.expr
;
879 else if (flag_coarray
== GFC_FCOARRAY_LIB
)
880 lock_acquired
= null_pointer_node
;
882 gfc_start_block (&se
.pre
);
883 if (flag_coarray
== GFC_FCOARRAY_LIB
)
885 tree tmp
, token
, image_index
, errmsg
, errmsg_len
;
886 tree index
= build_zero_cst (gfc_array_index_type
);
887 tree caf_decl
= gfc_get_tree_for_caf_expr (code
->expr1
);
889 if (code
->expr1
->symtree
->n
.sym
->ts
.type
!= BT_DERIVED
890 || code
->expr1
->symtree
->n
.sym
->ts
.u
.derived
->from_intmod
891 != INTMOD_ISO_FORTRAN_ENV
892 || code
->expr1
->symtree
->n
.sym
->ts
.u
.derived
->intmod_sym_id
893 != ISOFORTRAN_LOCK_TYPE
)
895 gfc_error ("Sorry, the lock component of derived type at %L is not "
896 "yet supported", &code
->expr1
->where
);
900 gfc_get_caf_token_offset (&se
, &token
, NULL
, caf_decl
, NULL_TREE
,
903 if (gfc_is_coindexed (code
->expr1
))
904 image_index
= gfc_caf_get_image_index (&se
.pre
, code
->expr1
, caf_decl
);
906 image_index
= integer_zero_node
;
908 /* For arrays, obtain the array index. */
909 if (gfc_expr_attr (code
->expr1
).dimension
)
911 tree desc
, tmp
, extent
, lbound
, ubound
;
912 gfc_array_ref
*ar
, ar2
;
915 /* TODO: Extend this, once DT components are supported. */
916 ar
= &code
->expr1
->ref
->u
.ar
;
918 memset (ar
, '\0', sizeof (*ar
));
922 gfc_init_se (&argse
, NULL
);
923 argse
.descriptor_only
= 1;
924 gfc_conv_expr_descriptor (&argse
, code
->expr1
);
925 gfc_add_block_to_block (&se
.pre
, &argse
.pre
);
929 extent
= build_one_cst (gfc_array_index_type
);
930 for (i
= 0; i
< ar
->dimen
; i
++)
932 gfc_init_se (&argse
, NULL
);
933 gfc_conv_expr_type (&argse
, ar
->start
[i
], gfc_array_index_type
);
934 gfc_add_block_to_block (&argse
.pre
, &argse
.pre
);
935 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[i
]);
936 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
937 TREE_TYPE (lbound
), argse
.expr
, lbound
);
938 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
939 TREE_TYPE (tmp
), extent
, tmp
);
940 index
= fold_build2_loc (input_location
, PLUS_EXPR
,
941 TREE_TYPE (tmp
), index
, tmp
);
942 if (i
< ar
->dimen
- 1)
944 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[i
]);
945 tmp
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
946 extent
= fold_build2_loc (input_location
, MULT_EXPR
,
947 TREE_TYPE (tmp
), extent
, tmp
);
955 gfc_init_se (&argse
, NULL
);
956 argse
.want_pointer
= 1;
957 gfc_conv_expr (&argse
, code
->expr3
);
958 gfc_add_block_to_block (&se
.pre
, &argse
.pre
);
960 errmsg_len
= fold_convert (size_type_node
, argse
.string_length
);
964 errmsg
= null_pointer_node
;
965 errmsg_len
= build_zero_cst (size_type_node
);
968 if (stat
!= null_pointer_node
&& TREE_TYPE (stat
) != integer_type_node
)
971 stat
= gfc_create_var (integer_type_node
, "stat");
974 if (lock_acquired
!= null_pointer_node
975 && TREE_TYPE (lock_acquired
) != integer_type_node
)
977 lock_acquired2
= lock_acquired
;
978 lock_acquired
= gfc_create_var (integer_type_node
, "acquired");
981 index
= fold_convert (size_type_node
, index
);
983 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_lock
, 7,
984 token
, index
, image_index
,
985 lock_acquired
!= null_pointer_node
986 ? gfc_build_addr_expr (NULL
, lock_acquired
)
988 stat
!= null_pointer_node
989 ? gfc_build_addr_expr (NULL
, stat
) : stat
,
992 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_unlock
, 6,
993 token
, index
, image_index
,
994 stat
!= null_pointer_node
995 ? gfc_build_addr_expr (NULL
, stat
) : stat
,
997 gfc_add_expr_to_block (&se
.pre
, tmp
);
999 /* It guarantees memory consistency within the same segment */
1000 tmp
= gfc_build_string_const (strlen ("memory")+1, "memory"),
1001 tmp
= build5_loc (input_location
, ASM_EXPR
, void_type_node
,
1002 gfc_build_string_const (1, ""), NULL_TREE
, NULL_TREE
,
1003 tree_cons (NULL_TREE
, tmp
, NULL_TREE
), NULL_TREE
);
1004 ASM_VOLATILE_P (tmp
) = 1;
1006 gfc_add_expr_to_block (&se
.pre
, tmp
);
1008 if (stat2
!= NULL_TREE
)
1009 gfc_add_modify (&se
.pre
, stat2
,
1010 fold_convert (TREE_TYPE (stat2
), stat
));
1012 if (lock_acquired2
!= NULL_TREE
)
1013 gfc_add_modify (&se
.pre
, lock_acquired2
,
1014 fold_convert (TREE_TYPE (lock_acquired2
),
1017 return gfc_finish_block (&se
.pre
);
1020 if (stat
!= NULL_TREE
)
1021 gfc_add_modify (&se
.pre
, stat
, build_int_cst (TREE_TYPE (stat
), 0));
1023 if (lock_acquired
!= NULL_TREE
)
1024 gfc_add_modify (&se
.pre
, lock_acquired
,
1025 fold_convert (TREE_TYPE (lock_acquired
),
1026 boolean_true_node
));
1028 return gfc_finish_block (&se
.pre
);
1032 gfc_trans_event_post_wait (gfc_code
*code
, gfc_exec_op op
)
1035 tree stat
= NULL_TREE
, stat2
= NULL_TREE
;
1036 tree until_count
= NULL_TREE
;
1040 gcc_assert (code
->expr2
->expr_type
== EXPR_VARIABLE
);
1041 gfc_init_se (&argse
, NULL
);
1042 gfc_conv_expr_val (&argse
, code
->expr2
);
1045 else if (flag_coarray
== GFC_FCOARRAY_LIB
)
1046 stat
= null_pointer_node
;
1050 gfc_init_se (&argse
, NULL
);
1051 gfc_conv_expr_val (&argse
, code
->expr4
);
1052 until_count
= fold_convert (integer_type_node
, argse
.expr
);
1055 until_count
= integer_one_node
;
1057 if (flag_coarray
!= GFC_FCOARRAY_LIB
)
1059 gfc_start_block (&se
.pre
);
1060 gfc_init_se (&argse
, NULL
);
1061 gfc_conv_expr_val (&argse
, code
->expr1
);
1063 if (op
== EXEC_EVENT_POST
)
1064 gfc_add_modify (&se
.pre
, argse
.expr
,
1065 fold_build2_loc (input_location
, PLUS_EXPR
,
1066 TREE_TYPE (argse
.expr
), argse
.expr
,
1067 build_int_cst (TREE_TYPE (argse
.expr
), 1)));
1069 gfc_add_modify (&se
.pre
, argse
.expr
,
1070 fold_build2_loc (input_location
, MINUS_EXPR
,
1071 TREE_TYPE (argse
.expr
), argse
.expr
,
1072 fold_convert (TREE_TYPE (argse
.expr
),
1074 if (stat
!= NULL_TREE
)
1075 gfc_add_modify (&se
.pre
, stat
, build_int_cst (TREE_TYPE (stat
), 0));
1077 return gfc_finish_block (&se
.pre
);
1080 gfc_start_block (&se
.pre
);
1081 tree tmp
, token
, image_index
, errmsg
, errmsg_len
;
1082 tree index
= build_zero_cst (gfc_array_index_type
);
1083 tree caf_decl
= gfc_get_tree_for_caf_expr (code
->expr1
);
1085 if (code
->expr1
->symtree
->n
.sym
->ts
.type
!= BT_DERIVED
1086 || code
->expr1
->symtree
->n
.sym
->ts
.u
.derived
->from_intmod
1087 != INTMOD_ISO_FORTRAN_ENV
1088 || code
->expr1
->symtree
->n
.sym
->ts
.u
.derived
->intmod_sym_id
1089 != ISOFORTRAN_EVENT_TYPE
)
1091 gfc_error ("Sorry, the event component of derived type at %L is not "
1092 "yet supported", &code
->expr1
->where
);
1096 gfc_init_se (&argse
, NULL
);
1097 gfc_get_caf_token_offset (&argse
, &token
, NULL
, caf_decl
, NULL_TREE
,
1099 gfc_add_block_to_block (&se
.pre
, &argse
.pre
);
1101 if (gfc_is_coindexed (code
->expr1
))
1102 image_index
= gfc_caf_get_image_index (&se
.pre
, code
->expr1
, caf_decl
);
1104 image_index
= integer_zero_node
;
1106 /* For arrays, obtain the array index. */
1107 if (gfc_expr_attr (code
->expr1
).dimension
)
1109 tree desc
, tmp
, extent
, lbound
, ubound
;
1110 gfc_array_ref
*ar
, ar2
;
1113 /* TODO: Extend this, once DT components are supported. */
1114 ar
= &code
->expr1
->ref
->u
.ar
;
1116 memset (ar
, '\0', sizeof (*ar
));
1120 gfc_init_se (&argse
, NULL
);
1121 argse
.descriptor_only
= 1;
1122 gfc_conv_expr_descriptor (&argse
, code
->expr1
);
1123 gfc_add_block_to_block (&se
.pre
, &argse
.pre
);
1127 extent
= build_one_cst (gfc_array_index_type
);
1128 for (i
= 0; i
< ar
->dimen
; i
++)
1130 gfc_init_se (&argse
, NULL
);
1131 gfc_conv_expr_type (&argse
, ar
->start
[i
], gfc_array_index_type
);
1132 gfc_add_block_to_block (&argse
.pre
, &argse
.pre
);
1133 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[i
]);
1134 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
1135 TREE_TYPE (lbound
), argse
.expr
, lbound
);
1136 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
1137 TREE_TYPE (tmp
), extent
, tmp
);
1138 index
= fold_build2_loc (input_location
, PLUS_EXPR
,
1139 TREE_TYPE (tmp
), index
, tmp
);
1140 if (i
< ar
->dimen
- 1)
1142 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[i
]);
1143 tmp
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
1144 extent
= fold_build2_loc (input_location
, MULT_EXPR
,
1145 TREE_TYPE (tmp
), extent
, tmp
);
1153 gfc_init_se (&argse
, NULL
);
1154 argse
.want_pointer
= 1;
1155 gfc_conv_expr (&argse
, code
->expr3
);
1156 gfc_add_block_to_block (&se
.pre
, &argse
.pre
);
1157 errmsg
= argse
.expr
;
1158 errmsg_len
= fold_convert (size_type_node
, argse
.string_length
);
1162 errmsg
= null_pointer_node
;
1163 errmsg_len
= build_zero_cst (size_type_node
);
1166 if (stat
!= null_pointer_node
&& TREE_TYPE (stat
) != integer_type_node
)
1169 stat
= gfc_create_var (integer_type_node
, "stat");
1172 index
= fold_convert (size_type_node
, index
);
1173 if (op
== EXEC_EVENT_POST
)
1174 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_event_post
, 6,
1175 token
, index
, image_index
,
1176 stat
!= null_pointer_node
1177 ? gfc_build_addr_expr (NULL
, stat
) : stat
,
1178 errmsg
, errmsg_len
);
1180 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_event_wait
, 6,
1181 token
, index
, until_count
,
1182 stat
!= null_pointer_node
1183 ? gfc_build_addr_expr (NULL
, stat
) : stat
,
1184 errmsg
, errmsg_len
);
1185 gfc_add_expr_to_block (&se
.pre
, tmp
);
1187 /* It guarantees memory consistency within the same segment */
1188 tmp
= gfc_build_string_const (strlen ("memory")+1, "memory"),
1189 tmp
= build5_loc (input_location
, ASM_EXPR
, void_type_node
,
1190 gfc_build_string_const (1, ""), NULL_TREE
, NULL_TREE
,
1191 tree_cons (NULL_TREE
, tmp
, NULL_TREE
), NULL_TREE
);
1192 ASM_VOLATILE_P (tmp
) = 1;
1193 gfc_add_expr_to_block (&se
.pre
, tmp
);
1195 if (stat2
!= NULL_TREE
)
1196 gfc_add_modify (&se
.pre
, stat2
, fold_convert (TREE_TYPE (stat2
), stat
));
1198 return gfc_finish_block (&se
.pre
);
1202 gfc_trans_sync (gfc_code
*code
, gfc_exec_op type
)
1206 tree images
= NULL_TREE
, stat
= NULL_TREE
,
1207 errmsg
= NULL_TREE
, errmsglen
= NULL_TREE
;
1209 /* Short cut: For single images without bound checking or without STAT=,
1210 return early. (ERRMSG= is always untouched for -fcoarray=single.) */
1211 if (!code
->expr2
&& !(gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
1212 && flag_coarray
!= GFC_FCOARRAY_LIB
)
1215 gfc_init_se (&se
, NULL
);
1216 gfc_start_block (&se
.pre
);
1218 if (code
->expr1
&& code
->expr1
->rank
== 0)
1220 gfc_init_se (&argse
, NULL
);
1221 gfc_conv_expr_val (&argse
, code
->expr1
);
1222 images
= argse
.expr
;
1227 gcc_assert (code
->expr2
->expr_type
== EXPR_VARIABLE
1228 || code
->expr2
->expr_type
== EXPR_FUNCTION
);
1229 gfc_init_se (&argse
, NULL
);
1230 gfc_conv_expr_val (&argse
, code
->expr2
);
1234 stat
= null_pointer_node
;
1236 if (code
->expr3
&& flag_coarray
== GFC_FCOARRAY_LIB
)
1238 gcc_assert (code
->expr3
->expr_type
== EXPR_VARIABLE
1239 || code
->expr3
->expr_type
== EXPR_FUNCTION
);
1240 gfc_init_se (&argse
, NULL
);
1241 argse
.want_pointer
= 1;
1242 gfc_conv_expr (&argse
, code
->expr3
);
1243 gfc_conv_string_parameter (&argse
);
1244 errmsg
= gfc_build_addr_expr (NULL
, argse
.expr
);
1245 errmsglen
= fold_convert (size_type_node
, argse
.string_length
);
1247 else if (flag_coarray
== GFC_FCOARRAY_LIB
)
1249 errmsg
= null_pointer_node
;
1250 errmsglen
= build_int_cst (size_type_node
, 0);
1253 /* Check SYNC IMAGES(imageset) for valid image index.
1254 FIXME: Add a check for image-set arrays. */
1255 if (code
->expr1
&& (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
1256 && code
->expr1
->rank
== 0)
1258 tree images2
= fold_convert (integer_type_node
, images
);
1260 if (flag_coarray
!= GFC_FCOARRAY_LIB
)
1261 cond
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
1262 images
, build_int_cst (TREE_TYPE (images
), 1));
1266 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_num_images
,
1267 2, integer_zero_node
,
1268 build_int_cst (integer_type_node
, -1));
1269 cond
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
,
1271 cond2
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
1273 build_int_cst (TREE_TYPE (images
), 1));
1274 cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
1275 logical_type_node
, cond
, cond2
);
1277 gfc_trans_runtime_check (true, false, cond
, &se
.pre
,
1278 &code
->expr1
->where
, "Invalid image number "
1279 "%d in SYNC IMAGES", images2
);
1282 /* Per F2008, 8.5.1, a SYNC MEMORY is implied by calling the
1283 image control statements SYNC IMAGES and SYNC ALL. */
1284 if (flag_coarray
== GFC_FCOARRAY_LIB
)
1286 tmp
= gfc_build_string_const (strlen ("memory")+1, "memory"),
1287 tmp
= build5_loc (input_location
, ASM_EXPR
, void_type_node
,
1288 gfc_build_string_const (1, ""), NULL_TREE
, NULL_TREE
,
1289 tree_cons (NULL_TREE
, tmp
, NULL_TREE
), NULL_TREE
);
1290 ASM_VOLATILE_P (tmp
) = 1;
1291 gfc_add_expr_to_block (&se
.pre
, tmp
);
1294 if (flag_coarray
!= GFC_FCOARRAY_LIB
)
1296 /* Set STAT to zero. */
1298 gfc_add_modify (&se
.pre
, stat
, build_int_cst (TREE_TYPE (stat
), 0));
1300 else if (type
== EXEC_SYNC_ALL
|| type
== EXEC_SYNC_MEMORY
)
1302 /* SYNC ALL => stat == null_pointer_node
1303 SYNC ALL(stat=s) => stat has an integer type
1305 If "stat" has the wrong integer type, use a temp variable of
1306 the right type and later cast the result back into "stat". */
1307 if (stat
== null_pointer_node
|| TREE_TYPE (stat
) == integer_type_node
)
1309 if (TREE_TYPE (stat
) == integer_type_node
)
1310 stat
= gfc_build_addr_expr (NULL
, stat
);
1312 if(type
== EXEC_SYNC_MEMORY
)
1313 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_sync_memory
,
1314 3, stat
, errmsg
, errmsglen
);
1316 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_sync_all
,
1317 3, stat
, errmsg
, errmsglen
);
1319 gfc_add_expr_to_block (&se
.pre
, tmp
);
1323 tree tmp_stat
= gfc_create_var (integer_type_node
, "stat");
1325 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_sync_all
,
1326 3, gfc_build_addr_expr (NULL
, tmp_stat
),
1328 gfc_add_expr_to_block (&se
.pre
, tmp
);
1330 gfc_add_modify (&se
.pre
, stat
,
1331 fold_convert (TREE_TYPE (stat
), tmp_stat
));
1338 gcc_assert (type
== EXEC_SYNC_IMAGES
);
1342 len
= build_int_cst (integer_type_node
, -1);
1343 images
= null_pointer_node
;
1345 else if (code
->expr1
->rank
== 0)
1347 len
= build_int_cst (integer_type_node
, 1);
1348 images
= gfc_build_addr_expr (NULL_TREE
, images
);
1353 if (code
->expr1
->ts
.kind
!= gfc_c_int_kind
)
1354 gfc_fatal_error ("Sorry, only support for integer kind %d "
1355 "implemented for image-set at %L",
1356 gfc_c_int_kind
, &code
->expr1
->where
);
1358 gfc_conv_array_parameter (&se
, code
->expr1
, true, NULL
, NULL
, &len
);
1361 tmp
= gfc_typenode_for_spec (&code
->expr1
->ts
);
1362 if (GFC_ARRAY_TYPE_P (tmp
) || GFC_DESCRIPTOR_TYPE_P (tmp
))
1363 tmp
= gfc_get_element_type (tmp
);
1365 len
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
,
1366 TREE_TYPE (len
), len
,
1367 fold_convert (TREE_TYPE (len
),
1368 TYPE_SIZE_UNIT (tmp
)));
1369 len
= fold_convert (integer_type_node
, len
);
1372 /* SYNC IMAGES(imgs) => stat == null_pointer_node
1373 SYNC IMAGES(imgs,stat=s) => stat has an integer type
1375 If "stat" has the wrong integer type, use a temp variable of
1376 the right type and later cast the result back into "stat". */
1377 if (stat
== null_pointer_node
|| TREE_TYPE (stat
) == integer_type_node
)
1379 if (TREE_TYPE (stat
) == integer_type_node
)
1380 stat
= gfc_build_addr_expr (NULL
, stat
);
1382 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_sync_images
,
1383 5, fold_convert (integer_type_node
, len
),
1384 images
, stat
, errmsg
, errmsglen
);
1385 gfc_add_expr_to_block (&se
.pre
, tmp
);
1389 tree tmp_stat
= gfc_create_var (integer_type_node
, "stat");
1391 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_sync_images
,
1392 5, fold_convert (integer_type_node
, len
),
1393 images
, gfc_build_addr_expr (NULL
, tmp_stat
),
1395 gfc_add_expr_to_block (&se
.pre
, tmp
);
1397 gfc_add_modify (&se
.pre
, stat
,
1398 fold_convert (TREE_TYPE (stat
), tmp_stat
));
1402 return gfc_finish_block (&se
.pre
);
1406 /* Generate GENERIC for the IF construct. This function also deals with
1407 the simple IF statement, because the front end translates the IF
1408 statement into an IF construct.
1440 where COND_S is the simplified version of the predicate. PRE_COND_S
1441 are the pre side-effects produced by the translation of the
1443 We need to build the chain recursively otherwise we run into
1444 problems with folding incomplete statements. */
1447 gfc_trans_if_1 (gfc_code
* code
)
1450 tree stmt
, elsestmt
;
1454 /* Check for an unconditional ELSE clause. */
1456 return gfc_trans_code (code
->next
);
1458 /* Initialize a statement builder for each block. Puts in NULL_TREEs. */
1459 gfc_init_se (&if_se
, NULL
);
1460 gfc_start_block (&if_se
.pre
);
1462 /* Calculate the IF condition expression. */
1463 if (code
->expr1
->where
.lb
)
1465 gfc_save_backend_locus (&saved_loc
);
1466 gfc_set_backend_locus (&code
->expr1
->where
);
1469 gfc_conv_expr_val (&if_se
, code
->expr1
);
1471 if (code
->expr1
->where
.lb
)
1472 gfc_restore_backend_locus (&saved_loc
);
1474 /* Translate the THEN clause. */
1475 stmt
= gfc_trans_code (code
->next
);
1477 /* Translate the ELSE clause. */
1479 elsestmt
= gfc_trans_if_1 (code
->block
);
1481 elsestmt
= build_empty_stmt (input_location
);
1483 /* Build the condition expression and add it to the condition block. */
1484 loc
= code
->expr1
->where
.lb
? gfc_get_location (&code
->expr1
->where
)
1486 stmt
= fold_build3_loc (loc
, COND_EXPR
, void_type_node
, if_se
.expr
, stmt
,
1489 gfc_add_expr_to_block (&if_se
.pre
, stmt
);
1491 /* Finish off this statement. */
1492 return gfc_finish_block (&if_se
.pre
);
1496 gfc_trans_if (gfc_code
* code
)
1501 /* Create exit label so it is available for trans'ing the body code. */
1502 exit_label
= gfc_build_label_decl (NULL_TREE
);
1503 code
->exit_label
= exit_label
;
1505 /* Translate the actual code in code->block. */
1506 gfc_init_block (&body
);
1507 gfc_add_expr_to_block (&body
, gfc_trans_if_1 (code
->block
));
1509 /* Add exit label. */
1510 gfc_add_expr_to_block (&body
, build1_v (LABEL_EXPR
, exit_label
));
1512 return gfc_finish_block (&body
);
1516 /* Translate an arithmetic IF expression.
1518 IF (cond) label1, label2, label3 translates to
1530 An optimized version can be generated in case of equal labels.
1531 E.g., if label1 is equal to label2, we can translate it to
1540 gfc_trans_arithmetic_if (gfc_code
* code
)
1548 /* Start a new block. */
1549 gfc_init_se (&se
, NULL
);
1550 gfc_start_block (&se
.pre
);
1552 /* Pre-evaluate COND. */
1553 gfc_conv_expr_val (&se
, code
->expr1
);
1554 se
.expr
= gfc_evaluate_now (se
.expr
, &se
.pre
);
1556 /* Build something to compare with. */
1557 zero
= gfc_build_const (TREE_TYPE (se
.expr
), integer_zero_node
);
1559 if (code
->label1
->value
!= code
->label2
->value
)
1561 /* If (cond < 0) take branch1 else take branch2.
1562 First build jumps to the COND .LT. 0 and the COND .EQ. 0 cases. */
1563 branch1
= build1_v (GOTO_EXPR
, gfc_get_label_decl (code
->label1
));
1564 branch2
= build1_v (GOTO_EXPR
, gfc_get_label_decl (code
->label2
));
1566 if (code
->label1
->value
!= code
->label3
->value
)
1567 tmp
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
1570 tmp
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
1573 branch1
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
1574 tmp
, branch1
, branch2
);
1577 branch1
= build1_v (GOTO_EXPR
, gfc_get_label_decl (code
->label1
));
1579 if (code
->label1
->value
!= code
->label3
->value
1580 && code
->label2
->value
!= code
->label3
->value
)
1582 /* if (cond <= 0) take branch1 else take branch2. */
1583 branch2
= build1_v (GOTO_EXPR
, gfc_get_label_decl (code
->label3
));
1584 tmp
= fold_build2_loc (input_location
, LE_EXPR
, logical_type_node
,
1586 branch1
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
1587 tmp
, branch1
, branch2
);
1590 /* Append the COND_EXPR to the evaluation of COND, and return. */
1591 gfc_add_expr_to_block (&se
.pre
, branch1
);
1592 return gfc_finish_block (&se
.pre
);
1596 /* Translate a CRITICAL block. */
1598 gfc_trans_critical (gfc_code
*code
)
1601 tree tmp
, token
= NULL_TREE
;
1603 gfc_start_block (&block
);
1605 if (flag_coarray
== GFC_FCOARRAY_LIB
)
1607 tree zero_size
= build_zero_cst (size_type_node
);
1608 token
= gfc_get_symbol_decl (code
->resolved_sym
);
1609 token
= GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (token
));
1610 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_lock
, 7,
1611 token
, zero_size
, integer_one_node
,
1612 null_pointer_node
, null_pointer_node
,
1613 null_pointer_node
, zero_size
);
1614 gfc_add_expr_to_block (&block
, tmp
);
1616 /* It guarantees memory consistency within the same segment */
1617 tmp
= gfc_build_string_const (strlen ("memory")+1, "memory"),
1618 tmp
= build5_loc (input_location
, ASM_EXPR
, void_type_node
,
1619 gfc_build_string_const (1, ""),
1620 NULL_TREE
, NULL_TREE
,
1621 tree_cons (NULL_TREE
, tmp
, NULL_TREE
),
1623 ASM_VOLATILE_P (tmp
) = 1;
1625 gfc_add_expr_to_block (&block
, tmp
);
1628 tmp
= gfc_trans_code (code
->block
->next
);
1629 gfc_add_expr_to_block (&block
, tmp
);
1631 if (flag_coarray
== GFC_FCOARRAY_LIB
)
1633 tree zero_size
= build_zero_cst (size_type_node
);
1634 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_unlock
, 6,
1635 token
, zero_size
, integer_one_node
,
1636 null_pointer_node
, null_pointer_node
,
1638 gfc_add_expr_to_block (&block
, tmp
);
1640 /* It guarantees memory consistency within the same segment */
1641 tmp
= gfc_build_string_const (strlen ("memory")+1, "memory"),
1642 tmp
= build5_loc (input_location
, ASM_EXPR
, void_type_node
,
1643 gfc_build_string_const (1, ""),
1644 NULL_TREE
, NULL_TREE
,
1645 tree_cons (NULL_TREE
, tmp
, NULL_TREE
),
1647 ASM_VOLATILE_P (tmp
) = 1;
1649 gfc_add_expr_to_block (&block
, tmp
);
1652 return gfc_finish_block (&block
);
1656 /* Return true, when the class has a _len component. */
1659 class_has_len_component (gfc_symbol
*sym
)
1661 gfc_component
*comp
= sym
->ts
.u
.derived
->components
;
1664 if (strcmp (comp
->name
, "_len") == 0)
1673 copy_descriptor (stmtblock_t
*block
, tree dst
, tree src
, int rank
)
1682 offset
= gfc_index_zero_node
;
1684 /* Use memcpy to copy the descriptor. The size is the minimum of
1685 the sizes of 'src' and 'dst'. This avoids a non-trivial conversion. */
1686 tmp
= TYPE_SIZE_UNIT (TREE_TYPE (src
));
1687 tmp2
= TYPE_SIZE_UNIT (TREE_TYPE (dst
));
1688 size
= fold_build2_loc (input_location
, MIN_EXPR
,
1689 TREE_TYPE (tmp
), tmp
, tmp2
);
1690 tmp
= builtin_decl_explicit (BUILT_IN_MEMCPY
);
1691 tmp
= build_call_expr_loc (input_location
, tmp
, 3,
1692 gfc_build_addr_expr (NULL_TREE
, dst
),
1693 gfc_build_addr_expr (NULL_TREE
, src
),
1694 fold_convert (size_type_node
, size
));
1695 gfc_add_expr_to_block (block
, tmp
);
1697 /* Set the offset correctly. */
1698 for (n
= 0; n
< rank
; n
++)
1700 dim
= gfc_rank_cst
[n
];
1701 tmp
= gfc_conv_descriptor_lbound_get (src
, dim
);
1702 tmp2
= gfc_conv_descriptor_stride_get (src
, dim
);
1703 tmp
= fold_build2_loc (input_location
, MULT_EXPR
, TREE_TYPE (tmp
),
1705 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
1706 TREE_TYPE (offset
), offset
, tmp
);
1707 offset
= gfc_evaluate_now (offset
, block
);
1710 gfc_conv_descriptor_offset_set (block
, dst
, offset
);
1714 /* Do proper initialization for ASSOCIATE names. */
1717 trans_associate_var (gfc_symbol
*sym
, gfc_wrapped_block
*block
)
1728 bool need_len_assign
;
1729 bool whole_array
= true;
1733 gcc_assert (sym
->assoc
);
1734 e
= sym
->assoc
->target
;
1736 class_target
= (e
->expr_type
== EXPR_VARIABLE
)
1737 && (gfc_is_class_scalar_expr (e
)
1738 || gfc_is_class_array_ref (e
, NULL
));
1740 unlimited
= UNLIMITED_POLY (e
);
1742 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
1743 if (ref
->type
== REF_ARRAY
1744 && ref
->u
.ar
.type
== AR_FULL
1747 whole_array
= false;
1751 /* Assignments to the string length need to be generated, when
1752 ( sym is a char array or
1753 sym has a _len component)
1754 and the associated expression is unlimited polymorphic, which is
1755 not (yet) correctly in 'unlimited', because for an already associated
1756 BT_DERIVED the u-poly flag is not set, i.e.,
1757 __tmp_CHARACTER_0_1 => w => arg
1758 ^ generated temp ^ from code, the w does not have the u-poly
1759 flag set, where UNLIMITED_POLY(e) expects it. */
1760 need_len_assign
= ((unlimited
|| (e
->ts
.type
== BT_DERIVED
1761 && e
->ts
.u
.derived
->attr
.unlimited_polymorphic
))
1762 && (sym
->ts
.type
== BT_CHARACTER
1763 || ((sym
->ts
.type
== BT_CLASS
|| sym
->ts
.type
== BT_DERIVED
)
1764 && class_has_len_component (sym
)))
1765 && !sym
->attr
.select_rank_temporary
);
1767 /* Do a `pointer assignment' with updated descriptor (or assign descriptor
1768 to array temporary) for arrays with either unknown shape or if associating
1769 to a variable. Select rank temporaries need somewhat different treatment
1770 to other associate names and case temporaries. This because the selector
1771 is assumed rank and so the offset in particular has to be changed. Also,
1772 the case temporaries carry both allocatable and target attributes if
1773 present in the selector. This means that an allocatation or change of
1774 association can occur and so has to be dealt with. */
1775 if (sym
->attr
.select_rank_temporary
)
1778 tree class_decl
= NULL_TREE
;
1782 sym2
= e
->symtree
->n
.sym
;
1783 gfc_init_se (&se
, NULL
);
1784 if (e
->ts
.type
== BT_CLASS
)
1786 /* Go straight to the class data. */
1787 if (sym2
->attr
.dummy
&& !sym2
->attr
.optional
)
1789 class_decl
= sym2
->backend_decl
;
1790 if (DECL_LANG_SPECIFIC (class_decl
)
1791 && GFC_DECL_SAVED_DESCRIPTOR (class_decl
))
1792 class_decl
= GFC_DECL_SAVED_DESCRIPTOR (class_decl
);
1793 if (POINTER_TYPE_P (TREE_TYPE (class_decl
)))
1794 class_decl
= build_fold_indirect_ref_loc (input_location
,
1796 gcc_assert (GFC_CLASS_TYPE_P (TREE_TYPE (class_decl
)));
1797 se
.expr
= gfc_class_data_get (class_decl
);
1801 class_decl
= sym2
->backend_decl
;
1802 gfc_conv_expr_descriptor (&se
, e
);
1803 if (POINTER_TYPE_P (TREE_TYPE (se
.expr
)))
1804 se
.expr
= build_fold_indirect_ref_loc (input_location
,
1808 if (CLASS_DATA (sym
)->as
&& CLASS_DATA (sym
)->as
->rank
> 0)
1809 rank
= CLASS_DATA (sym
)->as
->rank
;
1813 gfc_conv_expr_descriptor (&se
, e
);
1814 if (sym
->as
&& sym
->as
->rank
> 0)
1815 rank
= sym
->as
->rank
;
1818 desc
= sym
->backend_decl
;
1820 /* The SELECT TYPE mechanisms turn class temporaries into pointers, which
1821 point to the selector. */
1822 class_ptr
= class_decl
!= NULL_TREE
&& POINTER_TYPE_P (TREE_TYPE (desc
));
1825 tmp
= gfc_create_var (TREE_TYPE (TREE_TYPE (desc
)), "class");
1826 tmp
= gfc_build_addr_expr (NULL
, tmp
);
1827 gfc_add_modify (&se
.pre
, desc
, tmp
);
1829 tmp
= gfc_class_vptr_get (class_decl
);
1830 gfc_add_modify (&se
.pre
, gfc_class_vptr_get (desc
), tmp
);
1831 if (UNLIMITED_POLY (sym
))
1832 gfc_add_modify (&se
.pre
, gfc_class_len_get (desc
),
1833 gfc_class_len_get (class_decl
));
1835 desc
= gfc_class_data_get (desc
);
1838 /* SELECT RANK temporaries can carry the allocatable and pointer
1839 attributes so the selector descriptor must be copied in and
1842 copy_descriptor (&se
.pre
, desc
, se
.expr
, rank
);
1845 tmp
= gfc_conv_descriptor_data_get (se
.expr
);
1846 gfc_add_modify (&se
.pre
, desc
,
1847 fold_convert (TREE_TYPE (desc
), tmp
));
1850 /* Deal with associate_name => selector. Class associate names are
1851 treated in the same way as in SELECT TYPE. */
1852 sym2
= sym
->assoc
->target
->symtree
->n
.sym
;
1853 if (sym2
->assoc
&& sym
->assoc
->target
&& sym2
->ts
.type
!= BT_CLASS
)
1855 sym2
= sym2
->assoc
->target
->symtree
->n
.sym
;
1856 se
.expr
= sym2
->backend_decl
;
1858 if (POINTER_TYPE_P (TREE_TYPE (se
.expr
)))
1859 se
.expr
= build_fold_indirect_ref_loc (input_location
,
1863 /* There could have been reallocation. Copy descriptor back to the
1864 selector and update the offset. */
1865 if (sym
->attr
.allocatable
|| sym
->attr
.pointer
1866 || (sym
->ts
.type
== BT_CLASS
1867 && (CLASS_DATA (sym
)->attr
.allocatable
1868 || CLASS_DATA (sym
)->attr
.pointer
)))
1871 copy_descriptor (&se
.post
, se
.expr
, desc
, rank
);
1873 gfc_conv_descriptor_data_set (&se
.post
, se
.expr
, desc
);
1875 /* The dynamic type could have changed too. */
1876 if (sym
->ts
.type
== BT_CLASS
)
1878 tmp
= sym
->backend_decl
;
1880 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
1881 gfc_add_modify (&se
.post
, gfc_class_vptr_get (class_decl
),
1882 gfc_class_vptr_get (tmp
));
1883 if (UNLIMITED_POLY (sym
))
1884 gfc_add_modify (&se
.post
, gfc_class_len_get (class_decl
),
1885 gfc_class_len_get (tmp
));
1889 tmp
= gfc_finish_block (&se
.post
);
1891 gfc_add_init_cleanup (block
, gfc_finish_block (&se
.pre
), tmp
);
1893 /* Now all the other kinds of associate variable. */
1894 else if (sym
->attr
.dimension
&& !class_target
1895 && (sym
->as
->type
== AS_DEFERRED
|| sym
->assoc
->variable
))
1899 bool cst_array_ctor
;
1901 desc
= sym
->backend_decl
;
1902 cst_array_ctor
= e
->expr_type
== EXPR_ARRAY
1903 && gfc_constant_array_constructor_p (e
->value
.constructor
)
1904 && e
->ts
.type
!= BT_CHARACTER
;
1906 /* If association is to an expression, evaluate it and create temporary.
1907 Otherwise, get descriptor of target for pointer assignment. */
1908 gfc_init_se (&se
, NULL
);
1910 if (sym
->assoc
->variable
|| cst_array_ctor
)
1912 se
.direct_byref
= 1;
1915 GFC_DECL_PTR_ARRAY_P (sym
->backend_decl
) = 1;
1918 gfc_conv_expr_descriptor (&se
, e
);
1920 if (sym
->ts
.type
== BT_CHARACTER
1921 && !se
.direct_byref
&& sym
->ts
.deferred
1922 && !sym
->attr
.select_type_temporary
1923 && VAR_P (sym
->ts
.u
.cl
->backend_decl
)
1924 && se
.string_length
!= sym
->ts
.u
.cl
->backend_decl
)
1926 gfc_add_modify (&se
.pre
, sym
->ts
.u
.cl
->backend_decl
,
1927 fold_convert (TREE_TYPE (sym
->ts
.u
.cl
->backend_decl
),
1931 /* If we didn't already do the pointer assignment, set associate-name
1932 descriptor to the one generated for the temporary. */
1933 if ((!sym
->assoc
->variable
&& !cst_array_ctor
)
1939 gfc_add_modify (&se
.pre
, desc
, se
.expr
);
1941 /* The generated descriptor has lower bound zero (as array
1942 temporary), shift bounds so we get lower bounds of 1. */
1943 for (dim
= 0; dim
< e
->rank
; ++dim
)
1944 gfc_conv_shift_descriptor_lbound (&se
.pre
, desc
,
1945 dim
, gfc_index_one_node
);
1948 /* If this is a subreference array pointer associate name use the
1949 associate variable element size for the value of 'span'. */
1950 if (sym
->attr
.subref_array_pointer
&& !se
.direct_byref
)
1952 gcc_assert (e
->expr_type
== EXPR_VARIABLE
);
1953 tmp
= gfc_get_array_span (se
.expr
, e
);
1955 gfc_conv_descriptor_span_set (&se
.pre
, desc
, tmp
);
1958 if (e
->expr_type
== EXPR_FUNCTION
1959 && sym
->ts
.type
== BT_DERIVED
1960 && sym
->ts
.u
.derived
1961 && sym
->ts
.u
.derived
->attr
.pdt_type
)
1963 tmp
= gfc_deallocate_pdt_comp (sym
->ts
.u
.derived
, se
.expr
,
1965 gfc_add_expr_to_block (&se
.post
, tmp
);
1968 /* Done, register stuff as init / cleanup code. */
1969 gfc_add_init_cleanup (block
, gfc_finish_block (&se
.pre
),
1970 gfc_finish_block (&se
.post
));
1973 /* Temporaries, arising from TYPE IS, just need the descriptor of class
1974 arrays to be assigned directly. */
1975 else if (class_target
&& sym
->attr
.dimension
1976 && (sym
->ts
.type
== BT_DERIVED
|| unlimited
))
1980 gfc_init_se (&se
, NULL
);
1981 se
.descriptor_only
= 1;
1982 /* In a select type the (temporary) associate variable shall point to
1983 a standard fortran array (lower bound == 1), but conv_expr ()
1984 just maps to the input array in the class object, whose lbound may
1985 be arbitrary. conv_expr_descriptor solves this by inserting a
1986 temporary array descriptor. */
1987 gfc_conv_expr_descriptor (&se
, e
);
1989 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se
.expr
))
1990 || GFC_ARRAY_TYPE_P (TREE_TYPE (se
.expr
)));
1991 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (sym
->backend_decl
)));
1993 if (GFC_ARRAY_TYPE_P (TREE_TYPE (se
.expr
)))
1995 if (INDIRECT_REF_P (se
.expr
))
1996 tmp
= TREE_OPERAND (se
.expr
, 0);
2000 gfc_add_modify (&se
.pre
, sym
->backend_decl
,
2001 gfc_class_data_get (GFC_DECL_SAVED_DESCRIPTOR (tmp
)));
2004 gfc_add_modify (&se
.pre
, sym
->backend_decl
, se
.expr
);
2008 /* Recover the dtype, which has been overwritten by the
2009 assignment from an unlimited polymorphic object. */
2010 tmp
= gfc_conv_descriptor_dtype (sym
->backend_decl
);
2011 gfc_add_modify (&se
.pre
, tmp
,
2012 gfc_get_dtype (TREE_TYPE (sym
->backend_decl
)));
2015 gfc_add_init_cleanup (block
, gfc_finish_block (&se
.pre
),
2016 gfc_finish_block (&se
.post
));
2019 /* Do a scalar pointer assignment; this is for scalar variable targets. */
2020 else if (gfc_is_associate_pointer (sym
))
2024 gcc_assert (!sym
->attr
.dimension
);
2026 gfc_init_se (&se
, NULL
);
2028 /* Class associate-names come this way because they are
2029 unconditionally associate pointers and the symbol is scalar. */
2030 if (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)->attr
.dimension
)
2033 /* For a class array we need a descriptor for the selector. */
2034 gfc_conv_expr_descriptor (&se
, e
);
2035 /* Needed to get/set the _len component below. */
2036 target_expr
= se
.expr
;
2038 /* Obtain a temporary class container for the result. */
2039 gfc_conv_class_to_class (&se
, e
, sym
->ts
, false, true, false, false);
2040 se
.expr
= build_fold_indirect_ref_loc (input_location
, se
.expr
);
2042 /* Set the offset. */
2043 desc
= gfc_class_data_get (se
.expr
);
2044 offset
= gfc_index_zero_node
;
2045 for (n
= 0; n
< e
->rank
; n
++)
2047 dim
= gfc_rank_cst
[n
];
2048 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
2049 gfc_array_index_type
,
2050 gfc_conv_descriptor_stride_get (desc
, dim
),
2051 gfc_conv_descriptor_lbound_get (desc
, dim
));
2052 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
2053 gfc_array_index_type
,
2056 if (need_len_assign
)
2059 && DECL_LANG_SPECIFIC (e
->symtree
->n
.sym
->backend_decl
)
2060 && GFC_DECL_SAVED_DESCRIPTOR (e
->symtree
->n
.sym
->backend_decl
)
2061 && TREE_CODE (target_expr
) != COMPONENT_REF
)
2062 /* Use the original class descriptor stored in the saved
2063 descriptor to get the target_expr. */
2065 GFC_DECL_SAVED_DESCRIPTOR (e
->symtree
->n
.sym
->backend_decl
);
2067 /* Strip the _data component from the target_expr. */
2068 target_expr
= TREE_OPERAND (target_expr
, 0);
2069 /* Add a reference to the _len comp to the target expr. */
2070 tmp
= gfc_class_len_get (target_expr
);
2071 /* Get the component-ref for the temp structure's _len comp. */
2072 charlen
= gfc_class_len_get (se
.expr
);
2073 /* Add the assign to the beginning of the block... */
2074 gfc_add_modify (&se
.pre
, charlen
,
2075 fold_convert (TREE_TYPE (charlen
), tmp
));
2076 /* and the oposite way at the end of the block, to hand changes
2077 on the string length back. */
2078 gfc_add_modify (&se
.post
, tmp
,
2079 fold_convert (TREE_TYPE (tmp
), charlen
));
2080 /* Length assignment done, prevent adding it again below. */
2081 need_len_assign
= false;
2083 gfc_conv_descriptor_offset_set (&se
.pre
, desc
, offset
);
2085 else if (sym
->ts
.type
== BT_CLASS
&& e
->ts
.type
== BT_CLASS
2086 && CLASS_DATA (e
)->attr
.dimension
)
2088 /* This is bound to be a class array element. */
2089 gfc_conv_expr_reference (&se
, e
);
2090 /* Get the _vptr component of the class object. */
2091 tmp
= gfc_get_vptr_from_expr (se
.expr
);
2092 /* Obtain a temporary class container for the result. */
2093 gfc_conv_derived_to_class (&se
, e
, sym
->ts
, tmp
, false, false);
2094 se
.expr
= build_fold_indirect_ref_loc (input_location
, se
.expr
);
2095 need_len_assign
= false;
2099 /* For BT_CLASS and BT_DERIVED, this boils down to a pointer assign,
2100 which has the string length included. For CHARACTERS it is still
2101 needed and will be done at the end of this routine. */
2102 gfc_conv_expr (&se
, e
);
2103 need_len_assign
= need_len_assign
&& sym
->ts
.type
== BT_CHARACTER
;
2106 if (sym
->ts
.type
== BT_CHARACTER
2107 && !sym
->attr
.select_type_temporary
2108 && VAR_P (sym
->ts
.u
.cl
->backend_decl
)
2109 && se
.string_length
!= sym
->ts
.u
.cl
->backend_decl
)
2111 gfc_add_modify (&se
.pre
, sym
->ts
.u
.cl
->backend_decl
,
2112 fold_convert (TREE_TYPE (sym
->ts
.u
.cl
->backend_decl
),
2114 if (e
->expr_type
== EXPR_FUNCTION
)
2116 tmp
= gfc_call_free (sym
->backend_decl
);
2117 gfc_add_expr_to_block (&se
.post
, tmp
);
2121 if (sym
->ts
.type
== BT_CHARACTER
&& e
->ts
.type
== BT_CHARACTER
2122 && POINTER_TYPE_P (TREE_TYPE (se
.expr
)))
2124 /* These are pointer types already. */
2125 tmp
= fold_convert (TREE_TYPE (sym
->backend_decl
), se
.expr
);
2129 tree ctree
= gfc_get_class_from_expr (se
.expr
);
2130 tmp
= TREE_TYPE (sym
->backend_decl
);
2132 /* Coarray scalar component expressions can emerge from
2133 the front end as array elements of the _data field. */
2134 if (sym
->ts
.type
== BT_CLASS
2135 && e
->ts
.type
== BT_CLASS
&& e
->rank
== 0
2136 && !GFC_CLASS_TYPE_P (TREE_TYPE (se
.expr
)) && ctree
)
2142 dtmp
= TREE_TYPE (TREE_TYPE (sym
->backend_decl
));
2143 ctree
= gfc_create_var (dtmp
, "class");
2145 stmp
= gfc_class_data_get (se
.expr
);
2146 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (stmp
)));
2148 /* Set the fields of the target class variable. */
2149 stmp
= gfc_conv_descriptor_data_get (stmp
);
2150 dtmp
= gfc_class_data_get (ctree
);
2151 stmp
= fold_convert (TREE_TYPE (dtmp
), stmp
);
2152 gfc_add_modify (&se
.pre
, dtmp
, stmp
);
2153 stmp
= gfc_class_vptr_get (se
.expr
);
2154 dtmp
= gfc_class_vptr_get (ctree
);
2155 stmp
= fold_convert (TREE_TYPE (dtmp
), stmp
);
2156 gfc_add_modify (&se
.pre
, dtmp
, stmp
);
2157 if (UNLIMITED_POLY (sym
))
2159 stmp
= gfc_class_len_get (se
.expr
);
2160 dtmp
= gfc_class_len_get (ctree
);
2161 stmp
= fold_convert (TREE_TYPE (dtmp
), stmp
);
2162 gfc_add_modify (&se
.pre
, dtmp
, stmp
);
2166 tmp
= gfc_build_addr_expr (tmp
, se
.expr
);
2169 gfc_add_modify (&se
.pre
, sym
->backend_decl
, tmp
);
2171 gfc_add_init_cleanup (block
, gfc_finish_block( &se
.pre
),
2172 gfc_finish_block (&se
.post
));
2175 /* Do a simple assignment. This is for scalar expressions, where we
2176 can simply use expression assignment. */
2183 gfc_init_se (&se
, NULL
);
2185 /* resolve.c converts some associate names to allocatable so that
2186 allocation can take place automatically in gfc_trans_assignment.
2187 The frontend prevents them from being either allocated,
2188 deallocated or reallocated. */
2189 if (sym
->attr
.allocatable
)
2191 tmp
= sym
->backend_decl
;
2192 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp
)))
2193 tmp
= gfc_conv_descriptor_data_get (tmp
);
2194 gfc_add_modify (&se
.pre
, tmp
, fold_convert (TREE_TYPE (tmp
),
2195 null_pointer_node
));
2198 lhs
= gfc_lval_expr_from_sym (sym
);
2199 res
= gfc_trans_assignment (lhs
, e
, false, true);
2200 gfc_add_expr_to_block (&se
.pre
, res
);
2202 tmp
= sym
->backend_decl
;
2203 if (e
->expr_type
== EXPR_FUNCTION
2204 && sym
->ts
.type
== BT_DERIVED
2205 && sym
->ts
.u
.derived
2206 && sym
->ts
.u
.derived
->attr
.pdt_type
)
2208 tmp
= gfc_deallocate_pdt_comp (sym
->ts
.u
.derived
, tmp
,
2211 else if (e
->expr_type
== EXPR_FUNCTION
2212 && sym
->ts
.type
== BT_CLASS
2213 && CLASS_DATA (sym
)->ts
.u
.derived
2214 && CLASS_DATA (sym
)->ts
.u
.derived
->attr
.pdt_type
)
2216 tmp
= gfc_class_data_get (tmp
);
2217 tmp
= gfc_deallocate_pdt_comp (CLASS_DATA (sym
)->ts
.u
.derived
,
2220 else if (sym
->attr
.allocatable
)
2222 tmp
= sym
->backend_decl
;
2224 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp
)))
2225 tmp
= gfc_conv_descriptor_data_get (tmp
);
2227 /* A simple call to free suffices here. */
2228 tmp
= gfc_call_free (tmp
);
2230 /* Make sure that reallocation on assignment cannot occur. */
2231 sym
->attr
.allocatable
= 0;
2236 res
= gfc_finish_block (&se
.pre
);
2237 gfc_add_init_cleanup (block
, res
, tmp
);
2238 gfc_free_expr (lhs
);
2241 /* Set the stringlength, when needed. */
2242 if (need_len_assign
)
2245 gfc_init_se (&se
, NULL
);
2246 if (e
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
)
2248 /* Deferred strings are dealt with in the preceeding. */
2249 gcc_assert (!e
->symtree
->n
.sym
->ts
.deferred
);
2250 tmp
= e
->symtree
->n
.sym
->ts
.u
.cl
->backend_decl
;
2252 else if (e
->symtree
->n
.sym
->attr
.function
2253 && e
->symtree
->n
.sym
== e
->symtree
->n
.sym
->result
)
2255 tmp
= gfc_get_fake_result_decl (e
->symtree
->n
.sym
, 0);
2256 tmp
= gfc_class_len_get (tmp
);
2259 tmp
= gfc_class_len_get (gfc_get_symbol_decl (e
->symtree
->n
.sym
));
2260 gfc_get_symbol_decl (sym
);
2261 charlen
= sym
->ts
.type
== BT_CHARACTER
? sym
->ts
.u
.cl
->backend_decl
2262 : gfc_class_len_get (sym
->backend_decl
);
2263 /* Prevent adding a noop len= len. */
2266 gfc_add_modify (&se
.pre
, charlen
,
2267 fold_convert (TREE_TYPE (charlen
), tmp
));
2268 gfc_add_init_cleanup (block
, gfc_finish_block (&se
.pre
),
2269 gfc_finish_block (&se
.post
));
2275 /* Translate a BLOCK construct. This is basically what we would do for a
2279 gfc_trans_block_construct (gfc_code
* code
)
2283 gfc_wrapped_block block
;
2286 gfc_association_list
*ass
;
2288 ns
= code
->ext
.block
.ns
;
2290 sym
= ns
->proc_name
;
2293 /* Process local variables. */
2294 gcc_assert (!sym
->tlink
);
2296 gfc_process_block_locals (ns
);
2298 /* Generate code including exit-label. */
2299 gfc_init_block (&body
);
2300 exit_label
= gfc_build_label_decl (NULL_TREE
);
2301 code
->exit_label
= exit_label
;
2303 finish_oacc_declare (ns
, sym
, true);
2305 gfc_add_expr_to_block (&body
, gfc_trans_code (ns
->code
));
2306 gfc_add_expr_to_block (&body
, build1_v (LABEL_EXPR
, exit_label
));
2308 /* Finish everything. */
2309 gfc_start_wrapped_block (&block
, gfc_finish_block (&body
));
2310 gfc_trans_deferred_vars (sym
, &block
);
2311 for (ass
= code
->ext
.block
.assoc
; ass
; ass
= ass
->next
)
2312 trans_associate_var (ass
->st
->n
.sym
, &block
);
2314 return gfc_finish_wrapped_block (&block
);
2317 /* Translate the simple DO construct in a C-style manner.
2318 This is where the loop variable has integer type and step +-1.
2319 Following code will generate infinite loop in case where TO is INT_MAX
2320 (for +1 step) or INT_MIN (for -1 step)
2322 We translate a do loop from:
2324 DO dovar = from, to, step
2330 [Evaluate loop bounds and step]
2342 This helps the optimizers by avoiding the extra pre-header condition and
2343 we save a register as we just compare the updated IV (not a value in
2347 gfc_trans_simple_do (gfc_code
* code
, stmtblock_t
*pblock
, tree dovar
,
2348 tree from
, tree to
, tree step
, tree exit_cond
)
2354 tree saved_dovar
= NULL
;
2358 type
= TREE_TYPE (dovar
);
2359 bool is_step_positive
= tree_int_cst_sgn (step
) > 0;
2361 loc
= gfc_get_location (&code
->ext
.iterator
->start
->where
);
2363 /* Initialize the DO variable: dovar = from. */
2364 gfc_add_modify_loc (loc
, pblock
, dovar
,
2365 fold_convert (TREE_TYPE (dovar
), from
));
2367 /* Save value for do-tinkering checking. */
2368 if (gfc_option
.rtcheck
& GFC_RTCHECK_DO
)
2370 saved_dovar
= gfc_create_var (type
, ".saved_dovar");
2371 gfc_add_modify_loc (loc
, pblock
, saved_dovar
, dovar
);
2374 /* Cycle and exit statements are implemented with gotos. */
2375 cycle_label
= gfc_build_label_decl (NULL_TREE
);
2376 exit_label
= gfc_build_label_decl (NULL_TREE
);
2378 /* Put the labels where they can be found later. See gfc_trans_do(). */
2379 code
->cycle_label
= cycle_label
;
2380 code
->exit_label
= exit_label
;
2383 gfc_start_block (&body
);
2385 /* Exit the loop if there is an I/O result condition or error. */
2388 tmp
= build1_v (GOTO_EXPR
, exit_label
);
2389 tmp
= fold_build3_loc (loc
, COND_EXPR
, void_type_node
,
2391 build_empty_stmt (loc
));
2392 gfc_add_expr_to_block (&body
, tmp
);
2395 /* Evaluate the loop condition. */
2396 if (is_step_positive
)
2397 cond
= fold_build2_loc (loc
, GT_EXPR
, logical_type_node
, dovar
,
2398 fold_convert (type
, to
));
2400 cond
= fold_build2_loc (loc
, LT_EXPR
, logical_type_node
, dovar
,
2401 fold_convert (type
, to
));
2403 cond
= gfc_evaluate_now_loc (loc
, cond
, &body
);
2404 if (code
->ext
.iterator
->unroll
&& cond
!= error_mark_node
)
2406 = build3 (ANNOTATE_EXPR
, TREE_TYPE (cond
), cond
,
2407 build_int_cst (integer_type_node
, annot_expr_unroll_kind
),
2408 build_int_cst (integer_type_node
, code
->ext
.iterator
->unroll
));
2410 if (code
->ext
.iterator
->ivdep
&& cond
!= error_mark_node
)
2411 cond
= build3 (ANNOTATE_EXPR
, TREE_TYPE (cond
), cond
,
2412 build_int_cst (integer_type_node
, annot_expr_ivdep_kind
),
2414 if (code
->ext
.iterator
->vector
&& cond
!= error_mark_node
)
2415 cond
= build3 (ANNOTATE_EXPR
, TREE_TYPE (cond
), cond
,
2416 build_int_cst (integer_type_node
, annot_expr_vector_kind
),
2418 if (code
->ext
.iterator
->novector
&& cond
!= error_mark_node
)
2419 cond
= build3 (ANNOTATE_EXPR
, TREE_TYPE (cond
), cond
,
2420 build_int_cst (integer_type_node
, annot_expr_no_vector_kind
),
2423 /* The loop exit. */
2424 tmp
= fold_build1_loc (loc
, GOTO_EXPR
, void_type_node
, exit_label
);
2425 TREE_USED (exit_label
) = 1;
2426 tmp
= fold_build3_loc (loc
, COND_EXPR
, void_type_node
,
2427 cond
, tmp
, build_empty_stmt (loc
));
2428 gfc_add_expr_to_block (&body
, tmp
);
2430 /* Check whether the induction variable is equal to INT_MAX
2431 (respectively to INT_MIN). */
2432 if (gfc_option
.rtcheck
& GFC_RTCHECK_DO
)
2434 tree boundary
= is_step_positive
? TYPE_MAX_VALUE (type
)
2435 : TYPE_MIN_VALUE (type
);
2437 tmp
= fold_build2_loc (loc
, EQ_EXPR
, logical_type_node
,
2439 gfc_trans_runtime_check (true, false, tmp
, &body
, &code
->loc
,
2440 "Loop iterates infinitely");
2443 /* Main loop body. */
2444 tmp
= gfc_trans_code_cond (code
->block
->next
, exit_cond
);
2445 gfc_add_expr_to_block (&body
, tmp
);
2447 /* Label for cycle statements (if needed). */
2448 if (TREE_USED (cycle_label
))
2450 tmp
= build1_v (LABEL_EXPR
, cycle_label
);
2451 gfc_add_expr_to_block (&body
, tmp
);
2454 /* Check whether someone has modified the loop variable. */
2455 if (gfc_option
.rtcheck
& GFC_RTCHECK_DO
)
2457 tmp
= fold_build2_loc (loc
, NE_EXPR
, logical_type_node
,
2458 dovar
, saved_dovar
);
2459 gfc_trans_runtime_check (true, false, tmp
, &body
, &code
->loc
,
2460 "Loop variable has been modified");
2463 /* Increment the loop variable. */
2464 tmp
= fold_build2_loc (loc
, PLUS_EXPR
, type
, dovar
, step
);
2465 gfc_add_modify_loc (loc
, &body
, dovar
, tmp
);
2467 if (gfc_option
.rtcheck
& GFC_RTCHECK_DO
)
2468 gfc_add_modify_loc (loc
, &body
, saved_dovar
, dovar
);
2470 /* Finish the loop body. */
2471 tmp
= gfc_finish_block (&body
);
2472 tmp
= fold_build1_loc (loc
, LOOP_EXPR
, void_type_node
, tmp
);
2474 gfc_add_expr_to_block (pblock
, tmp
);
2476 /* Add the exit label. */
2477 tmp
= build1_v (LABEL_EXPR
, exit_label
);
2478 gfc_add_expr_to_block (pblock
, tmp
);
2480 return gfc_finish_block (pblock
);
2483 /* Translate the DO construct. This obviously is one of the most
2484 important ones to get right with any compiler, but especially
2487 We special case some loop forms as described in gfc_trans_simple_do.
2488 For other cases we implement them with a separate loop count,
2489 as described in the standard.
2491 We translate a do loop from:
2493 DO dovar = from, to, step
2499 [evaluate loop bounds and step]
2500 empty = (step > 0 ? to < from : to > from);
2501 countm1 = (to - from) / step;
2503 if (empty) goto exit_label;
2511 if (countm1t == 0) goto exit_label;
2515 countm1 is an unsigned integer. It is equal to the loop count minus one,
2516 because the loop count itself can overflow. */
2519 gfc_trans_do (gfc_code
* code
, tree exit_cond
)
2523 tree saved_dovar
= NULL
;
2538 gfc_start_block (&block
);
2540 loc
= gfc_get_location (&code
->ext
.iterator
->start
->where
);
2542 /* Evaluate all the expressions in the iterator. */
2543 gfc_init_se (&se
, NULL
);
2544 gfc_conv_expr_lhs (&se
, code
->ext
.iterator
->var
);
2545 gfc_add_block_to_block (&block
, &se
.pre
);
2547 type
= TREE_TYPE (dovar
);
2549 gfc_init_se (&se
, NULL
);
2550 gfc_conv_expr_val (&se
, code
->ext
.iterator
->start
);
2551 gfc_add_block_to_block (&block
, &se
.pre
);
2552 from
= gfc_evaluate_now (se
.expr
, &block
);
2554 gfc_init_se (&se
, NULL
);
2555 gfc_conv_expr_val (&se
, code
->ext
.iterator
->end
);
2556 gfc_add_block_to_block (&block
, &se
.pre
);
2557 to
= gfc_evaluate_now (se
.expr
, &block
);
2559 gfc_init_se (&se
, NULL
);
2560 gfc_conv_expr_val (&se
, code
->ext
.iterator
->step
);
2561 gfc_add_block_to_block (&block
, &se
.pre
);
2562 step
= gfc_evaluate_now (se
.expr
, &block
);
2564 if (gfc_option
.rtcheck
& GFC_RTCHECK_DO
)
2566 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
, step
,
2567 build_zero_cst (type
));
2568 gfc_trans_runtime_check (true, false, tmp
, &block
, &code
->loc
,
2569 "DO step value is zero");
2572 /* Special case simple loops. */
2573 if (TREE_CODE (type
) == INTEGER_TYPE
2574 && (integer_onep (step
)
2575 || tree_int_cst_equal (step
, integer_minus_one_node
)))
2576 return gfc_trans_simple_do (code
, &block
, dovar
, from
, to
, step
,
2579 if (TREE_CODE (type
) == INTEGER_TYPE
)
2580 utype
= unsigned_type_for (type
);
2582 utype
= unsigned_type_for (gfc_array_index_type
);
2583 countm1
= gfc_create_var (utype
, "countm1");
2585 /* Cycle and exit statements are implemented with gotos. */
2586 cycle_label
= gfc_build_label_decl (NULL_TREE
);
2587 exit_label
= gfc_build_label_decl (NULL_TREE
);
2588 TREE_USED (exit_label
) = 1;
2590 /* Put these labels where they can be found later. */
2591 code
->cycle_label
= cycle_label
;
2592 code
->exit_label
= exit_label
;
2594 /* Initialize the DO variable: dovar = from. */
2595 gfc_add_modify (&block
, dovar
, from
);
2597 /* Save value for do-tinkering checking. */
2598 if (gfc_option
.rtcheck
& GFC_RTCHECK_DO
)
2600 saved_dovar
= gfc_create_var (type
, ".saved_dovar");
2601 gfc_add_modify_loc (loc
, &block
, saved_dovar
, dovar
);
2604 /* Initialize loop count and jump to exit label if the loop is empty.
2605 This code is executed before we enter the loop body. We generate:
2608 countm1 = (to - from) / step;
2614 countm1 = (from - to) / -step;
2620 if (TREE_CODE (type
) == INTEGER_TYPE
)
2622 tree pos
, neg
, tou
, fromu
, stepu
, tmp2
;
2624 /* The distance from FROM to TO cannot always be represented in a signed
2625 type, thus use unsigned arithmetic, also to avoid any undefined
2627 tou
= fold_convert (utype
, to
);
2628 fromu
= fold_convert (utype
, from
);
2629 stepu
= fold_convert (utype
, step
);
2631 /* For a positive step, when to < from, exit, otherwise compute
2632 countm1 = ((unsigned)to - (unsigned)from) / (unsigned)step */
2633 tmp
= fold_build2_loc (loc
, LT_EXPR
, logical_type_node
, to
, from
);
2634 tmp2
= fold_build2_loc (loc
, TRUNC_DIV_EXPR
, utype
,
2635 fold_build2_loc (loc
, MINUS_EXPR
, utype
,
2638 pos
= build2 (COMPOUND_EXPR
, void_type_node
,
2639 fold_build2 (MODIFY_EXPR
, void_type_node
,
2641 build3_loc (loc
, COND_EXPR
, void_type_node
,
2642 gfc_unlikely (tmp
, PRED_FORTRAN_LOOP_PREHEADER
),
2643 build1_loc (loc
, GOTO_EXPR
, void_type_node
,
2644 exit_label
), NULL_TREE
));
2646 /* For a negative step, when to > from, exit, otherwise compute
2647 countm1 = ((unsigned)from - (unsigned)to) / -(unsigned)step */
2648 tmp
= fold_build2_loc (loc
, GT_EXPR
, logical_type_node
, to
, from
);
2649 tmp2
= fold_build2_loc (loc
, TRUNC_DIV_EXPR
, utype
,
2650 fold_build2_loc (loc
, MINUS_EXPR
, utype
,
2652 fold_build1_loc (loc
, NEGATE_EXPR
, utype
, stepu
));
2653 neg
= build2 (COMPOUND_EXPR
, void_type_node
,
2654 fold_build2 (MODIFY_EXPR
, void_type_node
,
2656 build3_loc (loc
, COND_EXPR
, void_type_node
,
2657 gfc_unlikely (tmp
, PRED_FORTRAN_LOOP_PREHEADER
),
2658 build1_loc (loc
, GOTO_EXPR
, void_type_node
,
2659 exit_label
), NULL_TREE
));
2661 tmp
= fold_build2_loc (loc
, LT_EXPR
, logical_type_node
, step
,
2662 build_int_cst (TREE_TYPE (step
), 0));
2663 tmp
= fold_build3_loc (loc
, COND_EXPR
, void_type_node
, tmp
, neg
, pos
);
2665 gfc_add_expr_to_block (&block
, tmp
);
2671 /* TODO: We could use the same width as the real type.
2672 This would probably cause more problems that it solves
2673 when we implement "long double" types. */
2675 tmp
= fold_build2_loc (loc
, MINUS_EXPR
, type
, to
, from
);
2676 tmp
= fold_build2_loc (loc
, RDIV_EXPR
, type
, tmp
, step
);
2677 tmp
= fold_build1_loc (loc
, FIX_TRUNC_EXPR
, utype
, tmp
);
2678 gfc_add_modify (&block
, countm1
, tmp
);
2680 /* We need a special check for empty loops:
2681 empty = (step > 0 ? to < from : to > from); */
2682 pos_step
= fold_build2_loc (loc
, GT_EXPR
, logical_type_node
, step
,
2683 build_zero_cst (type
));
2684 tmp
= fold_build3_loc (loc
, COND_EXPR
, logical_type_node
, pos_step
,
2685 fold_build2_loc (loc
, LT_EXPR
,
2686 logical_type_node
, to
, from
),
2687 fold_build2_loc (loc
, GT_EXPR
,
2688 logical_type_node
, to
, from
));
2689 /* If the loop is empty, go directly to the exit label. */
2690 tmp
= fold_build3_loc (loc
, COND_EXPR
, void_type_node
, tmp
,
2691 build1_v (GOTO_EXPR
, exit_label
),
2692 build_empty_stmt (input_location
));
2693 gfc_add_expr_to_block (&block
, tmp
);
2697 gfc_start_block (&body
);
2699 /* Main loop body. */
2700 tmp
= gfc_trans_code_cond (code
->block
->next
, exit_cond
);
2701 gfc_add_expr_to_block (&body
, tmp
);
2703 /* Label for cycle statements (if needed). */
2704 if (TREE_USED (cycle_label
))
2706 tmp
= build1_v (LABEL_EXPR
, cycle_label
);
2707 gfc_add_expr_to_block (&body
, tmp
);
2710 /* Check whether someone has modified the loop variable. */
2711 if (gfc_option
.rtcheck
& GFC_RTCHECK_DO
)
2713 tmp
= fold_build2_loc (loc
, NE_EXPR
, logical_type_node
, dovar
,
2715 gfc_trans_runtime_check (true, false, tmp
, &body
, &code
->loc
,
2716 "Loop variable has been modified");
2719 /* Exit the loop if there is an I/O result condition or error. */
2722 tmp
= build1_v (GOTO_EXPR
, exit_label
);
2723 tmp
= fold_build3_loc (loc
, COND_EXPR
, void_type_node
,
2725 build_empty_stmt (input_location
));
2726 gfc_add_expr_to_block (&body
, tmp
);
2729 /* Increment the loop variable. */
2730 tmp
= fold_build2_loc (loc
, PLUS_EXPR
, type
, dovar
, step
);
2731 gfc_add_modify_loc (loc
, &body
, dovar
, tmp
);
2733 if (gfc_option
.rtcheck
& GFC_RTCHECK_DO
)
2734 gfc_add_modify_loc (loc
, &body
, saved_dovar
, dovar
);
2736 /* Initialize countm1t. */
2737 tree countm1t
= gfc_create_var (utype
, "countm1t");
2738 gfc_add_modify_loc (loc
, &body
, countm1t
, countm1
);
2740 /* Decrement the loop count. */
2741 tmp
= fold_build2_loc (loc
, MINUS_EXPR
, utype
, countm1
,
2742 build_int_cst (utype
, 1));
2743 gfc_add_modify_loc (loc
, &body
, countm1
, tmp
);
2745 /* End with the loop condition. Loop until countm1t == 0. */
2746 cond
= fold_build2_loc (loc
, EQ_EXPR
, logical_type_node
, countm1t
,
2747 build_int_cst (utype
, 0));
2748 if (code
->ext
.iterator
->unroll
&& cond
!= error_mark_node
)
2750 = build3 (ANNOTATE_EXPR
, TREE_TYPE (cond
), cond
,
2751 build_int_cst (integer_type_node
, annot_expr_unroll_kind
),
2752 build_int_cst (integer_type_node
, code
->ext
.iterator
->unroll
));
2754 if (code
->ext
.iterator
->ivdep
&& cond
!= error_mark_node
)
2755 cond
= build3 (ANNOTATE_EXPR
, TREE_TYPE (cond
), cond
,
2756 build_int_cst (integer_type_node
, annot_expr_ivdep_kind
),
2758 if (code
->ext
.iterator
->vector
&& cond
!= error_mark_node
)
2759 cond
= build3 (ANNOTATE_EXPR
, TREE_TYPE (cond
), cond
,
2760 build_int_cst (integer_type_node
, annot_expr_vector_kind
),
2762 if (code
->ext
.iterator
->novector
&& cond
!= error_mark_node
)
2763 cond
= build3 (ANNOTATE_EXPR
, TREE_TYPE (cond
), cond
,
2764 build_int_cst (integer_type_node
, annot_expr_no_vector_kind
),
2767 tmp
= fold_build1_loc (loc
, GOTO_EXPR
, void_type_node
, exit_label
);
2768 tmp
= fold_build3_loc (loc
, COND_EXPR
, void_type_node
,
2769 cond
, tmp
, build_empty_stmt (loc
));
2770 gfc_add_expr_to_block (&body
, tmp
);
2772 /* End of loop body. */
2773 tmp
= gfc_finish_block (&body
);
2775 /* The for loop itself. */
2776 tmp
= fold_build1_loc (loc
, LOOP_EXPR
, void_type_node
, tmp
);
2777 gfc_add_expr_to_block (&block
, tmp
);
2779 /* Add the exit label. */
2780 tmp
= build1_v (LABEL_EXPR
, exit_label
);
2781 gfc_add_expr_to_block (&block
, tmp
);
2783 return gfc_finish_block (&block
);
2787 /* Translate the DO WHILE construct.
2800 if (! cond) goto exit_label;
2806 Because the evaluation of the exit condition `cond' may have side
2807 effects, we can't do much for empty loop bodies. The backend optimizers
2808 should be smart enough to eliminate any dead loops. */
2811 gfc_trans_do_while (gfc_code
* code
)
2819 /* Everything we build here is part of the loop body. */
2820 gfc_start_block (&block
);
2822 /* Cycle and exit statements are implemented with gotos. */
2823 cycle_label
= gfc_build_label_decl (NULL_TREE
);
2824 exit_label
= gfc_build_label_decl (NULL_TREE
);
2826 /* Put the labels where they can be found later. See gfc_trans_do(). */
2827 code
->cycle_label
= cycle_label
;
2828 code
->exit_label
= exit_label
;
2830 /* Create a GIMPLE version of the exit condition. */
2831 gfc_init_se (&cond
, NULL
);
2832 gfc_conv_expr_val (&cond
, code
->expr1
);
2833 gfc_add_block_to_block (&block
, &cond
.pre
);
2834 cond
.expr
= fold_build1_loc (gfc_get_location (&code
->expr1
->where
),
2835 TRUTH_NOT_EXPR
, TREE_TYPE (cond
.expr
),
2838 /* Build "IF (! cond) GOTO exit_label". */
2839 tmp
= build1_v (GOTO_EXPR
, exit_label
);
2840 TREE_USED (exit_label
) = 1;
2841 tmp
= fold_build3_loc (gfc_get_location (&code
->expr1
->where
), COND_EXPR
,
2842 void_type_node
, cond
.expr
, tmp
,
2843 build_empty_stmt (gfc_get_location (
2844 &code
->expr1
->where
)));
2845 gfc_add_expr_to_block (&block
, tmp
);
2847 /* The main body of the loop. */
2848 tmp
= gfc_trans_code (code
->block
->next
);
2849 gfc_add_expr_to_block (&block
, tmp
);
2851 /* Label for cycle statements (if needed). */
2852 if (TREE_USED (cycle_label
))
2854 tmp
= build1_v (LABEL_EXPR
, cycle_label
);
2855 gfc_add_expr_to_block (&block
, tmp
);
2858 /* End of loop body. */
2859 tmp
= gfc_finish_block (&block
);
2861 gfc_init_block (&block
);
2862 /* Build the loop. */
2863 tmp
= fold_build1_loc (gfc_get_location (&code
->expr1
->where
), LOOP_EXPR
,
2864 void_type_node
, tmp
);
2865 gfc_add_expr_to_block (&block
, tmp
);
2867 /* Add the exit label. */
2868 tmp
= build1_v (LABEL_EXPR
, exit_label
);
2869 gfc_add_expr_to_block (&block
, tmp
);
2871 return gfc_finish_block (&block
);
2875 /* Deal with the particular case of SELECT_TYPE, where the vtable
2876 addresses are used for the selection. Since these are not sorted,
2877 the selection has to be made by a series of if statements. */
2880 gfc_trans_select_type_cases (gfc_code
* code
)
2894 gfc_start_block (&block
);
2896 /* Calculate the switch expression. */
2897 gfc_init_se (&se
, NULL
);
2898 gfc_conv_expr_val (&se
, code
->expr1
);
2899 gfc_add_block_to_block (&block
, &se
.pre
);
2901 /* Generate an expression for the selector hash value, for
2902 use to resolve character cases. */
2903 e
= gfc_copy_expr (code
->expr1
->value
.function
.actual
->expr
);
2904 gfc_add_hash_component (e
);
2906 TREE_USED (code
->exit_label
) = 0;
2909 for (c
= code
->block
; c
; c
= c
->block
)
2911 cp
= c
->ext
.block
.case_list
;
2913 /* Assume it's the default case. */
2918 /* Put the default case at the end. */
2919 if ((!def
&& !cp
->low
) || (def
&& cp
->low
))
2922 if (cp
->low
&& (cp
->ts
.type
== BT_CLASS
2923 || cp
->ts
.type
== BT_DERIVED
))
2925 gfc_init_se (&cse
, NULL
);
2926 gfc_conv_expr_val (&cse
, cp
->low
);
2927 gfc_add_block_to_block (&block
, &cse
.pre
);
2930 else if (cp
->ts
.type
!= BT_UNKNOWN
)
2932 gcc_assert (cp
->high
);
2933 gfc_init_se (&cse
, NULL
);
2934 gfc_conv_expr_val (&cse
, cp
->high
);
2935 gfc_add_block_to_block (&block
, &cse
.pre
);
2939 gfc_init_block (&body
);
2941 /* Add the statements for this case. */
2942 tmp
= gfc_trans_code (c
->next
);
2943 gfc_add_expr_to_block (&body
, tmp
);
2945 /* Break to the end of the SELECT TYPE construct. The default
2946 case just falls through. */
2949 TREE_USED (code
->exit_label
) = 1;
2950 tmp
= build1_v (GOTO_EXPR
, code
->exit_label
);
2951 gfc_add_expr_to_block (&body
, tmp
);
2954 tmp
= gfc_finish_block (&body
);
2956 if (low
!= NULL_TREE
)
2958 /* Compare vtable pointers. */
2959 cond
= fold_build2_loc (input_location
, EQ_EXPR
,
2960 TREE_TYPE (se
.expr
), se
.expr
, low
);
2961 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
2963 build_empty_stmt (input_location
));
2965 else if (high
!= NULL_TREE
)
2967 /* Compare hash values for character cases. */
2968 gfc_init_se (&cse
, NULL
);
2969 gfc_conv_expr_val (&cse
, e
);
2970 gfc_add_block_to_block (&block
, &cse
.pre
);
2972 cond
= fold_build2_loc (input_location
, EQ_EXPR
,
2973 TREE_TYPE (se
.expr
), high
, cse
.expr
);
2974 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
2976 build_empty_stmt (input_location
));
2979 gfc_add_expr_to_block (&block
, tmp
);
2990 return gfc_finish_block (&block
);
2994 /* Translate the SELECT CASE construct for INTEGER case expressions,
2995 without killing all potential optimizations. The problem is that
2996 Fortran allows unbounded cases, but the back-end does not, so we
2997 need to intercept those before we enter the equivalent SWITCH_EXPR
3000 For example, we translate this,
3003 CASE (:100,101,105:115)
3013 to the GENERIC equivalent,
3017 case (minimum value for typeof(expr) ... 100:
3023 case 200 ... (maximum value for typeof(expr):
3040 gfc_trans_integer_select (gfc_code
* code
)
3050 gfc_start_block (&block
);
3052 /* Calculate the switch expression. */
3053 gfc_init_se (&se
, NULL
);
3054 gfc_conv_expr_val (&se
, code
->expr1
);
3055 gfc_add_block_to_block (&block
, &se
.pre
);
3057 end_label
= gfc_build_label_decl (NULL_TREE
);
3059 gfc_init_block (&body
);
3061 for (c
= code
->block
; c
; c
= c
->block
)
3063 for (cp
= c
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
3068 /* Assume it's the default case. */
3069 low
= high
= NULL_TREE
;
3073 low
= gfc_conv_mpz_to_tree (cp
->low
->value
.integer
,
3076 /* If there's only a lower bound, set the high bound to the
3077 maximum value of the case expression. */
3079 high
= TYPE_MAX_VALUE (TREE_TYPE (se
.expr
));
3084 /* Three cases are possible here:
3086 1) There is no lower bound, e.g. CASE (:N).
3087 2) There is a lower bound .NE. high bound, that is
3088 a case range, e.g. CASE (N:M) where M>N (we make
3089 sure that M>N during type resolution).
3090 3) There is a lower bound, and it has the same value
3091 as the high bound, e.g. CASE (N:N). This is our
3092 internal representation of CASE(N).
3094 In the first and second case, we need to set a value for
3095 high. In the third case, we don't because the GCC middle
3096 end represents a single case value by just letting high be
3097 a NULL_TREE. We can't do that because we need to be able
3098 to represent unbounded cases. */
3101 || (mpz_cmp (cp
->low
->value
.integer
,
3102 cp
->high
->value
.integer
) != 0))
3103 high
= gfc_conv_mpz_to_tree (cp
->high
->value
.integer
,
3106 /* Unbounded case. */
3108 low
= TYPE_MIN_VALUE (TREE_TYPE (se
.expr
));
3111 /* Build a label. */
3112 label
= gfc_build_label_decl (NULL_TREE
);
3114 /* Add this case label.
3115 Add parameter 'label', make it match GCC backend. */
3116 tmp
= build_case_label (low
, high
, label
);
3117 gfc_add_expr_to_block (&body
, tmp
);
3120 /* Add the statements for this case. */
3121 tmp
= gfc_trans_code (c
->next
);
3122 gfc_add_expr_to_block (&body
, tmp
);
3124 /* Break to the end of the construct. */
3125 tmp
= build1_v (GOTO_EXPR
, end_label
);
3126 gfc_add_expr_to_block (&body
, tmp
);
3129 tmp
= gfc_finish_block (&body
);
3130 tmp
= fold_build2_loc (input_location
, SWITCH_EXPR
, NULL_TREE
, se
.expr
, tmp
);
3131 gfc_add_expr_to_block (&block
, tmp
);
3133 tmp
= build1_v (LABEL_EXPR
, end_label
);
3134 gfc_add_expr_to_block (&block
, tmp
);
3136 return gfc_finish_block (&block
);
3140 /* Translate the SELECT CASE construct for LOGICAL case expressions.
3142 There are only two cases possible here, even though the standard
3143 does allow three cases in a LOGICAL SELECT CASE construct: .TRUE.,
3144 .FALSE., and DEFAULT.
3146 We never generate more than two blocks here. Instead, we always
3147 try to eliminate the DEFAULT case. This way, we can translate this
3148 kind of SELECT construct to a simple
3152 expression in GENERIC. */
3155 gfc_trans_logical_select (gfc_code
* code
)
3158 gfc_code
*t
, *f
, *d
;
3163 /* Assume we don't have any cases at all. */
3166 /* Now see which ones we actually do have. We can have at most two
3167 cases in a single case list: one for .TRUE. and one for .FALSE.
3168 The default case is always separate. If the cases for .TRUE. and
3169 .FALSE. are in the same case list, the block for that case list
3170 always executed, and we don't generate code a COND_EXPR. */
3171 for (c
= code
->block
; c
; c
= c
->block
)
3173 for (cp
= c
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
3177 if (cp
->low
->value
.logical
== 0) /* .FALSE. */
3179 else /* if (cp->value.logical != 0), thus .TRUE. */
3187 /* Start a new block. */
3188 gfc_start_block (&block
);
3190 /* Calculate the switch expression. We always need to do this
3191 because it may have side effects. */
3192 gfc_init_se (&se
, NULL
);
3193 gfc_conv_expr_val (&se
, code
->expr1
);
3194 gfc_add_block_to_block (&block
, &se
.pre
);
3196 if (t
== f
&& t
!= NULL
)
3198 /* Cases for .TRUE. and .FALSE. are in the same block. Just
3199 translate the code for these cases, append it to the current
3201 gfc_add_expr_to_block (&block
, gfc_trans_code (t
->next
));
3205 tree true_tree
, false_tree
, stmt
;
3207 true_tree
= build_empty_stmt (input_location
);
3208 false_tree
= build_empty_stmt (input_location
);
3210 /* If we have a case for .TRUE. and for .FALSE., discard the default case.
3211 Otherwise, if .TRUE. or .FALSE. is missing and there is a default case,
3212 make the missing case the default case. */
3213 if (t
!= NULL
&& f
!= NULL
)
3223 /* Translate the code for each of these blocks, and append it to
3224 the current block. */
3226 true_tree
= gfc_trans_code (t
->next
);
3229 false_tree
= gfc_trans_code (f
->next
);
3231 stmt
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
3232 se
.expr
, true_tree
, false_tree
);
3233 gfc_add_expr_to_block (&block
, stmt
);
3236 return gfc_finish_block (&block
);
3240 /* The jump table types are stored in static variables to avoid
3241 constructing them from scratch every single time. */
3242 static GTY(()) tree select_struct
[2];
3244 /* Translate the SELECT CASE construct for CHARACTER case expressions.
3245 Instead of generating compares and jumps, it is far simpler to
3246 generate a data structure describing the cases in order and call a
3247 library subroutine that locates the right case.
3248 This is particularly true because this is the only case where we
3249 might have to dispose of a temporary.
3250 The library subroutine returns a pointer to jump to or NULL if no
3251 branches are to be taken. */
3254 gfc_trans_character_select (gfc_code
*code
)
3256 tree init
, end_label
, tmp
, type
, case_num
, label
, fndecl
;
3257 stmtblock_t block
, body
;
3262 vec
<constructor_elt
, va_gc
> *inits
= NULL
;
3264 tree pchartype
= gfc_get_pchar_type (code
->expr1
->ts
.kind
);
3266 /* The jump table types are stored in static variables to avoid
3267 constructing them from scratch every single time. */
3268 static tree ss_string1
[2], ss_string1_len
[2];
3269 static tree ss_string2
[2], ss_string2_len
[2];
3270 static tree ss_target
[2];
3272 cp
= code
->block
->ext
.block
.case_list
;
3273 while (cp
->left
!= NULL
)
3276 /* Generate the body */
3277 gfc_start_block (&block
);
3278 gfc_init_se (&expr1se
, NULL
);
3279 gfc_conv_expr_reference (&expr1se
, code
->expr1
);
3281 gfc_add_block_to_block (&block
, &expr1se
.pre
);
3283 end_label
= gfc_build_label_decl (NULL_TREE
);
3285 gfc_init_block (&body
);
3287 /* Attempt to optimize length 1 selects. */
3288 if (integer_onep (expr1se
.string_length
))
3290 for (d
= cp
; d
; d
= d
->right
)
3295 gcc_assert (d
->low
->expr_type
== EXPR_CONSTANT
3296 && d
->low
->ts
.type
== BT_CHARACTER
);
3297 if (d
->low
->value
.character
.length
> 1)
3299 for (i
= 1; i
< d
->low
->value
.character
.length
; i
++)
3300 if (d
->low
->value
.character
.string
[i
] != ' ')
3302 if (i
!= d
->low
->value
.character
.length
)
3304 if (optimize
&& d
->high
&& i
== 1)
3306 gcc_assert (d
->high
->expr_type
== EXPR_CONSTANT
3307 && d
->high
->ts
.type
== BT_CHARACTER
);
3308 if (d
->high
->value
.character
.length
> 1
3309 && (d
->low
->value
.character
.string
[0]
3310 == d
->high
->value
.character
.string
[0])
3311 && d
->high
->value
.character
.string
[1] != ' '
3312 && ((d
->low
->value
.character
.string
[1] < ' ')
3313 == (d
->high
->value
.character
.string
[1]
3323 gcc_assert (d
->high
->expr_type
== EXPR_CONSTANT
3324 && d
->high
->ts
.type
== BT_CHARACTER
);
3325 if (d
->high
->value
.character
.length
> 1)
3327 for (i
= 1; i
< d
->high
->value
.character
.length
; i
++)
3328 if (d
->high
->value
.character
.string
[i
] != ' ')
3330 if (i
!= d
->high
->value
.character
.length
)
3337 tree ctype
= gfc_get_char_type (code
->expr1
->ts
.kind
);
3339 for (c
= code
->block
; c
; c
= c
->block
)
3341 for (cp
= c
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
3347 /* Assume it's the default case. */
3348 low
= high
= NULL_TREE
;
3352 /* CASE ('ab') or CASE ('ab':'az') will never match
3353 any length 1 character. */
3354 if (cp
->low
->value
.character
.length
> 1
3355 && cp
->low
->value
.character
.string
[1] != ' ')
3358 if (cp
->low
->value
.character
.length
> 0)
3359 r
= cp
->low
->value
.character
.string
[0];
3362 low
= build_int_cst (ctype
, r
);
3364 /* If there's only a lower bound, set the high bound
3365 to the maximum value of the case expression. */
3367 high
= TYPE_MAX_VALUE (ctype
);
3373 || (cp
->low
->value
.character
.string
[0]
3374 != cp
->high
->value
.character
.string
[0]))
3376 if (cp
->high
->value
.character
.length
> 0)
3377 r
= cp
->high
->value
.character
.string
[0];
3380 high
= build_int_cst (ctype
, r
);
3383 /* Unbounded case. */
3385 low
= TYPE_MIN_VALUE (ctype
);
3388 /* Build a label. */
3389 label
= gfc_build_label_decl (NULL_TREE
);
3391 /* Add this case label.
3392 Add parameter 'label', make it match GCC backend. */
3393 tmp
= build_case_label (low
, high
, label
);
3394 gfc_add_expr_to_block (&body
, tmp
);
3397 /* Add the statements for this case. */
3398 tmp
= gfc_trans_code (c
->next
);
3399 gfc_add_expr_to_block (&body
, tmp
);
3401 /* Break to the end of the construct. */
3402 tmp
= build1_v (GOTO_EXPR
, end_label
);
3403 gfc_add_expr_to_block (&body
, tmp
);
3406 tmp
= gfc_string_to_single_character (expr1se
.string_length
,
3408 code
->expr1
->ts
.kind
);
3409 case_num
= gfc_create_var (ctype
, "case_num");
3410 gfc_add_modify (&block
, case_num
, tmp
);
3412 gfc_add_block_to_block (&block
, &expr1se
.post
);
3414 tmp
= gfc_finish_block (&body
);
3415 tmp
= fold_build2_loc (input_location
, SWITCH_EXPR
, NULL_TREE
,
3417 gfc_add_expr_to_block (&block
, tmp
);
3419 tmp
= build1_v (LABEL_EXPR
, end_label
);
3420 gfc_add_expr_to_block (&block
, tmp
);
3422 return gfc_finish_block (&block
);
3426 if (code
->expr1
->ts
.kind
== 1)
3428 else if (code
->expr1
->ts
.kind
== 4)
3433 if (select_struct
[k
] == NULL
)
3436 select_struct
[k
] = make_node (RECORD_TYPE
);
3438 if (code
->expr1
->ts
.kind
== 1)
3439 TYPE_NAME (select_struct
[k
]) = get_identifier ("_jump_struct_char1");
3440 else if (code
->expr1
->ts
.kind
== 4)
3441 TYPE_NAME (select_struct
[k
]) = get_identifier ("_jump_struct_char4");
3446 #define ADD_FIELD(NAME, TYPE) \
3447 ss_##NAME[k] = gfc_add_field_to_struct (select_struct[k], \
3448 get_identifier (stringize(NAME)), \
3452 ADD_FIELD (string1
, pchartype
);
3453 ADD_FIELD (string1_len
, gfc_charlen_type_node
);
3455 ADD_FIELD (string2
, pchartype
);
3456 ADD_FIELD (string2_len
, gfc_charlen_type_node
);
3458 ADD_FIELD (target
, integer_type_node
);
3461 gfc_finish_type (select_struct
[k
]);
3465 for (d
= cp
; d
; d
= d
->right
)
3468 for (c
= code
->block
; c
; c
= c
->block
)
3470 for (d
= c
->ext
.block
.case_list
; d
; d
= d
->next
)
3472 label
= gfc_build_label_decl (NULL_TREE
);
3473 tmp
= build_case_label ((d
->low
== NULL
&& d
->high
== NULL
)
3475 : build_int_cst (integer_type_node
, d
->n
),
3477 gfc_add_expr_to_block (&body
, tmp
);
3480 tmp
= gfc_trans_code (c
->next
);
3481 gfc_add_expr_to_block (&body
, tmp
);
3483 tmp
= build1_v (GOTO_EXPR
, end_label
);
3484 gfc_add_expr_to_block (&body
, tmp
);
3487 /* Generate the structure describing the branches */
3488 for (d
= cp
; d
; d
= d
->right
)
3490 vec
<constructor_elt
, va_gc
> *node
= NULL
;
3492 gfc_init_se (&se
, NULL
);
3496 CONSTRUCTOR_APPEND_ELT (node
, ss_string1
[k
], null_pointer_node
);
3497 CONSTRUCTOR_APPEND_ELT (node
, ss_string1_len
[k
], build_zero_cst (gfc_charlen_type_node
));
3501 gfc_conv_expr_reference (&se
, d
->low
);
3503 CONSTRUCTOR_APPEND_ELT (node
, ss_string1
[k
], se
.expr
);
3504 CONSTRUCTOR_APPEND_ELT (node
, ss_string1_len
[k
], se
.string_length
);
3507 if (d
->high
== NULL
)
3509 CONSTRUCTOR_APPEND_ELT (node
, ss_string2
[k
], null_pointer_node
);
3510 CONSTRUCTOR_APPEND_ELT (node
, ss_string2_len
[k
], build_zero_cst (gfc_charlen_type_node
));
3514 gfc_init_se (&se
, NULL
);
3515 gfc_conv_expr_reference (&se
, d
->high
);
3517 CONSTRUCTOR_APPEND_ELT (node
, ss_string2
[k
], se
.expr
);
3518 CONSTRUCTOR_APPEND_ELT (node
, ss_string2_len
[k
], se
.string_length
);
3521 CONSTRUCTOR_APPEND_ELT (node
, ss_target
[k
],
3522 build_int_cst (integer_type_node
, d
->n
));
3524 tmp
= build_constructor (select_struct
[k
], node
);
3525 CONSTRUCTOR_APPEND_ELT (inits
, NULL_TREE
, tmp
);
3528 type
= build_array_type (select_struct
[k
],
3529 build_index_type (size_int (n
-1)));
3531 init
= build_constructor (type
, inits
);
3532 TREE_CONSTANT (init
) = 1;
3533 TREE_STATIC (init
) = 1;
3534 /* Create a static variable to hold the jump table. */
3535 tmp
= gfc_create_var (type
, "jumptable");
3536 TREE_CONSTANT (tmp
) = 1;
3537 TREE_STATIC (tmp
) = 1;
3538 TREE_READONLY (tmp
) = 1;
3539 DECL_INITIAL (tmp
) = init
;
3542 /* Build the library call */
3543 init
= gfc_build_addr_expr (pvoid_type_node
, init
);
3545 if (code
->expr1
->ts
.kind
== 1)
3546 fndecl
= gfor_fndecl_select_string
;
3547 else if (code
->expr1
->ts
.kind
== 4)
3548 fndecl
= gfor_fndecl_select_string_char4
;
3552 tmp
= build_call_expr_loc (input_location
,
3554 build_int_cst (gfc_charlen_type_node
, n
),
3555 expr1se
.expr
, expr1se
.string_length
);
3556 case_num
= gfc_create_var (integer_type_node
, "case_num");
3557 gfc_add_modify (&block
, case_num
, tmp
);
3559 gfc_add_block_to_block (&block
, &expr1se
.post
);
3561 tmp
= gfc_finish_block (&body
);
3562 tmp
= fold_build2_loc (input_location
, SWITCH_EXPR
, NULL_TREE
,
3564 gfc_add_expr_to_block (&block
, tmp
);
3566 tmp
= build1_v (LABEL_EXPR
, end_label
);
3567 gfc_add_expr_to_block (&block
, tmp
);
3569 return gfc_finish_block (&block
);
3573 /* Translate the three variants of the SELECT CASE construct.
3575 SELECT CASEs with INTEGER case expressions can be translated to an
3576 equivalent GENERIC switch statement, and for LOGICAL case
3577 expressions we build one or two if-else compares.
3579 SELECT CASEs with CHARACTER case expressions are a whole different
3580 story, because they don't exist in GENERIC. So we sort them and
3581 do a binary search at runtime.
3583 Fortran has no BREAK statement, and it does not allow jumps from
3584 one case block to another. That makes things a lot easier for
3588 gfc_trans_select (gfc_code
* code
)
3594 gcc_assert (code
&& code
->expr1
);
3595 gfc_init_block (&block
);
3597 /* Build the exit label and hang it in. */
3598 exit_label
= gfc_build_label_decl (NULL_TREE
);
3599 code
->exit_label
= exit_label
;
3601 /* Empty SELECT constructs are legal. */
3602 if (code
->block
== NULL
)
3603 body
= build_empty_stmt (input_location
);
3605 /* Select the correct translation function. */
3607 switch (code
->expr1
->ts
.type
)
3610 body
= gfc_trans_logical_select (code
);
3614 body
= gfc_trans_integer_select (code
);
3618 body
= gfc_trans_character_select (code
);
3622 gfc_internal_error ("gfc_trans_select(): Bad type for case expr.");
3626 /* Build everything together. */
3627 gfc_add_expr_to_block (&block
, body
);
3628 gfc_add_expr_to_block (&block
, build1_v (LABEL_EXPR
, exit_label
));
3630 return gfc_finish_block (&block
);
3634 gfc_trans_select_type (gfc_code
* code
)
3640 gcc_assert (code
&& code
->expr1
);
3641 gfc_init_block (&block
);
3643 /* Build the exit label and hang it in. */
3644 exit_label
= gfc_build_label_decl (NULL_TREE
);
3645 code
->exit_label
= exit_label
;
3647 /* Empty SELECT constructs are legal. */
3648 if (code
->block
== NULL
)
3649 body
= build_empty_stmt (input_location
);
3651 body
= gfc_trans_select_type_cases (code
);
3653 /* Build everything together. */
3654 gfc_add_expr_to_block (&block
, body
);
3656 if (TREE_USED (exit_label
))
3657 gfc_add_expr_to_block (&block
, build1_v (LABEL_EXPR
, exit_label
));
3659 return gfc_finish_block (&block
);
3664 gfc_trans_select_rank_cases (gfc_code
* code
)
3678 gfc_start_block (&block
);
3680 /* Calculate the switch expression. */
3681 gfc_init_se (&se
, NULL
);
3682 gfc_conv_expr_descriptor (&se
, code
->expr1
);
3683 rank
= gfc_conv_descriptor_rank (se
.expr
);
3684 rank
= gfc_evaluate_now (rank
, &block
);
3685 symbol_attribute attr
= gfc_expr_attr (code
->expr1
);
3686 if (!attr
.pointer
&& !attr
.allocatable
)
3688 /* Special case for assumed-rank ('rank(*)', internally -1):
3689 rank = (rank == 0 || ubound[rank-1] != -1) ? rank : -1. */
3690 cond
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
,
3691 rank
, build_int_cst (TREE_TYPE (rank
), 0));
3692 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
3693 fold_convert (gfc_array_index_type
, rank
),
3694 gfc_index_one_node
);
3695 tmp
= gfc_conv_descriptor_ubound_get (se
.expr
, tmp
);
3696 tmp
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
3697 tmp
, build_int_cst (TREE_TYPE (tmp
), -1));
3698 cond
= fold_build2_loc (input_location
, TRUTH_ORIF_EXPR
,
3699 logical_type_node
, cond
, tmp
);
3700 tmp
= fold_build3_loc (input_location
, COND_EXPR
, TREE_TYPE (rank
),
3701 cond
, rank
, build_int_cst (TREE_TYPE (rank
), -1));
3702 rank
= gfc_evaluate_now (tmp
, &block
);
3704 TREE_USED (code
->exit_label
) = 0;
3707 for (c
= code
->block
; c
; c
= c
->block
)
3709 cp
= c
->ext
.block
.case_list
;
3711 /* Assume it's the default case. */
3715 /* Put the default case at the end. */
3716 if ((!def
&& !cp
->low
) || (def
&& cp
->low
))
3721 gfc_init_se (&cse
, NULL
);
3722 gfc_conv_expr_val (&cse
, cp
->low
);
3723 gfc_add_block_to_block (&block
, &cse
.pre
);
3727 gfc_init_block (&body
);
3729 /* Add the statements for this case. */
3730 tmp
= gfc_trans_code (c
->next
);
3731 gfc_add_expr_to_block (&body
, tmp
);
3733 /* Break to the end of the SELECT RANK construct. The default
3734 case just falls through. */
3737 TREE_USED (code
->exit_label
) = 1;
3738 tmp
= build1_v (GOTO_EXPR
, code
->exit_label
);
3739 gfc_add_expr_to_block (&body
, tmp
);
3742 tmp
= gfc_finish_block (&body
);
3744 if (low
!= NULL_TREE
)
3746 cond
= fold_build2_loc (input_location
, EQ_EXPR
,
3747 TREE_TYPE (rank
), rank
,
3748 fold_convert (TREE_TYPE (rank
), low
));
3749 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
3751 build_empty_stmt (input_location
));
3754 gfc_add_expr_to_block (&block
, tmp
);
3763 return gfc_finish_block (&block
);
3768 gfc_trans_select_rank (gfc_code
* code
)
3774 gcc_assert (code
&& code
->expr1
);
3775 gfc_init_block (&block
);
3777 /* Build the exit label and hang it in. */
3778 exit_label
= gfc_build_label_decl (NULL_TREE
);
3779 code
->exit_label
= exit_label
;
3781 /* Empty SELECT constructs are legal. */
3782 if (code
->block
== NULL
)
3783 body
= build_empty_stmt (input_location
);
3785 body
= gfc_trans_select_rank_cases (code
);
3787 /* Build everything together. */
3788 gfc_add_expr_to_block (&block
, body
);
3790 if (TREE_USED (exit_label
))
3791 gfc_add_expr_to_block (&block
, build1_v (LABEL_EXPR
, exit_label
));
3793 return gfc_finish_block (&block
);
3797 /* Traversal function to substitute a replacement symtree if the symbol
3798 in the expression is the same as that passed. f == 2 signals that
3799 that variable itself is not to be checked - only the references.
3800 This group of functions is used when the variable expression in a
3801 FORALL assignment has internal references. For example:
3802 FORALL (i = 1:4) p(p(i)) = i
3803 The only recourse here is to store a copy of 'p' for the index
3806 static gfc_symtree
*new_symtree
;
3807 static gfc_symtree
*old_symtree
;
3810 forall_replace (gfc_expr
*expr
, gfc_symbol
*sym
, int *f
)
3812 if (expr
->expr_type
!= EXPR_VARIABLE
)
3817 else if (expr
->symtree
->n
.sym
== sym
)
3818 expr
->symtree
= new_symtree
;
3824 forall_replace_symtree (gfc_expr
*e
, gfc_symbol
*sym
, int f
)
3826 gfc_traverse_expr (e
, sym
, forall_replace
, f
);
3830 forall_restore (gfc_expr
*expr
,
3831 gfc_symbol
*sym ATTRIBUTE_UNUSED
,
3832 int *f ATTRIBUTE_UNUSED
)
3834 if (expr
->expr_type
!= EXPR_VARIABLE
)
3837 if (expr
->symtree
== new_symtree
)
3838 expr
->symtree
= old_symtree
;
3844 forall_restore_symtree (gfc_expr
*e
)
3846 gfc_traverse_expr (e
, NULL
, forall_restore
, 0);
3850 forall_make_variable_temp (gfc_code
*c
, stmtblock_t
*pre
, stmtblock_t
*post
)
3855 gfc_symbol
*new_sym
;
3856 gfc_symbol
*old_sym
;
3860 /* Build a copy of the lvalue. */
3861 old_symtree
= c
->expr1
->symtree
;
3862 old_sym
= old_symtree
->n
.sym
;
3863 e
= gfc_lval_expr_from_sym (old_sym
);
3864 if (old_sym
->attr
.dimension
)
3866 gfc_init_se (&tse
, NULL
);
3867 gfc_conv_subref_array_arg (&tse
, e
, 0, INTENT_IN
, false);
3868 gfc_add_block_to_block (pre
, &tse
.pre
);
3869 gfc_add_block_to_block (post
, &tse
.post
);
3870 tse
.expr
= build_fold_indirect_ref_loc (input_location
, tse
.expr
);
3872 if (c
->expr1
->ref
->u
.ar
.type
!= AR_SECTION
)
3874 /* Use the variable offset for the temporary. */
3875 tmp
= gfc_conv_array_offset (old_sym
->backend_decl
);
3876 gfc_conv_descriptor_offset_set (pre
, tse
.expr
, tmp
);
3881 gfc_init_se (&tse
, NULL
);
3882 gfc_init_se (&rse
, NULL
);
3883 gfc_conv_expr (&rse
, e
);
3884 if (e
->ts
.type
== BT_CHARACTER
)
3886 tse
.string_length
= rse
.string_length
;
3887 tmp
= gfc_get_character_type_len (gfc_default_character_kind
,
3889 tse
.expr
= gfc_conv_string_tmp (&tse
, build_pointer_type (tmp
),
3891 gfc_add_block_to_block (pre
, &tse
.pre
);
3892 gfc_add_block_to_block (post
, &tse
.post
);
3896 tmp
= gfc_typenode_for_spec (&e
->ts
);
3897 tse
.expr
= gfc_create_var (tmp
, "temp");
3900 tmp
= gfc_trans_scalar_assign (&tse
, &rse
, e
->ts
,
3901 e
->expr_type
== EXPR_VARIABLE
, false);
3902 gfc_add_expr_to_block (pre
, tmp
);
3906 /* Create a new symbol to represent the lvalue. */
3907 new_sym
= gfc_new_symbol (old_sym
->name
, NULL
);
3908 new_sym
->ts
= old_sym
->ts
;
3909 new_sym
->attr
.referenced
= 1;
3910 new_sym
->attr
.temporary
= 1;
3911 new_sym
->attr
.dimension
= old_sym
->attr
.dimension
;
3912 new_sym
->attr
.flavor
= old_sym
->attr
.flavor
;
3914 /* Use the temporary as the backend_decl. */
3915 new_sym
->backend_decl
= tse
.expr
;
3917 /* Create a fake symtree for it. */
3919 new_symtree
= gfc_new_symtree (&root
, old_sym
->name
);
3920 new_symtree
->n
.sym
= new_sym
;
3921 gcc_assert (new_symtree
== root
);
3923 /* Go through the expression reference replacing the old_symtree
3925 forall_replace_symtree (c
->expr1
, old_sym
, 2);
3927 /* Now we have made this temporary, we might as well use it for
3928 the right hand side. */
3929 forall_replace_symtree (c
->expr2
, old_sym
, 1);
3933 /* Handles dependencies in forall assignments. */
3935 check_forall_dependencies (gfc_code
*c
, stmtblock_t
*pre
, stmtblock_t
*post
)
3942 lsym
= c
->expr1
->symtree
->n
.sym
;
3943 need_temp
= gfc_check_dependency (c
->expr1
, c
->expr2
, 0);
3945 /* Now check for dependencies within the 'variable'
3946 expression itself. These are treated by making a complete
3947 copy of variable and changing all the references to it
3948 point to the copy instead. Note that the shallow copy of
3949 the variable will not suffice for derived types with
3950 pointer components. We therefore leave these to their
3951 own devices. Likewise for allocatable components. */
3952 if (lsym
->ts
.type
== BT_DERIVED
3953 && (lsym
->ts
.u
.derived
->attr
.pointer_comp
3954 || lsym
->ts
.u
.derived
->attr
.alloc_comp
))
3958 if (find_forall_index (c
->expr1
, lsym
, 2))
3960 forall_make_variable_temp (c
, pre
, post
);
3964 /* Substrings with dependencies are treated in the same
3966 if (c
->expr1
->ts
.type
== BT_CHARACTER
3968 && c
->expr2
->expr_type
== EXPR_VARIABLE
3969 && lsym
== c
->expr2
->symtree
->n
.sym
)
3971 for (lref
= c
->expr1
->ref
; lref
; lref
= lref
->next
)
3972 if (lref
->type
== REF_SUBSTRING
)
3974 for (rref
= c
->expr2
->ref
; rref
; rref
= rref
->next
)
3975 if (rref
->type
== REF_SUBSTRING
)
3979 && gfc_dep_compare_expr (rref
->u
.ss
.start
, lref
->u
.ss
.start
) < 0)
3981 forall_make_variable_temp (c
, pre
, post
);
3990 cleanup_forall_symtrees (gfc_code
*c
)
3992 forall_restore_symtree (c
->expr1
);
3993 forall_restore_symtree (c
->expr2
);
3994 free (new_symtree
->n
.sym
);
3999 /* Generate the loops for a FORALL block, specified by FORALL_TMP. BODY
4000 is the contents of the FORALL block/stmt to be iterated. MASK_FLAG
4001 indicates whether we should generate code to test the FORALLs mask
4002 array. OUTER is the loop header to be used for initializing mask
4005 The generated loop format is:
4006 count = (end - start + step) / step
4019 gfc_trans_forall_loop (forall_info
*forall_tmp
, tree body
,
4020 int mask_flag
, stmtblock_t
*outer
)
4028 tree var
, start
, end
, step
;
4031 /* Initialize the mask index outside the FORALL nest. */
4032 if (mask_flag
&& forall_tmp
->mask
)
4033 gfc_add_modify (outer
, forall_tmp
->maskindex
, gfc_index_zero_node
);
4035 iter
= forall_tmp
->this_loop
;
4036 nvar
= forall_tmp
->nvar
;
4037 for (n
= 0; n
< nvar
; n
++)
4040 start
= iter
->start
;
4044 exit_label
= gfc_build_label_decl (NULL_TREE
);
4045 TREE_USED (exit_label
) = 1;
4047 /* The loop counter. */
4048 count
= gfc_create_var (TREE_TYPE (var
), "count");
4050 /* The body of the loop. */
4051 gfc_init_block (&block
);
4053 /* The exit condition. */
4054 cond
= fold_build2_loc (input_location
, LE_EXPR
, logical_type_node
,
4055 count
, build_int_cst (TREE_TYPE (count
), 0));
4057 /* PR 83064 means that we cannot use annot_expr_parallel_kind until
4058 the autoparallelizer can hande this. */
4059 if (forall_tmp
->do_concurrent
)
4060 cond
= build3 (ANNOTATE_EXPR
, TREE_TYPE (cond
), cond
,
4061 build_int_cst (integer_type_node
,
4062 annot_expr_ivdep_kind
),
4065 tmp
= build1_v (GOTO_EXPR
, exit_label
);
4066 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
4067 cond
, tmp
, build_empty_stmt (input_location
));
4068 gfc_add_expr_to_block (&block
, tmp
);
4070 /* The main loop body. */
4071 gfc_add_expr_to_block (&block
, body
);
4073 /* Increment the loop variable. */
4074 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (var
), var
,
4076 gfc_add_modify (&block
, var
, tmp
);
4078 /* Advance to the next mask element. Only do this for the
4080 if (n
== 0 && mask_flag
&& forall_tmp
->mask
)
4082 tree maskindex
= forall_tmp
->maskindex
;
4083 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
4084 maskindex
, gfc_index_one_node
);
4085 gfc_add_modify (&block
, maskindex
, tmp
);
4088 /* Decrement the loop counter. */
4089 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (var
), count
,
4090 build_int_cst (TREE_TYPE (var
), 1));
4091 gfc_add_modify (&block
, count
, tmp
);
4093 body
= gfc_finish_block (&block
);
4095 /* Loop var initialization. */
4096 gfc_init_block (&block
);
4097 gfc_add_modify (&block
, var
, start
);
4100 /* Initialize the loop counter. */
4101 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (var
), step
,
4103 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (var
), end
,
4105 tmp
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
, TREE_TYPE (var
),
4107 gfc_add_modify (&block
, count
, tmp
);
4109 /* The loop expression. */
4110 tmp
= build1_v (LOOP_EXPR
, body
);
4111 gfc_add_expr_to_block (&block
, tmp
);
4113 /* The exit label. */
4114 tmp
= build1_v (LABEL_EXPR
, exit_label
);
4115 gfc_add_expr_to_block (&block
, tmp
);
4117 body
= gfc_finish_block (&block
);
4124 /* Generate the body and loops according to MASK_FLAG. If MASK_FLAG
4125 is nonzero, the body is controlled by all masks in the forall nest.
4126 Otherwise, the innermost loop is not controlled by it's mask. This
4127 is used for initializing that mask. */
4130 gfc_trans_nested_forall_loop (forall_info
* nested_forall_info
, tree body
,
4135 forall_info
*forall_tmp
;
4136 tree mask
, maskindex
;
4138 gfc_start_block (&header
);
4140 forall_tmp
= nested_forall_info
;
4141 while (forall_tmp
!= NULL
)
4143 /* Generate body with masks' control. */
4146 mask
= forall_tmp
->mask
;
4147 maskindex
= forall_tmp
->maskindex
;
4149 /* If a mask was specified make the assignment conditional. */
4152 tmp
= gfc_build_array_ref (mask
, maskindex
, NULL
);
4153 body
= build3_v (COND_EXPR
, tmp
, body
,
4154 build_empty_stmt (input_location
));
4157 body
= gfc_trans_forall_loop (forall_tmp
, body
, mask_flag
, &header
);
4158 forall_tmp
= forall_tmp
->prev_nest
;
4162 gfc_add_expr_to_block (&header
, body
);
4163 return gfc_finish_block (&header
);
4167 /* Allocate data for holding a temporary array. Returns either a local
4168 temporary array or a pointer variable. */
4171 gfc_do_allocate (tree bytesize
, tree size
, tree
* pdata
, stmtblock_t
* pblock
,
4178 if (INTEGER_CST_P (size
))
4179 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
4180 size
, gfc_index_one_node
);
4184 type
= build_range_type (gfc_array_index_type
, gfc_index_zero_node
, tmp
);
4185 type
= build_array_type (elem_type
, type
);
4186 if (gfc_can_put_var_on_stack (bytesize
) && INTEGER_CST_P (size
))
4188 tmpvar
= gfc_create_var (type
, "temp");
4193 tmpvar
= gfc_create_var (build_pointer_type (type
), "temp");
4194 *pdata
= convert (pvoid_type_node
, tmpvar
);
4196 tmp
= gfc_call_malloc (pblock
, TREE_TYPE (tmpvar
), bytesize
);
4197 gfc_add_modify (pblock
, tmpvar
, tmp
);
4203 /* Generate codes to copy the temporary to the actual lhs. */
4206 generate_loop_for_temp_to_lhs (gfc_expr
*expr
, tree tmp1
, tree count3
,
4208 gfc_ss
*lss
, gfc_ss
*rss
,
4209 tree wheremask
, bool invert
)
4211 stmtblock_t block
, body1
;
4218 (void) rss
; /* TODO: unused. */
4220 gfc_start_block (&block
);
4222 gfc_init_se (&rse
, NULL
);
4223 gfc_init_se (&lse
, NULL
);
4225 if (lss
== gfc_ss_terminator
)
4227 gfc_init_block (&body1
);
4228 gfc_conv_expr (&lse
, expr
);
4229 rse
.expr
= gfc_build_array_ref (tmp1
, count1
, NULL
);
4233 /* Initialize the loop. */
4234 gfc_init_loopinfo (&loop
);
4236 /* We may need LSS to determine the shape of the expression. */
4237 gfc_add_ss_to_loop (&loop
, lss
);
4239 gfc_conv_ss_startstride (&loop
);
4240 gfc_conv_loop_setup (&loop
, &expr
->where
);
4242 gfc_mark_ss_chain_used (lss
, 1);
4243 /* Start the loop body. */
4244 gfc_start_scalarized_body (&loop
, &body1
);
4246 /* Translate the expression. */
4247 gfc_copy_loopinfo_to_se (&lse
, &loop
);
4249 gfc_conv_expr (&lse
, expr
);
4251 /* Form the expression of the temporary. */
4252 rse
.expr
= gfc_build_array_ref (tmp1
, count1
, NULL
);
4255 /* Use the scalar assignment. */
4256 rse
.string_length
= lse
.string_length
;
4257 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
,
4258 expr
->expr_type
== EXPR_VARIABLE
, false);
4260 /* Form the mask expression according to the mask tree list. */
4263 wheremaskexpr
= gfc_build_array_ref (wheremask
, count3
, NULL
);
4265 wheremaskexpr
= fold_build1_loc (input_location
, TRUTH_NOT_EXPR
,
4266 TREE_TYPE (wheremaskexpr
),
4268 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
4270 build_empty_stmt (input_location
));
4273 gfc_add_expr_to_block (&body1
, tmp
);
4275 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (count1
),
4276 count1
, gfc_index_one_node
);
4277 gfc_add_modify (&body1
, count1
, tmp
);
4279 if (lss
== gfc_ss_terminator
)
4280 gfc_add_block_to_block (&block
, &body1
);
4283 /* Increment count3. */
4286 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
4287 gfc_array_index_type
,
4288 count3
, gfc_index_one_node
);
4289 gfc_add_modify (&body1
, count3
, tmp
);
4292 /* Generate the copying loops. */
4293 gfc_trans_scalarizing_loops (&loop
, &body1
);
4295 gfc_add_block_to_block (&block
, &loop
.pre
);
4296 gfc_add_block_to_block (&block
, &loop
.post
);
4298 gfc_cleanup_loop (&loop
);
4299 /* TODO: Reuse lss and rss when copying temp->lhs. Need to be careful
4300 as tree nodes in SS may not be valid in different scope. */
4303 tmp
= gfc_finish_block (&block
);
4308 /* Generate codes to copy rhs to the temporary. TMP1 is the address of
4309 temporary, LSS and RSS are formed in function compute_inner_temp_size(),
4310 and should not be freed. WHEREMASK is the conditional execution mask
4311 whose sense may be inverted by INVERT. */
4314 generate_loop_for_rhs_to_temp (gfc_expr
*expr2
, tree tmp1
, tree count3
,
4315 tree count1
, gfc_ss
*lss
, gfc_ss
*rss
,
4316 tree wheremask
, bool invert
)
4318 stmtblock_t block
, body1
;
4325 gfc_start_block (&block
);
4327 gfc_init_se (&rse
, NULL
);
4328 gfc_init_se (&lse
, NULL
);
4330 if (lss
== gfc_ss_terminator
)
4332 gfc_init_block (&body1
);
4333 gfc_conv_expr (&rse
, expr2
);
4334 lse
.expr
= gfc_build_array_ref (tmp1
, count1
, NULL
);
4338 /* Initialize the loop. */
4339 gfc_init_loopinfo (&loop
);
4341 /* We may need LSS to determine the shape of the expression. */
4342 gfc_add_ss_to_loop (&loop
, lss
);
4343 gfc_add_ss_to_loop (&loop
, rss
);
4345 gfc_conv_ss_startstride (&loop
);
4346 gfc_conv_loop_setup (&loop
, &expr2
->where
);
4348 gfc_mark_ss_chain_used (rss
, 1);
4349 /* Start the loop body. */
4350 gfc_start_scalarized_body (&loop
, &body1
);
4352 /* Translate the expression. */
4353 gfc_copy_loopinfo_to_se (&rse
, &loop
);
4355 gfc_conv_expr (&rse
, expr2
);
4357 /* Form the expression of the temporary. */
4358 lse
.expr
= gfc_build_array_ref (tmp1
, count1
, NULL
);
4361 /* Use the scalar assignment. */
4362 lse
.string_length
= rse
.string_length
;
4363 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr2
->ts
,
4364 expr2
->expr_type
== EXPR_VARIABLE
, false);
4366 /* Form the mask expression according to the mask tree list. */
4369 wheremaskexpr
= gfc_build_array_ref (wheremask
, count3
, NULL
);
4371 wheremaskexpr
= fold_build1_loc (input_location
, TRUTH_NOT_EXPR
,
4372 TREE_TYPE (wheremaskexpr
),
4374 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
4376 build_empty_stmt (input_location
));
4379 gfc_add_expr_to_block (&body1
, tmp
);
4381 if (lss
== gfc_ss_terminator
)
4383 gfc_add_block_to_block (&block
, &body1
);
4385 /* Increment count1. */
4386 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (count1
),
4387 count1
, gfc_index_one_node
);
4388 gfc_add_modify (&block
, count1
, tmp
);
4392 /* Increment count1. */
4393 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
4394 count1
, gfc_index_one_node
);
4395 gfc_add_modify (&body1
, count1
, tmp
);
4397 /* Increment count3. */
4400 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
4401 gfc_array_index_type
,
4402 count3
, gfc_index_one_node
);
4403 gfc_add_modify (&body1
, count3
, tmp
);
4406 /* Generate the copying loops. */
4407 gfc_trans_scalarizing_loops (&loop
, &body1
);
4409 gfc_add_block_to_block (&block
, &loop
.pre
);
4410 gfc_add_block_to_block (&block
, &loop
.post
);
4412 gfc_cleanup_loop (&loop
);
4413 /* TODO: Reuse lss and rss when copying temp->lhs. Need to be careful
4414 as tree nodes in SS may not be valid in different scope. */
4417 tmp
= gfc_finish_block (&block
);
4422 /* Calculate the size of temporary needed in the assignment inside forall.
4423 LSS and RSS are filled in this function. */
4426 compute_inner_temp_size (gfc_expr
*expr1
, gfc_expr
*expr2
,
4427 stmtblock_t
* pblock
,
4428 gfc_ss
**lss
, gfc_ss
**rss
)
4436 *lss
= gfc_walk_expr (expr1
);
4439 size
= gfc_index_one_node
;
4440 if (*lss
!= gfc_ss_terminator
)
4442 gfc_init_loopinfo (&loop
);
4444 /* Walk the RHS of the expression. */
4445 *rss
= gfc_walk_expr (expr2
);
4446 if (*rss
== gfc_ss_terminator
)
4447 /* The rhs is scalar. Add a ss for the expression. */
4448 *rss
= gfc_get_scalar_ss (gfc_ss_terminator
, expr2
);
4450 /* Associate the SS with the loop. */
4451 gfc_add_ss_to_loop (&loop
, *lss
);
4452 /* We don't actually need to add the rhs at this point, but it might
4453 make guessing the loop bounds a bit easier. */
4454 gfc_add_ss_to_loop (&loop
, *rss
);
4456 /* We only want the shape of the expression, not rest of the junk
4457 generated by the scalarizer. */
4458 loop
.array_parameter
= 1;
4460 /* Calculate the bounds of the scalarization. */
4461 save_flag
= gfc_option
.rtcheck
;
4462 gfc_option
.rtcheck
&= ~GFC_RTCHECK_BOUNDS
;
4463 gfc_conv_ss_startstride (&loop
);
4464 gfc_option
.rtcheck
= save_flag
;
4465 gfc_conv_loop_setup (&loop
, &expr2
->where
);
4467 /* Figure out how many elements we need. */
4468 for (i
= 0; i
< loop
.dimen
; i
++)
4470 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4471 gfc_array_index_type
,
4472 gfc_index_one_node
, loop
.from
[i
]);
4473 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
4474 gfc_array_index_type
, tmp
, loop
.to
[i
]);
4475 size
= fold_build2_loc (input_location
, MULT_EXPR
,
4476 gfc_array_index_type
, size
, tmp
);
4478 gfc_add_block_to_block (pblock
, &loop
.pre
);
4479 size
= gfc_evaluate_now (size
, pblock
);
4480 gfc_add_block_to_block (pblock
, &loop
.post
);
4482 /* TODO: write a function that cleans up a loopinfo without freeing
4483 the SS chains. Currently a NOP. */
4490 /* Calculate the overall iterator number of the nested forall construct.
4491 This routine actually calculates the number of times the body of the
4492 nested forall specified by NESTED_FORALL_INFO is executed and multiplies
4493 that by the expression INNER_SIZE. The BLOCK argument specifies the
4494 block in which to calculate the result, and the optional INNER_SIZE_BODY
4495 argument contains any statements that need to executed (inside the loop)
4496 to initialize or calculate INNER_SIZE. */
4499 compute_overall_iter_number (forall_info
*nested_forall_info
, tree inner_size
,
4500 stmtblock_t
*inner_size_body
, stmtblock_t
*block
)
4502 forall_info
*forall_tmp
= nested_forall_info
;
4506 /* We can eliminate the innermost unconditional loops with constant
4508 if (INTEGER_CST_P (inner_size
))
4511 && !forall_tmp
->mask
4512 && INTEGER_CST_P (forall_tmp
->size
))
4514 inner_size
= fold_build2_loc (input_location
, MULT_EXPR
,
4515 gfc_array_index_type
,
4516 inner_size
, forall_tmp
->size
);
4517 forall_tmp
= forall_tmp
->prev_nest
;
4520 /* If there are no loops left, we have our constant result. */
4525 /* Otherwise, create a temporary variable to compute the result. */
4526 number
= gfc_create_var (gfc_array_index_type
, "num");
4527 gfc_add_modify (block
, number
, gfc_index_zero_node
);
4529 gfc_start_block (&body
);
4530 if (inner_size_body
)
4531 gfc_add_block_to_block (&body
, inner_size_body
);
4533 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
4534 gfc_array_index_type
, number
, inner_size
);
4537 gfc_add_modify (&body
, number
, tmp
);
4538 tmp
= gfc_finish_block (&body
);
4540 /* Generate loops. */
4541 if (forall_tmp
!= NULL
)
4542 tmp
= gfc_trans_nested_forall_loop (forall_tmp
, tmp
, 1);
4544 gfc_add_expr_to_block (block
, tmp
);
4550 /* Allocate temporary for forall construct. SIZE is the size of temporary
4551 needed. PTEMP1 is returned for space free. */
4554 allocate_temp_for_forall_nest_1 (tree type
, tree size
, stmtblock_t
* block
,
4561 unit
= fold_convert (gfc_array_index_type
, TYPE_SIZE_UNIT (type
));
4562 if (!integer_onep (unit
))
4563 bytesize
= fold_build2_loc (input_location
, MULT_EXPR
,
4564 gfc_array_index_type
, size
, unit
);
4569 tmp
= gfc_do_allocate (bytesize
, size
, ptemp1
, block
, type
);
4572 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
4577 /* Allocate temporary for forall construct according to the information in
4578 nested_forall_info. INNER_SIZE is the size of temporary needed in the
4579 assignment inside forall. PTEMP1 is returned for space free. */
4582 allocate_temp_for_forall_nest (forall_info
* nested_forall_info
, tree type
,
4583 tree inner_size
, stmtblock_t
* inner_size_body
,
4584 stmtblock_t
* block
, tree
* ptemp1
)
4588 /* Calculate the total size of temporary needed in forall construct. */
4589 size
= compute_overall_iter_number (nested_forall_info
, inner_size
,
4590 inner_size_body
, block
);
4592 return allocate_temp_for_forall_nest_1 (type
, size
, block
, ptemp1
);
4596 /* Handle assignments inside forall which need temporary.
4598 forall (i=start:end:stride; maskexpr)
4601 (where e,f<i> are arbitrary expressions possibly involving i
4602 and there is a dependency between e<i> and f<i>)
4604 masktmp(:) = maskexpr(:)
4609 for (i = start; i <= end; i += stride)
4613 for (i = start; i <= end; i += stride)
4615 if (masktmp[maskindex++])
4616 tmp[count1++] = f<i>
4620 for (i = start; i <= end; i += stride)
4622 if (masktmp[maskindex++])
4623 e<i> = tmp[count1++]
4628 gfc_trans_assign_need_temp (gfc_expr
* expr1
, gfc_expr
* expr2
,
4629 tree wheremask
, bool invert
,
4630 forall_info
* nested_forall_info
,
4631 stmtblock_t
* block
)
4639 stmtblock_t inner_size_body
;
4641 /* Create vars. count1 is the current iterator number of the nested
4643 count1
= gfc_create_var (gfc_array_index_type
, "count1");
4645 /* Count is the wheremask index. */
4648 count
= gfc_create_var (gfc_array_index_type
, "count");
4649 gfc_add_modify (block
, count
, gfc_index_zero_node
);
4654 /* Initialize count1. */
4655 gfc_add_modify (block
, count1
, gfc_index_zero_node
);
4657 /* Calculate the size of temporary needed in the assignment. Return loop, lss
4658 and rss which are used in function generate_loop_for_rhs_to_temp(). */
4659 /* The type of LHS. Used in function allocate_temp_for_forall_nest */
4660 if (expr1
->ts
.type
== BT_CHARACTER
)
4663 if (expr1
->ref
&& expr1
->ref
->type
== REF_SUBSTRING
)
4666 gfc_init_se (&ssse
, NULL
);
4667 gfc_conv_expr (&ssse
, expr1
);
4668 type
= gfc_get_character_type_len (gfc_default_character_kind
,
4669 ssse
.string_length
);
4673 if (!expr1
->ts
.u
.cl
->backend_decl
)
4676 gcc_assert (expr1
->ts
.u
.cl
->length
);
4677 gfc_init_se (&tse
, NULL
);
4678 gfc_conv_expr (&tse
, expr1
->ts
.u
.cl
->length
);
4679 expr1
->ts
.u
.cl
->backend_decl
= tse
.expr
;
4681 type
= gfc_get_character_type_len (gfc_default_character_kind
,
4682 expr1
->ts
.u
.cl
->backend_decl
);
4686 type
= gfc_typenode_for_spec (&expr1
->ts
);
4688 gfc_init_block (&inner_size_body
);
4689 inner_size
= compute_inner_temp_size (expr1
, expr2
, &inner_size_body
,
4692 /* Allocate temporary for nested forall construct according to the
4693 information in nested_forall_info and inner_size. */
4694 tmp1
= allocate_temp_for_forall_nest (nested_forall_info
, type
, inner_size
,
4695 &inner_size_body
, block
, &ptemp1
);
4697 /* Generate codes to copy rhs to the temporary . */
4698 tmp
= generate_loop_for_rhs_to_temp (expr2
, tmp1
, count
, count1
, lss
, rss
,
4701 /* Generate body and loops according to the information in
4702 nested_forall_info. */
4703 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, tmp
, 1);
4704 gfc_add_expr_to_block (block
, tmp
);
4707 gfc_add_modify (block
, count1
, gfc_index_zero_node
);
4711 gfc_add_modify (block
, count
, gfc_index_zero_node
);
4713 /* TODO: Second call to compute_inner_temp_size to initialize lss and
4714 rss; there must be a better way. */
4715 inner_size
= compute_inner_temp_size (expr1
, expr2
, &inner_size_body
,
4718 /* Generate codes to copy the temporary to lhs. */
4719 tmp
= generate_loop_for_temp_to_lhs (expr1
, tmp1
, count
, count1
,
4723 /* Generate body and loops according to the information in
4724 nested_forall_info. */
4725 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, tmp
, 1);
4726 gfc_add_expr_to_block (block
, tmp
);
4730 /* Free the temporary. */
4731 tmp
= gfc_call_free (ptemp1
);
4732 gfc_add_expr_to_block (block
, tmp
);
4737 /* Translate pointer assignment inside FORALL which need temporary. */
4740 gfc_trans_pointer_assign_need_temp (gfc_expr
* expr1
, gfc_expr
* expr2
,
4741 forall_info
* nested_forall_info
,
4742 stmtblock_t
* block
)
4749 gfc_array_info
*info
;
4756 tree tmp
, tmp1
, ptemp1
;
4758 count
= gfc_create_var (gfc_array_index_type
, "count");
4759 gfc_add_modify (block
, count
, gfc_index_zero_node
);
4761 inner_size
= gfc_index_one_node
;
4762 lss
= gfc_walk_expr (expr1
);
4763 rss
= gfc_walk_expr (expr2
);
4764 if (lss
== gfc_ss_terminator
)
4766 type
= gfc_typenode_for_spec (&expr1
->ts
);
4767 type
= build_pointer_type (type
);
4769 /* Allocate temporary for nested forall construct according to the
4770 information in nested_forall_info and inner_size. */
4771 tmp1
= allocate_temp_for_forall_nest (nested_forall_info
, type
,
4772 inner_size
, NULL
, block
, &ptemp1
);
4773 gfc_start_block (&body
);
4774 gfc_init_se (&lse
, NULL
);
4775 lse
.expr
= gfc_build_array_ref (tmp1
, count
, NULL
);
4776 gfc_init_se (&rse
, NULL
);
4777 rse
.want_pointer
= 1;
4778 gfc_conv_expr (&rse
, expr2
);
4779 gfc_add_block_to_block (&body
, &rse
.pre
);
4780 gfc_add_modify (&body
, lse
.expr
,
4781 fold_convert (TREE_TYPE (lse
.expr
), rse
.expr
));
4782 gfc_add_block_to_block (&body
, &rse
.post
);
4784 /* Increment count. */
4785 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
4786 count
, gfc_index_one_node
);
4787 gfc_add_modify (&body
, count
, tmp
);
4789 tmp
= gfc_finish_block (&body
);
4791 /* Generate body and loops according to the information in
4792 nested_forall_info. */
4793 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, tmp
, 1);
4794 gfc_add_expr_to_block (block
, tmp
);
4797 gfc_add_modify (block
, count
, gfc_index_zero_node
);
4799 gfc_start_block (&body
);
4800 gfc_init_se (&lse
, NULL
);
4801 gfc_init_se (&rse
, NULL
);
4802 rse
.expr
= gfc_build_array_ref (tmp1
, count
, NULL
);
4803 lse
.want_pointer
= 1;
4804 gfc_conv_expr (&lse
, expr1
);
4805 gfc_add_block_to_block (&body
, &lse
.pre
);
4806 gfc_add_modify (&body
, lse
.expr
, rse
.expr
);
4807 gfc_add_block_to_block (&body
, &lse
.post
);
4808 /* Increment count. */
4809 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
4810 count
, gfc_index_one_node
);
4811 gfc_add_modify (&body
, count
, tmp
);
4812 tmp
= gfc_finish_block (&body
);
4814 /* Generate body and loops according to the information in
4815 nested_forall_info. */
4816 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, tmp
, 1);
4817 gfc_add_expr_to_block (block
, tmp
);
4821 gfc_init_loopinfo (&loop
);
4823 /* Associate the SS with the loop. */
4824 gfc_add_ss_to_loop (&loop
, rss
);
4826 /* Setup the scalarizing loops and bounds. */
4827 gfc_conv_ss_startstride (&loop
);
4829 gfc_conv_loop_setup (&loop
, &expr2
->where
);
4831 info
= &rss
->info
->data
.array
;
4832 desc
= info
->descriptor
;
4834 /* Make a new descriptor. */
4835 parmtype
= gfc_get_element_type (TREE_TYPE (desc
));
4836 parmtype
= gfc_get_array_type_bounds (parmtype
, loop
.dimen
, 0,
4837 loop
.from
, loop
.to
, 1,
4838 GFC_ARRAY_UNKNOWN
, true);
4840 /* Allocate temporary for nested forall construct. */
4841 tmp1
= allocate_temp_for_forall_nest (nested_forall_info
, parmtype
,
4842 inner_size
, NULL
, block
, &ptemp1
);
4843 gfc_start_block (&body
);
4844 gfc_init_se (&lse
, NULL
);
4845 lse
.expr
= gfc_build_array_ref (tmp1
, count
, NULL
);
4846 lse
.direct_byref
= 1;
4847 gfc_conv_expr_descriptor (&lse
, expr2
);
4849 gfc_add_block_to_block (&body
, &lse
.pre
);
4850 gfc_add_block_to_block (&body
, &lse
.post
);
4852 /* Increment count. */
4853 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
4854 count
, gfc_index_one_node
);
4855 gfc_add_modify (&body
, count
, tmp
);
4857 tmp
= gfc_finish_block (&body
);
4859 /* Generate body and loops according to the information in
4860 nested_forall_info. */
4861 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, tmp
, 1);
4862 gfc_add_expr_to_block (block
, tmp
);
4865 gfc_add_modify (block
, count
, gfc_index_zero_node
);
4867 parm
= gfc_build_array_ref (tmp1
, count
, NULL
);
4868 gfc_init_se (&lse
, NULL
);
4869 gfc_conv_expr_descriptor (&lse
, expr1
);
4870 gfc_add_modify (&lse
.pre
, lse
.expr
, parm
);
4871 gfc_start_block (&body
);
4872 gfc_add_block_to_block (&body
, &lse
.pre
);
4873 gfc_add_block_to_block (&body
, &lse
.post
);
4875 /* Increment count. */
4876 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
4877 count
, gfc_index_one_node
);
4878 gfc_add_modify (&body
, count
, tmp
);
4880 tmp
= gfc_finish_block (&body
);
4882 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, tmp
, 1);
4883 gfc_add_expr_to_block (block
, tmp
);
4885 /* Free the temporary. */
4888 tmp
= gfc_call_free (ptemp1
);
4889 gfc_add_expr_to_block (block
, tmp
);
4894 /* FORALL and WHERE statements are really nasty, especially when you nest
4895 them. All the rhs of a forall assignment must be evaluated before the
4896 actual assignments are performed. Presumably this also applies to all the
4897 assignments in an inner where statement. */
4899 /* Generate code for a FORALL statement. Any temporaries are allocated as a
4900 linear array, relying on the fact that we process in the same order in all
4903 forall (i=start:end:stride; maskexpr)
4907 (where e,f,g,h<i> are arbitrary expressions possibly involving i)
4909 count = ((end + 1 - start) / stride)
4910 masktmp(:) = maskexpr(:)
4913 for (i = start; i <= end; i += stride)
4915 if (masktmp[maskindex++])
4919 for (i = start; i <= end; i += stride)
4921 if (masktmp[maskindex++])
4925 Note that this code only works when there are no dependencies.
4926 Forall loop with array assignments and data dependencies are a real pain,
4927 because the size of the temporary cannot always be determined before the
4928 loop is executed. This problem is compounded by the presence of nested
4933 gfc_trans_forall_1 (gfc_code
* code
, forall_info
* nested_forall_info
)
4950 tree cycle_label
= NULL_TREE
;
4954 gfc_forall_iterator
*fa
;
4957 gfc_saved_var
*saved_vars
;
4958 iter_info
*this_forall
;
4962 /* Do nothing if the mask is false. */
4964 && code
->expr1
->expr_type
== EXPR_CONSTANT
4965 && !code
->expr1
->value
.logical
)
4966 return build_empty_stmt (input_location
);
4969 /* Count the FORALL index number. */
4970 for (fa
= code
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
4974 /* Allocate the space for var, start, end, step, varexpr. */
4975 var
= XCNEWVEC (tree
, nvar
);
4976 start
= XCNEWVEC (tree
, nvar
);
4977 end
= XCNEWVEC (tree
, nvar
);
4978 step
= XCNEWVEC (tree
, nvar
);
4979 varexpr
= XCNEWVEC (gfc_expr
*, nvar
);
4980 saved_vars
= XCNEWVEC (gfc_saved_var
, nvar
);
4982 /* Allocate the space for info. */
4983 info
= XCNEW (forall_info
);
4985 gfc_start_block (&pre
);
4986 gfc_init_block (&post
);
4987 gfc_init_block (&block
);
4990 for (fa
= code
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
4992 gfc_symbol
*sym
= fa
->var
->symtree
->n
.sym
;
4994 /* Allocate space for this_forall. */
4995 this_forall
= XCNEW (iter_info
);
4997 /* Create a temporary variable for the FORALL index. */
4998 tmp
= gfc_typenode_for_spec (&sym
->ts
);
4999 var
[n
] = gfc_create_var (tmp
, sym
->name
);
5000 gfc_shadow_sym (sym
, var
[n
], &saved_vars
[n
]);
5002 /* Record it in this_forall. */
5003 this_forall
->var
= var
[n
];
5005 /* Replace the index symbol's backend_decl with the temporary decl. */
5006 sym
->backend_decl
= var
[n
];
5008 /* Work out the start, end and stride for the loop. */
5009 gfc_init_se (&se
, NULL
);
5010 gfc_conv_expr_val (&se
, fa
->start
);
5011 /* Record it in this_forall. */
5012 this_forall
->start
= se
.expr
;
5013 gfc_add_block_to_block (&block
, &se
.pre
);
5016 gfc_init_se (&se
, NULL
);
5017 gfc_conv_expr_val (&se
, fa
->end
);
5018 /* Record it in this_forall. */
5019 this_forall
->end
= se
.expr
;
5020 gfc_make_safe_expr (&se
);
5021 gfc_add_block_to_block (&block
, &se
.pre
);
5024 gfc_init_se (&se
, NULL
);
5025 gfc_conv_expr_val (&se
, fa
->stride
);
5026 /* Record it in this_forall. */
5027 this_forall
->step
= se
.expr
;
5028 gfc_make_safe_expr (&se
);
5029 gfc_add_block_to_block (&block
, &se
.pre
);
5032 /* Set the NEXT field of this_forall to NULL. */
5033 this_forall
->next
= NULL
;
5034 /* Link this_forall to the info construct. */
5035 if (info
->this_loop
)
5037 iter_info
*iter_tmp
= info
->this_loop
;
5038 while (iter_tmp
->next
!= NULL
)
5039 iter_tmp
= iter_tmp
->next
;
5040 iter_tmp
->next
= this_forall
;
5043 info
->this_loop
= this_forall
;
5049 /* Calculate the size needed for the current forall level. */
5050 size
= gfc_index_one_node
;
5051 for (n
= 0; n
< nvar
; n
++)
5053 /* size = (end + step - start) / step. */
5054 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (start
[n
]),
5056 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (end
[n
]),
5058 tmp
= fold_build2_loc (input_location
, FLOOR_DIV_EXPR
, TREE_TYPE (tmp
),
5060 tmp
= convert (gfc_array_index_type
, tmp
);
5062 size
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
5066 /* Record the nvar and size of current forall level. */
5072 /* If the mask is .true., consider the FORALL unconditional. */
5073 if (code
->expr1
->expr_type
== EXPR_CONSTANT
5074 && code
->expr1
->value
.logical
)
5082 /* First we need to allocate the mask. */
5085 /* As the mask array can be very big, prefer compact boolean types. */
5086 tree mask_type
= gfc_get_logical_type (gfc_logical_kinds
[0].kind
);
5087 mask
= allocate_temp_for_forall_nest (nested_forall_info
, mask_type
,
5088 size
, NULL
, &block
, &pmask
);
5089 maskindex
= gfc_create_var_np (gfc_array_index_type
, "mi");
5091 /* Record them in the info structure. */
5092 info
->maskindex
= maskindex
;
5097 /* No mask was specified. */
5098 maskindex
= NULL_TREE
;
5099 mask
= pmask
= NULL_TREE
;
5102 /* Link the current forall level to nested_forall_info. */
5103 info
->prev_nest
= nested_forall_info
;
5104 nested_forall_info
= info
;
5106 /* Copy the mask into a temporary variable if required.
5107 For now we assume a mask temporary is needed. */
5110 /* As the mask array can be very big, prefer compact boolean types. */
5111 tree mask_type
= gfc_get_logical_type (gfc_logical_kinds
[0].kind
);
5113 gfc_add_modify (&block
, maskindex
, gfc_index_zero_node
);
5115 /* Start of mask assignment loop body. */
5116 gfc_start_block (&body
);
5118 /* Evaluate the mask expression. */
5119 gfc_init_se (&se
, NULL
);
5120 gfc_conv_expr_val (&se
, code
->expr1
);
5121 gfc_add_block_to_block (&body
, &se
.pre
);
5123 /* Store the mask. */
5124 se
.expr
= convert (mask_type
, se
.expr
);
5126 tmp
= gfc_build_array_ref (mask
, maskindex
, NULL
);
5127 gfc_add_modify (&body
, tmp
, se
.expr
);
5129 /* Advance to the next mask element. */
5130 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
5131 maskindex
, gfc_index_one_node
);
5132 gfc_add_modify (&body
, maskindex
, tmp
);
5134 /* Generate the loops. */
5135 tmp
= gfc_finish_block (&body
);
5136 tmp
= gfc_trans_nested_forall_loop (info
, tmp
, 0);
5137 gfc_add_expr_to_block (&block
, tmp
);
5140 if (code
->op
== EXEC_DO_CONCURRENT
)
5142 gfc_init_block (&body
);
5143 cycle_label
= gfc_build_label_decl (NULL_TREE
);
5144 code
->cycle_label
= cycle_label
;
5145 tmp
= gfc_trans_code (code
->block
->next
);
5146 gfc_add_expr_to_block (&body
, tmp
);
5148 if (TREE_USED (cycle_label
))
5150 tmp
= build1_v (LABEL_EXPR
, cycle_label
);
5151 gfc_add_expr_to_block (&body
, tmp
);
5154 tmp
= gfc_finish_block (&body
);
5155 nested_forall_info
->do_concurrent
= true;
5156 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, tmp
, 1);
5157 gfc_add_expr_to_block (&block
, tmp
);
5161 c
= code
->block
->next
;
5163 /* TODO: loop merging in FORALL statements. */
5164 /* Now that we've got a copy of the mask, generate the assignment loops. */
5170 /* A scalar or array assignment. DO the simple check for
5171 lhs to rhs dependencies. These make a temporary for the
5172 rhs and form a second forall block to copy to variable. */
5173 need_temp
= check_forall_dependencies(c
, &pre
, &post
);
5175 /* Temporaries due to array assignment data dependencies introduce
5176 no end of problems. */
5177 if (need_temp
|| flag_test_forall_temp
)
5178 gfc_trans_assign_need_temp (c
->expr1
, c
->expr2
, NULL
, false,
5179 nested_forall_info
, &block
);
5182 /* Use the normal assignment copying routines. */
5183 assign
= gfc_trans_assignment (c
->expr1
, c
->expr2
, false, true);
5185 /* Generate body and loops. */
5186 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
,
5188 gfc_add_expr_to_block (&block
, tmp
);
5191 /* Cleanup any temporary symtrees that have been made to deal
5192 with dependencies. */
5194 cleanup_forall_symtrees (c
);
5199 /* Translate WHERE or WHERE construct nested in FORALL. */
5200 gfc_trans_where_2 (c
, NULL
, false, nested_forall_info
, &block
);
5203 /* Pointer assignment inside FORALL. */
5204 case EXEC_POINTER_ASSIGN
:
5205 need_temp
= gfc_check_dependency (c
->expr1
, c
->expr2
, 0);
5206 /* Avoid cases where a temporary would never be needed and where
5207 the temp code is guaranteed to fail. */
5209 || (flag_test_forall_temp
5210 && c
->expr2
->expr_type
!= EXPR_CONSTANT
5211 && c
->expr2
->expr_type
!= EXPR_NULL
))
5212 gfc_trans_pointer_assign_need_temp (c
->expr1
, c
->expr2
,
5213 nested_forall_info
, &block
);
5216 /* Use the normal assignment copying routines. */
5217 assign
= gfc_trans_pointer_assignment (c
->expr1
, c
->expr2
);
5219 /* Generate body and loops. */
5220 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
,
5222 gfc_add_expr_to_block (&block
, tmp
);
5227 tmp
= gfc_trans_forall_1 (c
, nested_forall_info
);
5228 gfc_add_expr_to_block (&block
, tmp
);
5231 /* Explicit subroutine calls are prevented by the frontend but interface
5232 assignments can legitimately produce them. */
5233 case EXEC_ASSIGN_CALL
:
5234 assign
= gfc_trans_call (c
, true, NULL_TREE
, NULL_TREE
, false);
5235 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, assign
, 1);
5236 gfc_add_expr_to_block (&block
, tmp
);
5247 /* Restore the original index variables. */
5248 for (fa
= code
->ext
.forall_iterator
, n
= 0; fa
; fa
= fa
->next
, n
++)
5249 gfc_restore_sym (fa
->var
->symtree
->n
.sym
, &saved_vars
[n
]);
5251 /* Free the space for var, start, end, step, varexpr. */
5259 for (this_forall
= info
->this_loop
; this_forall
;)
5261 iter_info
*next
= this_forall
->next
;
5266 /* Free the space for this forall_info. */
5271 /* Free the temporary for the mask. */
5272 tmp
= gfc_call_free (pmask
);
5273 gfc_add_expr_to_block (&block
, tmp
);
5276 pushdecl (maskindex
);
5278 gfc_add_block_to_block (&pre
, &block
);
5279 gfc_add_block_to_block (&pre
, &post
);
5281 return gfc_finish_block (&pre
);
5285 /* Translate the FORALL statement or construct. */
5287 tree
gfc_trans_forall (gfc_code
* code
)
5289 return gfc_trans_forall_1 (code
, NULL
);
5293 /* Translate the DO CONCURRENT construct. */
5295 tree
gfc_trans_do_concurrent (gfc_code
* code
)
5297 return gfc_trans_forall_1 (code
, NULL
);
5301 /* Evaluate the WHERE mask expression, copy its value to a temporary.
5302 If the WHERE construct is nested in FORALL, compute the overall temporary
5303 needed by the WHERE mask expression multiplied by the iterator number of
5305 ME is the WHERE mask expression.
5306 MASK is the current execution mask upon input, whose sense may or may
5307 not be inverted as specified by the INVERT argument.
5308 CMASK is the updated execution mask on output, or NULL if not required.
5309 PMASK is the pending execution mask on output, or NULL if not required.
5310 BLOCK is the block in which to place the condition evaluation loops. */
5313 gfc_evaluate_where_mask (gfc_expr
* me
, forall_info
* nested_forall_info
,
5314 tree mask
, bool invert
, tree cmask
, tree pmask
,
5315 tree mask_type
, stmtblock_t
* block
)
5320 stmtblock_t body
, body1
;
5321 tree count
, cond
, mtmp
;
5324 gfc_init_loopinfo (&loop
);
5326 lss
= gfc_walk_expr (me
);
5327 rss
= gfc_walk_expr (me
);
5329 /* Variable to index the temporary. */
5330 count
= gfc_create_var (gfc_array_index_type
, "count");
5331 /* Initialize count. */
5332 gfc_add_modify (block
, count
, gfc_index_zero_node
);
5334 gfc_start_block (&body
);
5336 gfc_init_se (&rse
, NULL
);
5337 gfc_init_se (&lse
, NULL
);
5339 if (lss
== gfc_ss_terminator
)
5341 gfc_init_block (&body1
);
5345 /* Initialize the loop. */
5346 gfc_init_loopinfo (&loop
);
5348 /* We may need LSS to determine the shape of the expression. */
5349 gfc_add_ss_to_loop (&loop
, lss
);
5350 gfc_add_ss_to_loop (&loop
, rss
);
5352 gfc_conv_ss_startstride (&loop
);
5353 gfc_conv_loop_setup (&loop
, &me
->where
);
5355 gfc_mark_ss_chain_used (rss
, 1);
5356 /* Start the loop body. */
5357 gfc_start_scalarized_body (&loop
, &body1
);
5359 /* Translate the expression. */
5360 gfc_copy_loopinfo_to_se (&rse
, &loop
);
5362 gfc_conv_expr (&rse
, me
);
5365 /* Variable to evaluate mask condition. */
5366 cond
= gfc_create_var (mask_type
, "cond");
5367 if (mask
&& (cmask
|| pmask
))
5368 mtmp
= gfc_create_var (mask_type
, "mask");
5369 else mtmp
= NULL_TREE
;
5371 gfc_add_block_to_block (&body1
, &lse
.pre
);
5372 gfc_add_block_to_block (&body1
, &rse
.pre
);
5374 gfc_add_modify (&body1
, cond
, fold_convert (mask_type
, rse
.expr
));
5376 if (mask
&& (cmask
|| pmask
))
5378 tmp
= gfc_build_array_ref (mask
, count
, NULL
);
5380 tmp
= fold_build1_loc (input_location
, TRUTH_NOT_EXPR
, mask_type
, tmp
);
5381 gfc_add_modify (&body1
, mtmp
, tmp
);
5386 tmp1
= gfc_build_array_ref (cmask
, count
, NULL
);
5389 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
, mask_type
,
5391 gfc_add_modify (&body1
, tmp1
, tmp
);
5396 tmp1
= gfc_build_array_ref (pmask
, count
, NULL
);
5397 tmp
= fold_build1_loc (input_location
, TRUTH_NOT_EXPR
, mask_type
, cond
);
5399 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
, mask_type
, mtmp
,
5401 gfc_add_modify (&body1
, tmp1
, tmp
);
5404 gfc_add_block_to_block (&body1
, &lse
.post
);
5405 gfc_add_block_to_block (&body1
, &rse
.post
);
5407 if (lss
== gfc_ss_terminator
)
5409 gfc_add_block_to_block (&body
, &body1
);
5413 /* Increment count. */
5414 tmp1
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
5415 count
, gfc_index_one_node
);
5416 gfc_add_modify (&body1
, count
, tmp1
);
5418 /* Generate the copying loops. */
5419 gfc_trans_scalarizing_loops (&loop
, &body1
);
5421 gfc_add_block_to_block (&body
, &loop
.pre
);
5422 gfc_add_block_to_block (&body
, &loop
.post
);
5424 gfc_cleanup_loop (&loop
);
5425 /* TODO: Reuse lss and rss when copying temp->lhs. Need to be careful
5426 as tree nodes in SS may not be valid in different scope. */
5429 tmp1
= gfc_finish_block (&body
);
5430 /* If the WHERE construct is inside FORALL, fill the full temporary. */
5431 if (nested_forall_info
!= NULL
)
5432 tmp1
= gfc_trans_nested_forall_loop (nested_forall_info
, tmp1
, 1);
5434 gfc_add_expr_to_block (block
, tmp1
);
5438 /* Translate an assignment statement in a WHERE statement or construct
5439 statement. The MASK expression is used to control which elements
5440 of EXPR1 shall be assigned. The sense of MASK is specified by
5444 gfc_trans_where_assign (gfc_expr
*expr1
, gfc_expr
*expr2
,
5445 tree mask
, bool invert
,
5446 tree count1
, tree count2
,
5452 gfc_ss
*lss_section
;
5459 tree index
, maskexpr
;
5461 /* A defined assignment. */
5462 if (cnext
&& cnext
->resolved_sym
)
5463 return gfc_trans_call (cnext
, true, mask
, count1
, invert
);
5466 /* TODO: handle this special case.
5467 Special case a single function returning an array. */
5468 if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->rank
> 0)
5470 tmp
= gfc_trans_arrayfunc_assign (expr1
, expr2
);
5476 /* Assignment of the form lhs = rhs. */
5477 gfc_start_block (&block
);
5479 gfc_init_se (&lse
, NULL
);
5480 gfc_init_se (&rse
, NULL
);
5483 lss
= gfc_walk_expr (expr1
);
5486 /* In each where-assign-stmt, the mask-expr and the variable being
5487 defined shall be arrays of the same shape. */
5488 gcc_assert (lss
!= gfc_ss_terminator
);
5490 /* The assignment needs scalarization. */
5493 /* Find a non-scalar SS from the lhs. */
5494 while (lss_section
!= gfc_ss_terminator
5495 && lss_section
->info
->type
!= GFC_SS_SECTION
)
5496 lss_section
= lss_section
->next
;
5498 gcc_assert (lss_section
!= gfc_ss_terminator
);
5500 /* Initialize the scalarizer. */
5501 gfc_init_loopinfo (&loop
);
5504 rss
= gfc_walk_expr (expr2
);
5505 if (rss
== gfc_ss_terminator
)
5507 /* The rhs is scalar. Add a ss for the expression. */
5508 rss
= gfc_get_scalar_ss (gfc_ss_terminator
, expr2
);
5509 rss
->info
->where
= 1;
5512 /* Associate the SS with the loop. */
5513 gfc_add_ss_to_loop (&loop
, lss
);
5514 gfc_add_ss_to_loop (&loop
, rss
);
5516 /* Calculate the bounds of the scalarization. */
5517 gfc_conv_ss_startstride (&loop
);
5519 /* Resolve any data dependencies in the statement. */
5520 gfc_conv_resolve_dependencies (&loop
, lss_section
, rss
);
5522 /* Setup the scalarizing loops. */
5523 gfc_conv_loop_setup (&loop
, &expr2
->where
);
5525 /* Setup the gfc_se structures. */
5526 gfc_copy_loopinfo_to_se (&lse
, &loop
);
5527 gfc_copy_loopinfo_to_se (&rse
, &loop
);
5530 gfc_mark_ss_chain_used (rss
, 1);
5531 if (loop
.temp_ss
== NULL
)
5534 gfc_mark_ss_chain_used (lss
, 1);
5538 lse
.ss
= loop
.temp_ss
;
5539 gfc_mark_ss_chain_used (lss
, 3);
5540 gfc_mark_ss_chain_used (loop
.temp_ss
, 3);
5543 /* Start the scalarized loop body. */
5544 gfc_start_scalarized_body (&loop
, &body
);
5546 /* Translate the expression. */
5547 gfc_conv_expr (&rse
, expr2
);
5548 if (lss
!= gfc_ss_terminator
&& loop
.temp_ss
!= NULL
)
5549 gfc_conv_tmp_array_ref (&lse
);
5551 gfc_conv_expr (&lse
, expr1
);
5553 /* Form the mask expression according to the mask. */
5555 maskexpr
= gfc_build_array_ref (mask
, index
, NULL
);
5557 maskexpr
= fold_build1_loc (input_location
, TRUTH_NOT_EXPR
,
5558 TREE_TYPE (maskexpr
), maskexpr
);
5560 /* Use the scalar assignment as is. */
5561 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
,
5562 false, loop
.temp_ss
== NULL
);
5564 tmp
= build3_v (COND_EXPR
, maskexpr
, tmp
, build_empty_stmt (input_location
));
5566 gfc_add_expr_to_block (&body
, tmp
);
5568 if (lss
== gfc_ss_terminator
)
5570 /* Increment count1. */
5571 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
5572 count1
, gfc_index_one_node
);
5573 gfc_add_modify (&body
, count1
, tmp
);
5575 /* Use the scalar assignment as is. */
5576 gfc_add_block_to_block (&block
, &body
);
5580 gcc_assert (lse
.ss
== gfc_ss_terminator
5581 && rse
.ss
== gfc_ss_terminator
);
5583 if (loop
.temp_ss
!= NULL
)
5585 /* Increment count1 before finish the main body of a scalarized
5587 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
5588 gfc_array_index_type
, count1
, gfc_index_one_node
);
5589 gfc_add_modify (&body
, count1
, tmp
);
5590 gfc_trans_scalarized_loop_boundary (&loop
, &body
);
5592 /* We need to copy the temporary to the actual lhs. */
5593 gfc_init_se (&lse
, NULL
);
5594 gfc_init_se (&rse
, NULL
);
5595 gfc_copy_loopinfo_to_se (&lse
, &loop
);
5596 gfc_copy_loopinfo_to_se (&rse
, &loop
);
5598 rse
.ss
= loop
.temp_ss
;
5601 gfc_conv_tmp_array_ref (&rse
);
5602 gfc_conv_expr (&lse
, expr1
);
5604 gcc_assert (lse
.ss
== gfc_ss_terminator
5605 && rse
.ss
== gfc_ss_terminator
);
5607 /* Form the mask expression according to the mask tree list. */
5609 maskexpr
= gfc_build_array_ref (mask
, index
, NULL
);
5611 maskexpr
= fold_build1_loc (input_location
, TRUTH_NOT_EXPR
,
5612 TREE_TYPE (maskexpr
), maskexpr
);
5614 /* Use the scalar assignment as is. */
5615 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
, false, true);
5616 tmp
= build3_v (COND_EXPR
, maskexpr
, tmp
,
5617 build_empty_stmt (input_location
));
5618 gfc_add_expr_to_block (&body
, tmp
);
5620 /* Increment count2. */
5621 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
5622 gfc_array_index_type
, count2
,
5623 gfc_index_one_node
);
5624 gfc_add_modify (&body
, count2
, tmp
);
5628 /* Increment count1. */
5629 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
5630 gfc_array_index_type
, count1
,
5631 gfc_index_one_node
);
5632 gfc_add_modify (&body
, count1
, tmp
);
5635 /* Generate the copying loops. */
5636 gfc_trans_scalarizing_loops (&loop
, &body
);
5638 /* Wrap the whole thing up. */
5639 gfc_add_block_to_block (&block
, &loop
.pre
);
5640 gfc_add_block_to_block (&block
, &loop
.post
);
5641 gfc_cleanup_loop (&loop
);
5644 return gfc_finish_block (&block
);
5648 /* Translate the WHERE construct or statement.
5649 This function can be called iteratively to translate the nested WHERE
5650 construct or statement.
5651 MASK is the control mask. */
5654 gfc_trans_where_2 (gfc_code
* code
, tree mask
, bool invert
,
5655 forall_info
* nested_forall_info
, stmtblock_t
* block
)
5657 stmtblock_t inner_size_body
;
5658 tree inner_size
, size
;
5667 tree count1
, count2
;
5671 tree pcmask
= NULL_TREE
;
5672 tree ppmask
= NULL_TREE
;
5673 tree cmask
= NULL_TREE
;
5674 tree pmask
= NULL_TREE
;
5675 gfc_actual_arglist
*arg
;
5677 /* the WHERE statement or the WHERE construct statement. */
5678 cblock
= code
->block
;
5680 /* As the mask array can be very big, prefer compact boolean types. */
5681 mask_type
= gfc_get_logical_type (gfc_logical_kinds
[0].kind
);
5683 /* Determine which temporary masks are needed. */
5686 /* One clause: No ELSEWHEREs. */
5687 need_cmask
= (cblock
->next
!= 0);
5690 else if (cblock
->block
->block
)
5692 /* Three or more clauses: Conditional ELSEWHEREs. */
5696 else if (cblock
->next
)
5698 /* Two clauses, the first non-empty. */
5700 need_pmask
= (mask
!= NULL_TREE
5701 && cblock
->block
->next
!= 0);
5703 else if (!cblock
->block
->next
)
5705 /* Two clauses, both empty. */
5709 /* Two clauses, the first empty, the second non-empty. */
5712 need_cmask
= (cblock
->block
->expr1
!= 0);
5721 if (need_cmask
|| need_pmask
)
5723 /* Calculate the size of temporary needed by the mask-expr. */
5724 gfc_init_block (&inner_size_body
);
5725 inner_size
= compute_inner_temp_size (cblock
->expr1
, cblock
->expr1
,
5726 &inner_size_body
, &lss
, &rss
);
5728 gfc_free_ss_chain (lss
);
5729 gfc_free_ss_chain (rss
);
5731 /* Calculate the total size of temporary needed. */
5732 size
= compute_overall_iter_number (nested_forall_info
, inner_size
,
5733 &inner_size_body
, block
);
5735 /* Check whether the size is negative. */
5736 cond
= fold_build2_loc (input_location
, LE_EXPR
, logical_type_node
, size
,
5737 gfc_index_zero_node
);
5738 size
= fold_build3_loc (input_location
, COND_EXPR
, gfc_array_index_type
,
5739 cond
, gfc_index_zero_node
, size
);
5740 size
= gfc_evaluate_now (size
, block
);
5742 /* Allocate temporary for WHERE mask if needed. */
5744 cmask
= allocate_temp_for_forall_nest_1 (mask_type
, size
, block
,
5747 /* Allocate temporary for !mask if needed. */
5749 pmask
= allocate_temp_for_forall_nest_1 (mask_type
, size
, block
,
5755 /* Each time around this loop, the where clause is conditional
5756 on the value of mask and invert, which are updated at the
5757 bottom of the loop. */
5759 /* Has mask-expr. */
5762 /* Ensure that the WHERE mask will be evaluated exactly once.
5763 If there are no statements in this WHERE/ELSEWHERE clause,
5764 then we don't need to update the control mask (cmask).
5765 If this is the last clause of the WHERE construct, then
5766 we don't need to update the pending control mask (pmask). */
5768 gfc_evaluate_where_mask (cblock
->expr1
, nested_forall_info
,
5770 cblock
->next
? cmask
: NULL_TREE
,
5771 cblock
->block
? pmask
: NULL_TREE
,
5774 gfc_evaluate_where_mask (cblock
->expr1
, nested_forall_info
,
5776 (cblock
->next
|| cblock
->block
)
5777 ? cmask
: NULL_TREE
,
5778 NULL_TREE
, mask_type
, block
);
5782 /* It's a final elsewhere-stmt. No mask-expr is present. */
5786 /* The body of this where clause are controlled by cmask with
5787 sense specified by invert. */
5789 /* Get the assignment statement of a WHERE statement, or the first
5790 statement in where-body-construct of a WHERE construct. */
5791 cnext
= cblock
->next
;
5796 /* WHERE assignment statement. */
5797 case EXEC_ASSIGN_CALL
:
5799 arg
= cnext
->ext
.actual
;
5800 expr1
= expr2
= NULL
;
5801 for (; arg
; arg
= arg
->next
)
5813 expr1
= cnext
->expr1
;
5814 expr2
= cnext
->expr2
;
5816 if (nested_forall_info
!= NULL
)
5818 need_temp
= gfc_check_dependency (expr1
, expr2
, 0);
5819 if ((need_temp
|| flag_test_forall_temp
)
5820 && cnext
->op
!= EXEC_ASSIGN_CALL
)
5821 gfc_trans_assign_need_temp (expr1
, expr2
,
5823 nested_forall_info
, block
);
5826 /* Variables to control maskexpr. */
5827 count1
= gfc_create_var (gfc_array_index_type
, "count1");
5828 count2
= gfc_create_var (gfc_array_index_type
, "count2");
5829 gfc_add_modify (block
, count1
, gfc_index_zero_node
);
5830 gfc_add_modify (block
, count2
, gfc_index_zero_node
);
5832 tmp
= gfc_trans_where_assign (expr1
, expr2
,
5837 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
,
5839 gfc_add_expr_to_block (block
, tmp
);
5844 /* Variables to control maskexpr. */
5845 count1
= gfc_create_var (gfc_array_index_type
, "count1");
5846 count2
= gfc_create_var (gfc_array_index_type
, "count2");
5847 gfc_add_modify (block
, count1
, gfc_index_zero_node
);
5848 gfc_add_modify (block
, count2
, gfc_index_zero_node
);
5850 tmp
= gfc_trans_where_assign (expr1
, expr2
,
5854 gfc_add_expr_to_block (block
, tmp
);
5859 /* WHERE or WHERE construct is part of a where-body-construct. */
5861 gfc_trans_where_2 (cnext
, cmask
, invert
,
5862 nested_forall_info
, block
);
5869 /* The next statement within the same where-body-construct. */
5870 cnext
= cnext
->next
;
5872 /* The next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt. */
5873 cblock
= cblock
->block
;
5874 if (mask
== NULL_TREE
)
5876 /* If we're the initial WHERE, we can simply invert the sense
5877 of the current mask to obtain the "mask" for the remaining
5884 /* Otherwise, for nested WHERE's we need to use the pending mask. */
5890 /* If we allocated a pending mask array, deallocate it now. */
5893 tmp
= gfc_call_free (ppmask
);
5894 gfc_add_expr_to_block (block
, tmp
);
5897 /* If we allocated a current mask array, deallocate it now. */
5900 tmp
= gfc_call_free (pcmask
);
5901 gfc_add_expr_to_block (block
, tmp
);
5905 /* Translate a simple WHERE construct or statement without dependencies.
5906 CBLOCK is the "then" clause of the WHERE statement, where CBLOCK->EXPR
5907 is the mask condition, and EBLOCK if non-NULL is the "else" clause.
5908 Currently both CBLOCK and EBLOCK are restricted to single assignments. */
5911 gfc_trans_where_3 (gfc_code
* cblock
, gfc_code
* eblock
)
5913 stmtblock_t block
, body
;
5914 gfc_expr
*cond
, *tdst
, *tsrc
, *edst
, *esrc
;
5915 tree tmp
, cexpr
, tstmt
, estmt
;
5916 gfc_ss
*css
, *tdss
, *tsss
;
5917 gfc_se cse
, tdse
, tsse
, edse
, esse
;
5921 bool maybe_workshare
= false;
5923 /* Allow the scalarizer to workshare simple where loops. */
5924 if ((ompws_flags
& (OMPWS_WORKSHARE_FLAG
| OMPWS_SCALARIZER_BODY
))
5925 == OMPWS_WORKSHARE_FLAG
)
5927 maybe_workshare
= true;
5928 ompws_flags
|= OMPWS_SCALARIZER_WS
| OMPWS_SCALARIZER_BODY
;
5931 cond
= cblock
->expr1
;
5932 tdst
= cblock
->next
->expr1
;
5933 tsrc
= cblock
->next
->expr2
;
5934 edst
= eblock
? eblock
->next
->expr1
: NULL
;
5935 esrc
= eblock
? eblock
->next
->expr2
: NULL
;
5937 gfc_start_block (&block
);
5938 gfc_init_loopinfo (&loop
);
5940 /* Handle the condition. */
5941 gfc_init_se (&cse
, NULL
);
5942 css
= gfc_walk_expr (cond
);
5943 gfc_add_ss_to_loop (&loop
, css
);
5945 /* Handle the then-clause. */
5946 gfc_init_se (&tdse
, NULL
);
5947 gfc_init_se (&tsse
, NULL
);
5948 tdss
= gfc_walk_expr (tdst
);
5949 tsss
= gfc_walk_expr (tsrc
);
5950 if (tsss
== gfc_ss_terminator
)
5952 tsss
= gfc_get_scalar_ss (gfc_ss_terminator
, tsrc
);
5953 tsss
->info
->where
= 1;
5955 gfc_add_ss_to_loop (&loop
, tdss
);
5956 gfc_add_ss_to_loop (&loop
, tsss
);
5960 /* Handle the else clause. */
5961 gfc_init_se (&edse
, NULL
);
5962 gfc_init_se (&esse
, NULL
);
5963 edss
= gfc_walk_expr (edst
);
5964 esss
= gfc_walk_expr (esrc
);
5965 if (esss
== gfc_ss_terminator
)
5967 esss
= gfc_get_scalar_ss (gfc_ss_terminator
, esrc
);
5968 esss
->info
->where
= 1;
5970 gfc_add_ss_to_loop (&loop
, edss
);
5971 gfc_add_ss_to_loop (&loop
, esss
);
5974 gfc_conv_ss_startstride (&loop
);
5975 gfc_conv_loop_setup (&loop
, &tdst
->where
);
5977 gfc_mark_ss_chain_used (css
, 1);
5978 gfc_mark_ss_chain_used (tdss
, 1);
5979 gfc_mark_ss_chain_used (tsss
, 1);
5982 gfc_mark_ss_chain_used (edss
, 1);
5983 gfc_mark_ss_chain_used (esss
, 1);
5986 gfc_start_scalarized_body (&loop
, &body
);
5988 gfc_copy_loopinfo_to_se (&cse
, &loop
);
5989 gfc_copy_loopinfo_to_se (&tdse
, &loop
);
5990 gfc_copy_loopinfo_to_se (&tsse
, &loop
);
5996 gfc_copy_loopinfo_to_se (&edse
, &loop
);
5997 gfc_copy_loopinfo_to_se (&esse
, &loop
);
6002 gfc_conv_expr (&cse
, cond
);
6003 gfc_add_block_to_block (&body
, &cse
.pre
);
6006 gfc_conv_expr (&tsse
, tsrc
);
6007 if (tdss
!= gfc_ss_terminator
&& loop
.temp_ss
!= NULL
)
6008 gfc_conv_tmp_array_ref (&tdse
);
6010 gfc_conv_expr (&tdse
, tdst
);
6014 gfc_conv_expr (&esse
, esrc
);
6015 if (edss
!= gfc_ss_terminator
&& loop
.temp_ss
!= NULL
)
6016 gfc_conv_tmp_array_ref (&edse
);
6018 gfc_conv_expr (&edse
, edst
);
6021 tstmt
= gfc_trans_scalar_assign (&tdse
, &tsse
, tdst
->ts
, false, true);
6022 estmt
= eblock
? gfc_trans_scalar_assign (&edse
, &esse
, edst
->ts
,
6024 : build_empty_stmt (input_location
);
6025 tmp
= build3_v (COND_EXPR
, cexpr
, tstmt
, estmt
);
6026 gfc_add_expr_to_block (&body
, tmp
);
6027 gfc_add_block_to_block (&body
, &cse
.post
);
6029 if (maybe_workshare
)
6030 ompws_flags
&= ~OMPWS_SCALARIZER_BODY
;
6031 gfc_trans_scalarizing_loops (&loop
, &body
);
6032 gfc_add_block_to_block (&block
, &loop
.pre
);
6033 gfc_add_block_to_block (&block
, &loop
.post
);
6034 gfc_cleanup_loop (&loop
);
6036 return gfc_finish_block (&block
);
6039 /* As the WHERE or WHERE construct statement can be nested, we call
6040 gfc_trans_where_2 to do the translation, and pass the initial
6041 NULL values for both the control mask and the pending control mask. */
6044 gfc_trans_where (gfc_code
* code
)
6050 cblock
= code
->block
;
6052 && cblock
->next
->op
== EXEC_ASSIGN
6053 && !cblock
->next
->next
)
6055 eblock
= cblock
->block
;
6058 /* A simple "WHERE (cond) x = y" statement or block is
6059 dependence free if cond is not dependent upon writing x,
6060 and the source y is unaffected by the destination x. */
6061 if (!gfc_check_dependency (cblock
->next
->expr1
,
6063 && !gfc_check_dependency (cblock
->next
->expr1
,
6064 cblock
->next
->expr2
, 0))
6065 return gfc_trans_where_3 (cblock
, NULL
);
6067 else if (!eblock
->expr1
6070 && eblock
->next
->op
== EXEC_ASSIGN
6071 && !eblock
->next
->next
)
6073 /* A simple "WHERE (cond) x1 = y1 ELSEWHERE x2 = y2 ENDWHERE"
6074 block is dependence free if cond is not dependent on writes
6075 to x1 and x2, y1 is not dependent on writes to x2, and y2
6076 is not dependent on writes to x1, and both y's are not
6077 dependent upon their own x's. In addition to this, the
6078 final two dependency checks below exclude all but the same
6079 array reference if the where and elswhere destinations
6080 are the same. In short, this is VERY conservative and this
6081 is needed because the two loops, required by the standard
6082 are coalesced in gfc_trans_where_3. */
6083 if (!gfc_check_dependency (cblock
->next
->expr1
,
6085 && !gfc_check_dependency (eblock
->next
->expr1
,
6087 && !gfc_check_dependency (cblock
->next
->expr1
,
6088 eblock
->next
->expr2
, 1)
6089 && !gfc_check_dependency (eblock
->next
->expr1
,
6090 cblock
->next
->expr2
, 1)
6091 && !gfc_check_dependency (cblock
->next
->expr1
,
6092 cblock
->next
->expr2
, 1)
6093 && !gfc_check_dependency (eblock
->next
->expr1
,
6094 eblock
->next
->expr2
, 1)
6095 && !gfc_check_dependency (cblock
->next
->expr1
,
6096 eblock
->next
->expr1
, 0)
6097 && !gfc_check_dependency (eblock
->next
->expr1
,
6098 cblock
->next
->expr1
, 0))
6099 return gfc_trans_where_3 (cblock
, eblock
);
6103 gfc_start_block (&block
);
6105 gfc_trans_where_2 (code
, NULL
, false, NULL
, &block
);
6107 return gfc_finish_block (&block
);
6111 /* CYCLE a DO loop. The label decl has already been created by
6112 gfc_trans_do(), it's in TREE_PURPOSE (backend_decl) of the gfc_code
6113 node at the head of the loop. We must mark the label as used. */
6116 gfc_trans_cycle (gfc_code
* code
)
6120 cycle_label
= code
->ext
.which_construct
->cycle_label
;
6121 gcc_assert (cycle_label
);
6123 TREE_USED (cycle_label
) = 1;
6124 return build1_v (GOTO_EXPR
, cycle_label
);
6128 /* EXIT a DO loop. Similar to CYCLE, but now the label is in
6129 TREE_VALUE (backend_decl) of the gfc_code node at the head of the
6133 gfc_trans_exit (gfc_code
* code
)
6137 exit_label
= code
->ext
.which_construct
->exit_label
;
6138 gcc_assert (exit_label
);
6140 TREE_USED (exit_label
) = 1;
6141 return build1_v (GOTO_EXPR
, exit_label
);
6145 /* Get the initializer expression for the code and expr of an allocate.
6146 When no initializer is needed return NULL. */
6149 allocate_get_initializer (gfc_code
* code
, gfc_expr
* expr
)
6151 if (!gfc_bt_struct (expr
->ts
.type
) && expr
->ts
.type
!= BT_CLASS
)
6154 /* An explicit type was given in allocate ( T:: object). */
6155 if (code
->ext
.alloc
.ts
.type
== BT_DERIVED
6156 && (code
->ext
.alloc
.ts
.u
.derived
->attr
.alloc_comp
6157 || gfc_has_default_initializer (code
->ext
.alloc
.ts
.u
.derived
)))
6158 return gfc_default_initializer (&code
->ext
.alloc
.ts
);
6160 if (gfc_bt_struct (expr
->ts
.type
)
6161 && (expr
->ts
.u
.derived
->attr
.alloc_comp
6162 || gfc_has_default_initializer (expr
->ts
.u
.derived
)))
6163 return gfc_default_initializer (&expr
->ts
);
6165 if (expr
->ts
.type
== BT_CLASS
6166 && (CLASS_DATA (expr
)->ts
.u
.derived
->attr
.alloc_comp
6167 || gfc_has_default_initializer (CLASS_DATA (expr
)->ts
.u
.derived
)))
6168 return gfc_default_initializer (&CLASS_DATA (expr
)->ts
);
6173 /* Translate the ALLOCATE statement. */
6176 gfc_trans_allocate (gfc_code
* code
)
6179 gfc_expr
*expr
, *e3rhs
= NULL
, *init_expr
;
6189 tree al_vptr
, al_len
;
6190 /* If an expr3 is present, then store the tree for accessing its
6191 _vptr, and _len components in the variables, respectively. The
6192 element size, i.e. _vptr%size, is stored in expr3_esize. Any of
6193 the trees may be the NULL_TREE indicating that this is not
6194 available for expr3's type. */
6195 tree expr3
, expr3_vptr
, expr3_len
, expr3_esize
;
6196 /* Classify what expr3 stores. */
6197 enum { E3_UNSET
= 0, E3_SOURCE
, E3_MOLD
, E3_DESC
} e3_is
;
6200 stmtblock_t final_block
;
6202 bool upoly_expr
, tmp_expr3_len_flag
= false, al_len_needs_set
, is_coarray
;
6203 bool needs_caf_sync
, caf_refs_comp
;
6204 bool e3_has_nodescriptor
= false;
6205 gfc_symtree
*newsym
= NULL
;
6206 symbol_attribute caf_attr
;
6207 gfc_actual_arglist
*param_list
;
6209 if (!code
->ext
.alloc
.list
)
6212 stat
= tmp
= memsz
= al_vptr
= al_len
= NULL_TREE
;
6213 expr3
= expr3_vptr
= expr3_len
= expr3_esize
= NULL_TREE
;
6214 label_errmsg
= label_finish
= errmsg
= errlen
= NULL_TREE
;
6216 is_coarray
= needs_caf_sync
= false;
6218 gfc_init_block (&block
);
6219 gfc_init_block (&post
);
6220 gfc_init_block (&final_block
);
6222 /* STAT= (and maybe ERRMSG=) is present. */
6226 tree gfc_int4_type_node
= gfc_get_int_type (4);
6227 stat
= gfc_create_var (gfc_int4_type_node
, "stat");
6229 /* ERRMSG= only makes sense with STAT=. */
6232 gfc_init_se (&se
, NULL
);
6233 se
.want_pointer
= 1;
6234 gfc_conv_expr_lhs (&se
, code
->expr2
);
6236 errlen
= se
.string_length
;
6240 errmsg
= null_pointer_node
;
6241 errlen
= build_int_cst (gfc_charlen_type_node
, 0);
6244 /* GOTO destinations. */
6245 label_errmsg
= gfc_build_label_decl (NULL_TREE
);
6246 label_finish
= gfc_build_label_decl (NULL_TREE
);
6247 TREE_USED (label_finish
) = 0;
6250 /* When an expr3 is present evaluate it only once. The standards prevent a
6251 dependency of expr3 on the objects in the allocate list. An expr3 can
6252 be pre-evaluated in all cases. One just has to make sure, to use the
6253 correct way, i.e., to get the descriptor or to get a reference
6257 bool vtab_needed
= false, temp_var_needed
= false,
6258 temp_obj_created
= false;
6260 is_coarray
= gfc_is_coarray (code
->expr3
);
6262 if (code
->expr3
->expr_type
== EXPR_FUNCTION
&& !code
->expr3
->mold
6263 && (gfc_is_class_array_function (code
->expr3
)
6264 || gfc_is_alloc_class_scalar_function (code
->expr3
)))
6265 code
->expr3
->must_finalize
= 1;
6267 /* Figure whether we need the vtab from expr3. */
6268 for (al
= code
->ext
.alloc
.list
; !vtab_needed
&& al
!= NULL
;
6270 vtab_needed
= (al
->expr
->ts
.type
== BT_CLASS
);
6272 gfc_init_se (&se
, NULL
);
6273 /* When expr3 is a variable, i.e., a very simple expression,
6274 then convert it once here. */
6275 if (code
->expr3
->expr_type
== EXPR_VARIABLE
6276 || code
->expr3
->expr_type
== EXPR_ARRAY
6277 || code
->expr3
->expr_type
== EXPR_CONSTANT
)
6279 if (!code
->expr3
->mold
6280 || code
->expr3
->ts
.type
== BT_CHARACTER
6282 || code
->ext
.alloc
.arr_spec_from_expr3
)
6284 /* Convert expr3 to a tree. For all "simple" expression just
6285 get the descriptor or the reference, respectively, depending
6286 on the rank of the expr. */
6287 if (code
->ext
.alloc
.arr_spec_from_expr3
|| code
->expr3
->rank
!= 0)
6288 gfc_conv_expr_descriptor (&se
, code
->expr3
);
6291 gfc_conv_expr_reference (&se
, code
->expr3
);
6293 /* gfc_conv_expr_reference wraps POINTER_PLUS_EXPR in a
6294 NOP_EXPR, which prevents gfortran from getting the vptr
6295 from the source=-expression. Remove the NOP_EXPR and go
6296 with the POINTER_PLUS_EXPR in this case. */
6297 if (code
->expr3
->ts
.type
== BT_CLASS
6298 && TREE_CODE (se
.expr
) == NOP_EXPR
6299 && (TREE_CODE (TREE_OPERAND (se
.expr
, 0))
6300 == POINTER_PLUS_EXPR
6302 se
.expr
= TREE_OPERAND (se
.expr
, 0);
6304 /* Create a temp variable only for component refs to prevent
6305 having to go through the full deref-chain each time and to
6306 simplfy computation of array properties. */
6307 temp_var_needed
= TREE_CODE (se
.expr
) == COMPONENT_REF
;
6312 /* In all other cases evaluate the expr3. */
6313 symbol_attribute attr
;
6314 /* Get the descriptor for all arrays, that are not allocatable or
6315 pointer, because the latter are descriptors already.
6316 The exception are function calls returning a class object:
6317 The descriptor is stored in their results _data component, which
6318 is easier to access, when first a temporary variable for the
6319 result is created and the descriptor retrieved from there. */
6320 attr
= gfc_expr_attr (code
->expr3
);
6321 if (code
->expr3
->rank
!= 0
6322 && ((!attr
.allocatable
&& !attr
.pointer
)
6323 || (code
->expr3
->expr_type
== EXPR_FUNCTION
6324 && (code
->expr3
->ts
.type
!= BT_CLASS
6325 || (code
->expr3
->value
.function
.isym
6326 && code
->expr3
->value
.function
.isym
6327 ->transformational
)))))
6328 gfc_conv_expr_descriptor (&se
, code
->expr3
);
6330 gfc_conv_expr_reference (&se
, code
->expr3
);
6331 if (code
->expr3
->ts
.type
== BT_CLASS
)
6332 gfc_conv_class_to_class (&se
, code
->expr3
,
6336 temp_obj_created
= temp_var_needed
= !VAR_P (se
.expr
);
6338 gfc_add_block_to_block (&block
, &se
.pre
);
6339 if (code
->expr3
->must_finalize
)
6340 gfc_add_block_to_block (&final_block
, &se
.post
);
6342 gfc_add_block_to_block (&post
, &se
.post
);
6344 /* Special case when string in expr3 is zero. */
6345 if (code
->expr3
->ts
.type
== BT_CHARACTER
6346 && integer_zerop (se
.string_length
))
6348 gfc_init_se (&se
, NULL
);
6349 temp_var_needed
= false;
6350 expr3_len
= build_zero_cst (gfc_charlen_type_node
);
6353 /* Prevent aliasing, i.e., se.expr may be already a
6354 variable declaration. */
6355 else if (se
.expr
!= NULL_TREE
&& temp_var_needed
)
6358 tmp
= GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se
.expr
)) || is_coarray
?
6360 : build_fold_indirect_ref_loc (input_location
, se
.expr
);
6362 /* Get the array descriptor and prepare it to be assigned to the
6363 temporary variable var. For classes the array descriptor is
6364 in the _data component and the object goes into the
6365 GFC_DECL_SAVED_DESCRIPTOR. */
6366 if (code
->expr3
->ts
.type
== BT_CLASS
6367 && code
->expr3
->rank
!= 0)
6369 /* When an array_ref was in expr3, then the descriptor is the
6371 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp
)) || is_coarray
)
6373 desc
= TREE_OPERAND (tmp
, 0);
6378 tmp
= gfc_class_data_get (tmp
);
6380 if (code
->ext
.alloc
.arr_spec_from_expr3
)
6384 desc
= !is_coarray
? se
.expr
6385 : TREE_OPERAND (TREE_OPERAND (se
.expr
, 0), 0);
6386 /* We need a regular (non-UID) symbol here, therefore give a
6388 var
= gfc_create_var (TREE_TYPE (tmp
), "source");
6389 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp
)) || is_coarray
)
6391 gfc_allocate_lang_decl (var
);
6392 GFC_DECL_SAVED_DESCRIPTOR (var
) = desc
;
6394 gfc_add_modify_loc (input_location
, &block
, var
, tmp
);
6397 if (se
.string_length
)
6398 /* Evaluate it assuming that it also is complicated like expr3. */
6399 expr3_len
= gfc_evaluate_now (se
.string_length
, &block
);
6404 expr3_len
= se
.string_length
;
6407 /* Deallocate any allocatable components in expressions that use a
6408 temporary object, i.e. are not a simple alias of to an EXPR_VARIABLE.
6409 E.g. temporaries of a function call need freeing of their components
6411 if ((code
->expr3
->ts
.type
== BT_DERIVED
6412 || code
->expr3
->ts
.type
== BT_CLASS
)
6413 && (code
->expr3
->expr_type
!= EXPR_VARIABLE
|| temp_obj_created
)
6414 && code
->expr3
->ts
.u
.derived
->attr
.alloc_comp
6415 && !code
->expr3
->must_finalize
)
6417 tmp
= gfc_deallocate_alloc_comp (code
->expr3
->ts
.u
.derived
,
6418 expr3
, code
->expr3
->rank
);
6419 gfc_prepend_expr_to_block (&post
, tmp
);
6422 /* Store what the expr3 is to be used for. */
6423 if (e3_is
== E3_UNSET
)
6424 e3_is
= expr3
!= NULL_TREE
?
6425 (code
->ext
.alloc
.arr_spec_from_expr3
?
6427 : (code
->expr3
->mold
? E3_MOLD
: E3_SOURCE
))
6430 /* Figure how to get the _vtab entry. This also obtains the tree
6431 expression for accessing the _len component, because only
6432 unlimited polymorphic objects, which are a subcategory of class
6433 types, have a _len component. */
6434 if (code
->expr3
->ts
.type
== BT_CLASS
)
6437 tmp
= expr3
!= NULL_TREE
&& POINTER_TYPE_P (TREE_TYPE (expr3
)) ?
6438 build_fold_indirect_ref (expr3
): expr3
;
6439 /* Polymorphic SOURCE: VPTR must be determined at run time.
6440 expr3 may be a temporary array declaration, therefore check for
6441 GFC_CLASS_TYPE_P before trying to get the _vptr component. */
6442 if (tmp
!= NULL_TREE
6443 && (e3_is
== E3_DESC
6444 || (GFC_CLASS_TYPE_P (TREE_TYPE (tmp
))
6445 && (VAR_P (tmp
) || !code
->expr3
->ref
))
6446 || (VAR_P (tmp
) && DECL_LANG_SPECIFIC (tmp
))))
6447 tmp
= gfc_class_vptr_get (expr3
);
6450 rhs
= gfc_find_and_cut_at_last_class_ref (code
->expr3
);
6451 gfc_add_vptr_component (rhs
);
6452 gfc_init_se (&se
, NULL
);
6453 se
.want_pointer
= 1;
6454 gfc_conv_expr (&se
, rhs
);
6456 gfc_free_expr (rhs
);
6458 /* Set the element size. */
6459 expr3_esize
= gfc_vptr_size_get (tmp
);
6462 /* Initialize the ref to the _len component. */
6463 if (expr3_len
== NULL_TREE
&& UNLIMITED_POLY (code
->expr3
))
6465 /* Same like for retrieving the _vptr. */
6466 if (expr3
!= NULL_TREE
&& !code
->expr3
->ref
)
6467 expr3_len
= gfc_class_len_get (expr3
);
6470 rhs
= gfc_find_and_cut_at_last_class_ref (code
->expr3
);
6471 gfc_add_len_component (rhs
);
6472 gfc_init_se (&se
, NULL
);
6473 gfc_conv_expr (&se
, rhs
);
6474 expr3_len
= se
.expr
;
6475 gfc_free_expr (rhs
);
6481 /* When the object to allocate is polymorphic type, then it
6482 needs its vtab set correctly, so deduce the required _vtab
6483 and _len from the source expression. */
6486 /* VPTR is fixed at compile time. */
6489 vtab
= gfc_find_vtab (&code
->expr3
->ts
);
6491 expr3_vptr
= gfc_get_symbol_decl (vtab
);
6492 expr3_vptr
= gfc_build_addr_expr (NULL_TREE
,
6495 /* _len component needs to be set, when ts is a character
6497 if (expr3_len
== NULL_TREE
6498 && code
->expr3
->ts
.type
== BT_CHARACTER
)
6500 if (code
->expr3
->ts
.u
.cl
6501 && code
->expr3
->ts
.u
.cl
->length
)
6503 gfc_init_se (&se
, NULL
);
6504 gfc_conv_expr (&se
, code
->expr3
->ts
.u
.cl
->length
);
6505 gfc_add_block_to_block (&block
, &se
.pre
);
6506 expr3_len
= gfc_evaluate_now (se
.expr
, &block
);
6508 gcc_assert (expr3_len
);
6510 /* For character arrays only the kind's size is needed, because
6511 the array mem_size is _len * (elem_size = kind_size).
6512 For all other get the element size in the normal way. */
6513 if (code
->expr3
->ts
.type
== BT_CHARACTER
)
6514 expr3_esize
= TYPE_SIZE_UNIT (
6515 gfc_get_char_type (code
->expr3
->ts
.kind
));
6517 expr3_esize
= TYPE_SIZE_UNIT (
6518 gfc_typenode_for_spec (&code
->expr3
->ts
));
6520 gcc_assert (expr3_esize
);
6521 expr3_esize
= fold_convert (sizetype
, expr3_esize
);
6522 if (e3_is
== E3_MOLD
)
6523 /* The expr3 is no longer valid after this point. */
6526 else if (code
->ext
.alloc
.ts
.type
!= BT_UNKNOWN
)
6528 /* Compute the explicit typespec given only once for all objects
6530 if (code
->ext
.alloc
.ts
.type
!= BT_CHARACTER
)
6531 expr3_esize
= TYPE_SIZE_UNIT (
6532 gfc_typenode_for_spec (&code
->ext
.alloc
.ts
));
6533 else if (code
->ext
.alloc
.ts
.u
.cl
->length
!= NULL
)
6536 sz
= gfc_copy_expr (code
->ext
.alloc
.ts
.u
.cl
->length
);
6537 gfc_init_se (&se_sz
, NULL
);
6538 gfc_conv_expr (&se_sz
, sz
);
6540 tmp
= gfc_get_char_type (code
->ext
.alloc
.ts
.kind
);
6541 tmp
= TYPE_SIZE_UNIT (tmp
);
6542 tmp
= fold_convert (TREE_TYPE (se_sz
.expr
), tmp
);
6543 gfc_add_block_to_block (&block
, &se_sz
.pre
);
6544 expr3_esize
= fold_build2_loc (input_location
, MULT_EXPR
,
6545 TREE_TYPE (se_sz
.expr
),
6547 expr3_esize
= gfc_evaluate_now (expr3_esize
, &block
);
6550 expr3_esize
= NULL_TREE
;
6553 /* The routine gfc_trans_assignment () already implements all
6554 techniques needed. Unfortunately we may have a temporary
6555 variable for the source= expression here. When that is the
6556 case convert this variable into a temporary gfc_expr of type
6557 EXPR_VARIABLE and used it as rhs for the assignment. The
6558 advantage is, that we get scalarizer support for free,
6559 don't have to take care about scalar to array treatment and
6560 will benefit of every enhancements gfc_trans_assignment ()
6562 No need to check whether e3_is is E3_UNSET, because that is
6563 done by expr3 != NULL_TREE.
6564 Exclude variables since the following block does not handle
6565 array sections. In any case, there is no harm in sending
6566 variables to gfc_trans_assignment because there is no
6567 evaluation of variables. */
6570 if (code
->expr3
->expr_type
!= EXPR_VARIABLE
6571 && e3_is
!= E3_MOLD
&& expr3
!= NULL_TREE
6572 && DECL_P (expr3
) && DECL_ARTIFICIAL (expr3
))
6574 /* Build a temporary symtree and symbol. Do not add it to the current
6575 namespace to prevent accidently modifying a colliding
6577 newsym
= XCNEW (gfc_symtree
);
6578 /* The name of the symtree should be unique, because gfc_create_var ()
6579 took care about generating the identifier. */
6581 = gfc_get_string ("%s", IDENTIFIER_POINTER (DECL_NAME (expr3
)));
6582 newsym
->n
.sym
= gfc_new_symbol (newsym
->name
, NULL
);
6583 /* The backend_decl is known. It is expr3, which is inserted
6585 newsym
->n
.sym
->backend_decl
= expr3
;
6586 e3rhs
= gfc_get_expr ();
6587 e3rhs
->rank
= code
->expr3
->rank
;
6588 e3rhs
->symtree
= newsym
;
6589 /* Mark the symbol referenced or gfc_trans_assignment will bug. */
6590 newsym
->n
.sym
->attr
.referenced
= 1;
6591 e3rhs
->expr_type
= EXPR_VARIABLE
;
6592 e3rhs
->where
= code
->expr3
->where
;
6593 /* Set the symbols type, upto it was BT_UNKNOWN. */
6594 if (IS_CLASS_ARRAY (code
->expr3
)
6595 && code
->expr3
->expr_type
== EXPR_FUNCTION
6596 && code
->expr3
->value
.function
.isym
6597 && code
->expr3
->value
.function
.isym
->transformational
)
6599 e3rhs
->ts
= CLASS_DATA (code
->expr3
)->ts
;
6601 else if (code
->expr3
->ts
.type
== BT_CLASS
6602 && !GFC_CLASS_TYPE_P (TREE_TYPE (expr3
)))
6603 e3rhs
->ts
= CLASS_DATA (code
->expr3
)->ts
;
6605 e3rhs
->ts
= code
->expr3
->ts
;
6606 newsym
->n
.sym
->ts
= e3rhs
->ts
;
6607 /* Check whether the expr3 is array valued. */
6610 gfc_array_spec
*arr
;
6611 arr
= gfc_get_array_spec ();
6612 arr
->rank
= e3rhs
->rank
;
6613 arr
->type
= AS_DEFERRED
;
6614 /* Set the dimension and pointer attribute for arrays
6615 to be on the safe side. */
6616 newsym
->n
.sym
->attr
.dimension
= 1;
6617 newsym
->n
.sym
->attr
.pointer
= 1;
6618 newsym
->n
.sym
->as
= arr
;
6619 if (IS_CLASS_ARRAY (code
->expr3
)
6620 && code
->expr3
->expr_type
== EXPR_FUNCTION
6621 && code
->expr3
->value
.function
.isym
6622 && code
->expr3
->value
.function
.isym
->transformational
)
6624 gfc_array_spec
*tarr
;
6625 tarr
= gfc_get_array_spec ();
6627 e3rhs
->ts
.u
.derived
->as
= tarr
;
6629 gfc_add_full_array_ref (e3rhs
, arr
);
6631 else if (POINTER_TYPE_P (TREE_TYPE (expr3
)))
6632 newsym
->n
.sym
->attr
.pointer
= 1;
6633 /* The string length is known, too. Set it for char arrays. */
6634 if (e3rhs
->ts
.type
== BT_CHARACTER
)
6635 newsym
->n
.sym
->ts
.u
.cl
->backend_decl
= expr3_len
;
6636 gfc_commit_symbol (newsym
->n
.sym
);
6639 e3rhs
= gfc_copy_expr (code
->expr3
);
6641 // We need to propagate the bounds of the expr3 for source=/mold=.
6642 // However, for non-named arrays, the lbound has to be 1 and neither the
6643 // bound used inside the called function even when returning an
6644 // allocatable/pointer nor the zero used internally.
6645 if (e3_is
== E3_DESC
6646 && code
->expr3
->expr_type
!= EXPR_VARIABLE
)
6647 e3_has_nodescriptor
= true;
6650 /* Loop over all objects to allocate. */
6651 for (al
= code
->ext
.alloc
.list
; al
!= NULL
; al
= al
->next
)
6653 expr
= gfc_copy_expr (al
->expr
);
6654 /* UNLIMITED_POLY () needs the _data component to be set, when
6655 expr is a unlimited polymorphic object. But the _data component
6656 has not been set yet, so check the derived type's attr for the
6657 unlimited polymorphic flag to be safe. */
6658 upoly_expr
= UNLIMITED_POLY (expr
)
6659 || (expr
->ts
.type
== BT_DERIVED
6660 && expr
->ts
.u
.derived
->attr
.unlimited_polymorphic
);
6661 gfc_init_se (&se
, NULL
);
6663 /* For class types prepare the expressions to ref the _vptr
6664 and the _len component. The latter for unlimited polymorphic
6666 if (expr
->ts
.type
== BT_CLASS
)
6668 gfc_expr
*expr_ref_vptr
, *expr_ref_len
;
6669 gfc_add_data_component (expr
);
6670 /* Prep the vptr handle. */
6671 expr_ref_vptr
= gfc_copy_expr (al
->expr
);
6672 gfc_add_vptr_component (expr_ref_vptr
);
6673 se
.want_pointer
= 1;
6674 gfc_conv_expr (&se
, expr_ref_vptr
);
6676 se
.want_pointer
= 0;
6677 gfc_free_expr (expr_ref_vptr
);
6678 /* Allocated unlimited polymorphic objects always have a _len
6682 expr_ref_len
= gfc_copy_expr (al
->expr
);
6683 gfc_add_len_component (expr_ref_len
);
6684 gfc_conv_expr (&se
, expr_ref_len
);
6686 gfc_free_expr (expr_ref_len
);
6689 /* In a loop ensure that all loop variable dependent variables
6690 are initialized at the same spot in all execution paths. */
6694 al_vptr
= al_len
= NULL_TREE
;
6696 se
.want_pointer
= 1;
6697 se
.descriptor_only
= 1;
6699 gfc_conv_expr (&se
, expr
);
6700 if (expr
->ts
.type
== BT_CHARACTER
&& expr
->ts
.deferred
)
6701 /* se.string_length now stores the .string_length variable of expr
6702 needed to allocate character(len=:) arrays. */
6703 al_len
= se
.string_length
;
6705 al_len_needs_set
= al_len
!= NULL_TREE
;
6706 /* When allocating an array one cannot use much of the
6707 pre-evaluated expr3 expressions, because for most of them the
6708 scalarizer is needed which is not available in the pre-evaluation
6709 step. Therefore gfc_array_allocate () is responsible (and able)
6710 to handle the complete array allocation. Only the element size
6711 needs to be provided, which is done most of the time by the
6712 pre-evaluation step. */
6714 if (expr3_len
&& (code
->expr3
->ts
.type
== BT_CHARACTER
6715 || code
->expr3
->ts
.type
== BT_CLASS
))
6717 /* When al is an array, then the element size for each element
6718 in the array is needed, which is the product of the len and
6719 esize for char arrays. For unlimited polymorphics len can be
6720 zero, therefore take the maximum of len and one. */
6721 tmp
= fold_build2_loc (input_location
, MAX_EXPR
,
6722 TREE_TYPE (expr3_len
),
6723 expr3_len
, fold_convert (TREE_TYPE (expr3_len
),
6725 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
6726 TREE_TYPE (expr3_esize
), expr3_esize
,
6727 fold_convert (TREE_TYPE (expr3_esize
), tmp
));
6732 if (!gfc_array_allocate (&se
, expr
, stat
, errmsg
, errlen
,
6733 label_finish
, tmp
, &nelems
,
6734 e3rhs
? e3rhs
: code
->expr3
,
6735 e3_is
== E3_DESC
? expr3
: NULL_TREE
,
6736 e3_has_nodescriptor
))
6738 /* A scalar or derived type. First compute the size to
6741 expr3_len is set when expr3 is an unlimited polymorphic
6742 object or a deferred length string. */
6743 if (expr3_len
!= NULL_TREE
)
6745 tmp
= fold_convert (TREE_TYPE (expr3_esize
), expr3_len
);
6746 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
6747 TREE_TYPE (expr3_esize
),
6749 if (code
->expr3
->ts
.type
!= BT_CLASS
)
6750 /* expr3 is a deferred length string, i.e., we are
6755 /* For unlimited polymorphic enties build
6756 (len > 0) ? element_size * len : element_size
6757 to compute the number of bytes to allocate.
6758 This allows the allocation of unlimited polymorphic
6759 objects from an expr3 that is also unlimited
6760 polymorphic and stores a _len dependent object,
6762 memsz
= fold_build2_loc (input_location
, GT_EXPR
,
6763 logical_type_node
, expr3_len
,
6765 (TREE_TYPE (expr3_len
)));
6766 memsz
= fold_build3_loc (input_location
, COND_EXPR
,
6767 TREE_TYPE (expr3_esize
),
6768 memsz
, tmp
, expr3_esize
);
6771 else if (expr3_esize
!= NULL_TREE
)
6772 /* Any other object in expr3 just needs element size in
6774 memsz
= expr3_esize
;
6775 else if ((expr
->ts
.type
== BT_CHARACTER
&& expr
->ts
.deferred
)
6777 && code
->ext
.alloc
.ts
.type
== BT_CHARACTER
))
6779 /* Allocating deferred length char arrays need the length
6780 to allocate in the alloc_type_spec. But also unlimited
6781 polymorphic objects may be allocated as char arrays.
6782 Both are handled here. */
6783 gfc_init_se (&se_sz
, NULL
);
6784 gfc_conv_expr (&se_sz
, code
->ext
.alloc
.ts
.u
.cl
->length
);
6785 gfc_add_block_to_block (&se
.pre
, &se_sz
.pre
);
6786 se_sz
.expr
= gfc_evaluate_now (se_sz
.expr
, &se
.pre
);
6787 gfc_add_block_to_block (&se
.pre
, &se_sz
.post
);
6788 expr3_len
= se_sz
.expr
;
6789 tmp_expr3_len_flag
= true;
6790 tmp
= TYPE_SIZE_UNIT (
6791 gfc_get_char_type (code
->ext
.alloc
.ts
.kind
));
6792 memsz
= fold_build2_loc (input_location
, MULT_EXPR
,
6794 fold_convert (TREE_TYPE (tmp
),
6798 else if (expr
->ts
.type
== BT_CHARACTER
)
6800 /* Compute the number of bytes needed to allocate a fixed
6801 length char array. */
6802 gcc_assert (se
.string_length
!= NULL_TREE
);
6803 tmp
= TYPE_SIZE_UNIT (gfc_get_char_type (expr
->ts
.kind
));
6804 memsz
= fold_build2_loc (input_location
, MULT_EXPR
,
6805 TREE_TYPE (tmp
), tmp
,
6806 fold_convert (TREE_TYPE (tmp
),
6809 else if (code
->ext
.alloc
.ts
.type
!= BT_UNKNOWN
)
6810 /* Handle all types, where the alloc_type_spec is set. */
6811 memsz
= TYPE_SIZE_UNIT (gfc_typenode_for_spec (&code
->ext
.alloc
.ts
));
6813 /* Handle size computation of the type declared to alloc. */
6814 memsz
= TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (se
.expr
)));
6816 /* Store the caf-attributes for latter use. */
6817 if (flag_coarray
== GFC_FCOARRAY_LIB
6818 && (caf_attr
= gfc_caf_attr (expr
, true, &caf_refs_comp
))
6821 /* Scalar allocatable components in coarray'ed derived types make
6822 it here and are treated now. */
6823 tree caf_decl
, token
;
6827 /* Set flag, to add synchronize after the allocate. */
6828 needs_caf_sync
= needs_caf_sync
6829 || caf_attr
.coarray_comp
|| !caf_refs_comp
;
6831 gfc_init_se (&caf_se
, NULL
);
6833 caf_decl
= gfc_get_tree_for_caf_expr (expr
);
6834 gfc_get_caf_token_offset (&caf_se
, &token
, NULL
, caf_decl
,
6836 gfc_add_block_to_block (&se
.pre
, &caf_se
.pre
);
6837 gfc_allocate_allocatable (&se
.pre
, se
.expr
, memsz
,
6838 gfc_build_addr_expr (NULL_TREE
, token
),
6839 NULL_TREE
, NULL_TREE
, NULL_TREE
,
6840 label_finish
, expr
, 1);
6842 /* Allocate - for non-pointers with re-alloc checking. */
6843 else if (gfc_expr_attr (expr
).allocatable
)
6844 gfc_allocate_allocatable (&se
.pre
, se
.expr
, memsz
,
6845 NULL_TREE
, stat
, errmsg
, errlen
,
6846 label_finish
, expr
, 0);
6848 gfc_allocate_using_malloc (&se
.pre
, se
.expr
, memsz
, stat
);
6852 /* Allocating coarrays needs a sync after the allocate executed.
6853 Set the flag to add the sync after all objects are allocated. */
6854 if (flag_coarray
== GFC_FCOARRAY_LIB
6855 && (caf_attr
= gfc_caf_attr (expr
, true, &caf_refs_comp
))
6859 needs_caf_sync
= needs_caf_sync
6860 || caf_attr
.coarray_comp
|| !caf_refs_comp
;
6863 if (expr
->ts
.type
== BT_CHARACTER
&& al_len
!= NULL_TREE
6864 && expr3_len
!= NULL_TREE
)
6866 /* Arrays need to have a _len set before the array
6867 descriptor is filled. */
6868 gfc_add_modify (&block
, al_len
,
6869 fold_convert (TREE_TYPE (al_len
), expr3_len
));
6870 /* Prevent setting the length twice. */
6871 al_len_needs_set
= false;
6873 else if (expr
->ts
.type
== BT_CHARACTER
&& al_len
!= NULL_TREE
6874 && code
->ext
.alloc
.ts
.u
.cl
->length
)
6876 /* Cover the cases where a string length is explicitly
6877 specified by a type spec for deferred length character
6878 arrays or unlimited polymorphic objects without a
6879 source= or mold= expression. */
6880 gfc_init_se (&se_sz
, NULL
);
6881 gfc_conv_expr (&se_sz
, code
->ext
.alloc
.ts
.u
.cl
->length
);
6882 gfc_add_block_to_block (&block
, &se_sz
.pre
);
6883 gfc_add_modify (&block
, al_len
,
6884 fold_convert (TREE_TYPE (al_len
),
6886 al_len_needs_set
= false;
6890 gfc_add_block_to_block (&block
, &se
.pre
);
6892 /* Error checking -- Note: ERRMSG only makes sense with STAT. */
6895 tmp
= build1_v (GOTO_EXPR
, label_errmsg
);
6896 parm
= fold_build2_loc (input_location
, NE_EXPR
,
6897 logical_type_node
, stat
,
6898 build_int_cst (TREE_TYPE (stat
), 0));
6899 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
6900 gfc_unlikely (parm
, PRED_FORTRAN_FAIL_ALLOC
),
6901 tmp
, build_empty_stmt (input_location
));
6902 gfc_add_expr_to_block (&block
, tmp
);
6905 /* Set the vptr only when no source= is set. When source= is set, then
6906 the trans_assignment below will set the vptr. */
6907 if (al_vptr
!= NULL_TREE
&& (!code
->expr3
|| code
->expr3
->mold
))
6909 if (expr3_vptr
!= NULL_TREE
)
6910 /* The vtab is already known, so just assign it. */
6911 gfc_add_modify (&block
, al_vptr
,
6912 fold_convert (TREE_TYPE (al_vptr
), expr3_vptr
));
6915 /* VPTR is fixed at compile time. */
6920 /* Although expr3 is pre-evaluated above, it may happen,
6921 that for arrays or in mold= cases the pre-evaluation
6922 was not successful. In these rare cases take the vtab
6923 from the typespec of expr3 here. */
6924 ts
= &code
->expr3
->ts
;
6925 else if (code
->ext
.alloc
.ts
.type
== BT_DERIVED
|| upoly_expr
)
6926 /* The alloc_type_spec gives the type to allocate or the
6927 al is unlimited polymorphic, which enforces the use of
6928 an alloc_type_spec that is not necessarily a BT_DERIVED. */
6929 ts
= &code
->ext
.alloc
.ts
;
6931 /* Prepare for setting the vtab as declared. */
6934 vtab
= gfc_find_vtab (ts
);
6936 tmp
= gfc_build_addr_expr (NULL_TREE
,
6937 gfc_get_symbol_decl (vtab
));
6938 gfc_add_modify (&block
, al_vptr
,
6939 fold_convert (TREE_TYPE (al_vptr
), tmp
));
6943 /* Add assignment for string length. */
6944 if (al_len
!= NULL_TREE
&& al_len_needs_set
)
6946 if (expr3_len
!= NULL_TREE
)
6948 gfc_add_modify (&block
, al_len
,
6949 fold_convert (TREE_TYPE (al_len
),
6951 /* When tmp_expr3_len_flag is set, then expr3_len is
6952 abused to carry the length information from the
6953 alloc_type. Clear it to prevent setting incorrect len
6954 information in future loop iterations. */
6955 if (tmp_expr3_len_flag
)
6956 /* No need to reset tmp_expr3_len_flag, because the
6957 presence of an expr3 cannot change within in the
6959 expr3_len
= NULL_TREE
;
6961 else if (code
->ext
.alloc
.ts
.type
== BT_CHARACTER
6962 && code
->ext
.alloc
.ts
.u
.cl
->length
)
6964 /* Cover the cases where a string length is explicitly
6965 specified by a type spec for deferred length character
6966 arrays or unlimited polymorphic objects without a
6967 source= or mold= expression. */
6968 if (expr3_esize
== NULL_TREE
|| code
->ext
.alloc
.ts
.kind
!= 1)
6970 gfc_init_se (&se_sz
, NULL
);
6971 gfc_conv_expr (&se_sz
, code
->ext
.alloc
.ts
.u
.cl
->length
);
6972 gfc_add_block_to_block (&block
, &se_sz
.pre
);
6973 gfc_add_modify (&block
, al_len
,
6974 fold_convert (TREE_TYPE (al_len
),
6978 gfc_add_modify (&block
, al_len
,
6979 fold_convert (TREE_TYPE (al_len
),
6983 /* No length information needed, because type to allocate
6984 has no length. Set _len to 0. */
6985 gfc_add_modify (&block
, al_len
,
6986 fold_convert (TREE_TYPE (al_len
),
6987 integer_zero_node
));
6991 if (code
->expr3
&& !code
->expr3
->mold
&& e3_is
!= E3_MOLD
)
6993 /* Initialization via SOURCE block (or static default initializer).
6994 Switch off automatic reallocation since we have just done the
6996 int realloc_lhs
= flag_realloc_lhs
;
6997 gfc_expr
*init_expr
= gfc_expr_to_initialize (expr
);
6998 gfc_expr
*rhs
= e3rhs
? e3rhs
: gfc_copy_expr (code
->expr3
);
6999 flag_realloc_lhs
= 0;
7000 tmp
= gfc_trans_assignment (init_expr
, rhs
, true, false, true,
7002 flag_realloc_lhs
= realloc_lhs
;
7003 /* Free the expression allocated for init_expr. */
7004 gfc_free_expr (init_expr
);
7006 gfc_free_expr (rhs
);
7007 gfc_add_expr_to_block (&block
, tmp
);
7009 /* Set KIND and LEN PDT components and allocate those that are
7011 else if (expr
->ts
.type
== BT_DERIVED
7012 && expr
->ts
.u
.derived
->attr
.pdt_type
)
7014 if (code
->expr3
&& code
->expr3
->param_list
)
7015 param_list
= code
->expr3
->param_list
;
7016 else if (expr
->param_list
)
7017 param_list
= expr
->param_list
;
7019 param_list
= expr
->symtree
->n
.sym
->param_list
;
7020 tmp
= gfc_allocate_pdt_comp (expr
->ts
.u
.derived
, se
.expr
,
7021 expr
->rank
, param_list
);
7022 gfc_add_expr_to_block (&block
, tmp
);
7024 /* Ditto for CLASS expressions. */
7025 else if (expr
->ts
.type
== BT_CLASS
7026 && CLASS_DATA (expr
)->ts
.u
.derived
->attr
.pdt_type
)
7028 if (code
->expr3
&& code
->expr3
->param_list
)
7029 param_list
= code
->expr3
->param_list
;
7030 else if (expr
->param_list
)
7031 param_list
= expr
->param_list
;
7033 param_list
= expr
->symtree
->n
.sym
->param_list
;
7034 tmp
= gfc_allocate_pdt_comp (CLASS_DATA (expr
)->ts
.u
.derived
,
7035 se
.expr
, expr
->rank
, param_list
);
7036 gfc_add_expr_to_block (&block
, tmp
);
7038 else if (code
->expr3
&& code
->expr3
->mold
7039 && code
->expr3
->ts
.type
== BT_CLASS
)
7041 /* Use class_init_assign to initialize expr. */
7043 ini
= gfc_get_code (EXEC_INIT_ASSIGN
);
7044 ini
->expr1
= gfc_find_and_cut_at_last_class_ref (expr
, true);
7045 tmp
= gfc_trans_class_init_assign (ini
);
7046 gfc_free_statements (ini
);
7047 gfc_add_expr_to_block (&block
, tmp
);
7049 else if ((init_expr
= allocate_get_initializer (code
, expr
)))
7051 /* Use class_init_assign to initialize expr. */
7053 int realloc_lhs
= flag_realloc_lhs
;
7054 ini
= gfc_get_code (EXEC_INIT_ASSIGN
);
7055 ini
->expr1
= gfc_expr_to_initialize (expr
);
7056 ini
->expr2
= init_expr
;
7057 flag_realloc_lhs
= 0;
7058 tmp
= gfc_trans_init_assign (ini
);
7059 flag_realloc_lhs
= realloc_lhs
;
7060 gfc_free_statements (ini
);
7061 /* Init_expr is freeed by above free_statements, just need to null
7064 gfc_add_expr_to_block (&block
, tmp
);
7067 /* Nullify all pointers in derived type coarrays. This registers a
7068 token for them which allows their allocation. */
7071 gfc_symbol
*type
= NULL
;
7072 symbol_attribute caf_attr
;
7074 if (code
->ext
.alloc
.ts
.type
== BT_DERIVED
7075 && code
->ext
.alloc
.ts
.u
.derived
->attr
.pointer_comp
)
7077 type
= code
->ext
.alloc
.ts
.u
.derived
;
7078 rank
= type
->attr
.dimension
? type
->as
->rank
: 0;
7079 gfc_clear_attr (&caf_attr
);
7081 else if (expr
->ts
.type
== BT_DERIVED
7082 && expr
->ts
.u
.derived
->attr
.pointer_comp
)
7084 type
= expr
->ts
.u
.derived
;
7086 caf_attr
= gfc_caf_attr (expr
, true);
7089 /* Initialize the tokens of pointer components in derived type
7093 tmp
= (caf_attr
.codimension
&& !caf_attr
.dimension
)
7094 ? gfc_conv_descriptor_data_get (se
.expr
) : se
.expr
;
7095 tmp
= gfc_nullify_alloc_comp (type
, tmp
, rank
,
7096 GFC_STRUCTURE_CAF_MODE_IN_COARRAY
);
7097 gfc_add_expr_to_block (&block
, tmp
);
7101 gfc_free_expr (expr
);
7108 gfc_free_symbol (newsym
->n
.sym
);
7111 gfc_free_expr (e3rhs
);
7116 tmp
= build1_v (LABEL_EXPR
, label_errmsg
);
7117 gfc_add_expr_to_block (&block
, tmp
);
7120 /* ERRMSG - only useful if STAT is present. */
7121 if (code
->expr1
&& code
->expr2
)
7123 const char *msg
= "Attempt to allocate an allocated object";
7124 tree slen
, dlen
, errmsg_str
;
7125 stmtblock_t errmsg_block
;
7127 gfc_init_block (&errmsg_block
);
7129 errmsg_str
= gfc_create_var (pchar_type_node
, "ERRMSG");
7130 gfc_add_modify (&errmsg_block
, errmsg_str
,
7131 gfc_build_addr_expr (pchar_type_node
,
7132 gfc_build_localized_cstring_const (msg
)));
7134 slen
= build_int_cst (gfc_charlen_type_node
, strlen (msg
));
7135 dlen
= gfc_get_expr_charlen (code
->expr2
);
7136 slen
= fold_build2_loc (input_location
, MIN_EXPR
,
7137 TREE_TYPE (slen
), dlen
, slen
);
7139 gfc_trans_string_copy (&errmsg_block
, dlen
, errmsg
,
7140 code
->expr2
->ts
.kind
,
7142 gfc_default_character_kind
);
7143 dlen
= gfc_finish_block (&errmsg_block
);
7145 tmp
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
7146 stat
, build_int_cst (TREE_TYPE (stat
), 0));
7148 tmp
= build3_v (COND_EXPR
, tmp
,
7149 dlen
, build_empty_stmt (input_location
));
7151 gfc_add_expr_to_block (&block
, tmp
);
7157 if (TREE_USED (label_finish
))
7159 tmp
= build1_v (LABEL_EXPR
, label_finish
);
7160 gfc_add_expr_to_block (&block
, tmp
);
7163 gfc_init_se (&se
, NULL
);
7164 gfc_conv_expr_lhs (&se
, code
->expr1
);
7165 tmp
= convert (TREE_TYPE (se
.expr
), stat
);
7166 gfc_add_modify (&block
, se
.expr
, tmp
);
7171 /* Add a sync all after the allocation has been executed. */
7172 tree zero_size
= build_zero_cst (size_type_node
);
7173 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_sync_all
,
7174 3, null_pointer_node
, null_pointer_node
,
7176 gfc_add_expr_to_block (&post
, tmp
);
7179 gfc_add_block_to_block (&block
, &se
.post
);
7180 gfc_add_block_to_block (&block
, &post
);
7181 if (code
->expr3
&& code
->expr3
->must_finalize
)
7182 gfc_add_block_to_block (&block
, &final_block
);
7184 return gfc_finish_block (&block
);
7188 /* Translate a DEALLOCATE statement. */
7191 gfc_trans_deallocate (gfc_code
*code
)
7195 tree apstat
, pstat
, stat
, errmsg
, errlen
, tmp
;
7196 tree label_finish
, label_errmsg
;
7199 pstat
= apstat
= stat
= errmsg
= errlen
= tmp
= NULL_TREE
;
7200 label_finish
= label_errmsg
= NULL_TREE
;
7202 gfc_start_block (&block
);
7204 /* Count the number of failed deallocations. If deallocate() was
7205 called with STAT= , then set STAT to the count. If deallocate
7206 was called with ERRMSG, then set ERRMG to a string. */
7209 tree gfc_int4_type_node
= gfc_get_int_type (4);
7211 stat
= gfc_create_var (gfc_int4_type_node
, "stat");
7212 pstat
= gfc_build_addr_expr (NULL_TREE
, stat
);
7214 /* GOTO destinations. */
7215 label_errmsg
= gfc_build_label_decl (NULL_TREE
);
7216 label_finish
= gfc_build_label_decl (NULL_TREE
);
7217 TREE_USED (label_finish
) = 0;
7220 /* Set ERRMSG - only needed if STAT is available. */
7221 if (code
->expr1
&& code
->expr2
)
7223 gfc_init_se (&se
, NULL
);
7224 se
.want_pointer
= 1;
7225 gfc_conv_expr_lhs (&se
, code
->expr2
);
7227 errlen
= se
.string_length
;
7230 for (al
= code
->ext
.alloc
.list
; al
!= NULL
; al
= al
->next
)
7232 gfc_expr
*expr
= gfc_copy_expr (al
->expr
);
7233 bool is_coarray
= false, is_coarray_array
= false;
7236 gcc_assert (expr
->expr_type
== EXPR_VARIABLE
);
7238 if (expr
->ts
.type
== BT_CLASS
)
7239 gfc_add_data_component (expr
);
7241 gfc_init_se (&se
, NULL
);
7242 gfc_start_block (&se
.pre
);
7244 se
.want_pointer
= 1;
7245 se
.descriptor_only
= 1;
7246 gfc_conv_expr (&se
, expr
);
7248 /* Deallocate PDT components that are parameterized. */
7250 if (expr
->ts
.type
== BT_DERIVED
7251 && expr
->ts
.u
.derived
->attr
.pdt_type
7252 && expr
->symtree
->n
.sym
->param_list
)
7253 tmp
= gfc_deallocate_pdt_comp (expr
->ts
.u
.derived
, se
.expr
, expr
->rank
);
7254 else if (expr
->ts
.type
== BT_CLASS
7255 && CLASS_DATA (expr
)->ts
.u
.derived
->attr
.pdt_type
7256 && expr
->symtree
->n
.sym
->param_list
)
7257 tmp
= gfc_deallocate_pdt_comp (CLASS_DATA (expr
)->ts
.u
.derived
,
7258 se
.expr
, expr
->rank
);
7261 gfc_add_expr_to_block (&block
, tmp
);
7263 if (flag_coarray
== GFC_FCOARRAY_LIB
7264 || flag_coarray
== GFC_FCOARRAY_SINGLE
)
7267 symbol_attribute caf_attr
= gfc_caf_attr (expr
, false, &comp_ref
);
7268 if (caf_attr
.codimension
)
7271 is_coarray_array
= caf_attr
.dimension
|| !comp_ref
7272 || caf_attr
.coarray_comp
;
7274 if (flag_coarray
== GFC_FCOARRAY_LIB
)
7275 /* When the expression to deallocate is referencing a
7276 component, then only deallocate it, but do not
7278 caf_mode
= GFC_STRUCTURE_CAF_MODE_IN_COARRAY
7279 | (comp_ref
&& !caf_attr
.coarray_comp
7280 ? GFC_STRUCTURE_CAF_MODE_DEALLOC_ONLY
: 0);
7284 if (expr
->rank
|| is_coarray_array
)
7288 if (gfc_bt_struct (expr
->ts
.type
)
7289 && expr
->ts
.u
.derived
->attr
.alloc_comp
7290 && !gfc_is_finalizable (expr
->ts
.u
.derived
, NULL
))
7292 gfc_ref
*last
= NULL
;
7294 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
7295 if (ref
->type
== REF_COMPONENT
)
7298 /* Do not deallocate the components of a derived type
7299 ultimate pointer component. */
7300 if (!(last
&& last
->u
.c
.component
->attr
.pointer
)
7301 && !(!last
&& expr
->symtree
->n
.sym
->attr
.pointer
))
7303 if (is_coarray
&& expr
->rank
== 0
7304 && (!last
|| !last
->u
.c
.component
->attr
.dimension
)
7305 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se
.expr
)))
7307 /* Add the ref to the data member only, when this is not
7308 a regular array or deallocate_alloc_comp will try to
7310 tmp
= gfc_conv_descriptor_data_get (se
.expr
);
7314 tmp
= gfc_deallocate_alloc_comp (expr
->ts
.u
.derived
, tmp
,
7315 expr
->rank
, caf_mode
);
7316 gfc_add_expr_to_block (&se
.pre
, tmp
);
7320 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se
.expr
)))
7322 gfc_coarray_deregtype caf_dtype
;
7325 caf_dtype
= gfc_caf_is_dealloc_only (caf_mode
)
7326 ? GFC_CAF_COARRAY_DEALLOCATE_ONLY
7327 : GFC_CAF_COARRAY_DEREGISTER
;
7329 caf_dtype
= GFC_CAF_COARRAY_NOCOARRAY
;
7330 tmp
= gfc_deallocate_with_status (se
.expr
, pstat
, errmsg
, errlen
,
7331 label_finish
, false, expr
,
7333 gfc_add_expr_to_block (&se
.pre
, tmp
);
7335 else if (TREE_CODE (se
.expr
) == COMPONENT_REF
7336 && TREE_CODE (TREE_TYPE (se
.expr
)) == ARRAY_TYPE
7337 && TREE_CODE (TREE_TYPE (TREE_TYPE (se
.expr
)))
7340 /* class.c(finalize_component) generates these, when a
7341 finalizable entity has a non-allocatable derived type array
7342 component, which has allocatable components. Obtain the
7343 derived type of the array and deallocate the allocatable
7345 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
7347 if (ref
->u
.c
.component
->attr
.dimension
7348 && ref
->u
.c
.component
->ts
.type
== BT_DERIVED
)
7352 if (ref
&& ref
->u
.c
.component
->ts
.u
.derived
->attr
.alloc_comp
7353 && !gfc_is_finalizable (ref
->u
.c
.component
->ts
.u
.derived
,
7356 tmp
= gfc_deallocate_alloc_comp
7357 (ref
->u
.c
.component
->ts
.u
.derived
,
7358 se
.expr
, expr
->rank
);
7359 gfc_add_expr_to_block (&se
.pre
, tmp
);
7363 if (al
->expr
->ts
.type
== BT_CLASS
)
7365 gfc_reset_vptr (&se
.pre
, al
->expr
);
7366 if (UNLIMITED_POLY (al
->expr
)
7367 || (al
->expr
->ts
.type
== BT_DERIVED
7368 && al
->expr
->ts
.u
.derived
->attr
.unlimited_polymorphic
))
7369 /* Clear _len, too. */
7370 gfc_reset_len (&se
.pre
, al
->expr
);
7375 tmp
= gfc_deallocate_scalar_with_status (se
.expr
, pstat
, label_finish
,
7377 al
->expr
->ts
, is_coarray
);
7378 gfc_add_expr_to_block (&se
.pre
, tmp
);
7380 /* Set to zero after deallocation. */
7381 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
, void_type_node
,
7383 build_int_cst (TREE_TYPE (se
.expr
), 0));
7384 gfc_add_expr_to_block (&se
.pre
, tmp
);
7386 if (al
->expr
->ts
.type
== BT_CLASS
)
7388 gfc_reset_vptr (&se
.pre
, al
->expr
);
7389 if (UNLIMITED_POLY (al
->expr
)
7390 || (al
->expr
->ts
.type
== BT_DERIVED
7391 && al
->expr
->ts
.u
.derived
->attr
.unlimited_polymorphic
))
7392 /* Clear _len, too. */
7393 gfc_reset_len (&se
.pre
, al
->expr
);
7401 cond
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
, stat
,
7402 build_int_cst (TREE_TYPE (stat
), 0));
7403 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
7404 gfc_unlikely (cond
, PRED_FORTRAN_FAIL_ALLOC
),
7405 build1_v (GOTO_EXPR
, label_errmsg
),
7406 build_empty_stmt (input_location
));
7407 gfc_add_expr_to_block (&se
.pre
, tmp
);
7410 tmp
= gfc_finish_block (&se
.pre
);
7411 gfc_add_expr_to_block (&block
, tmp
);
7412 gfc_free_expr (expr
);
7417 tmp
= build1_v (LABEL_EXPR
, label_errmsg
);
7418 gfc_add_expr_to_block (&block
, tmp
);
7421 /* Set ERRMSG - only needed if STAT is available. */
7422 if (code
->expr1
&& code
->expr2
)
7424 const char *msg
= "Attempt to deallocate an unallocated object";
7425 stmtblock_t errmsg_block
;
7426 tree errmsg_str
, slen
, dlen
, cond
;
7428 gfc_init_block (&errmsg_block
);
7430 errmsg_str
= gfc_create_var (pchar_type_node
, "ERRMSG");
7431 gfc_add_modify (&errmsg_block
, errmsg_str
,
7432 gfc_build_addr_expr (pchar_type_node
,
7433 gfc_build_localized_cstring_const (msg
)));
7434 slen
= build_int_cst (gfc_charlen_type_node
, strlen (msg
));
7435 dlen
= gfc_get_expr_charlen (code
->expr2
);
7437 gfc_trans_string_copy (&errmsg_block
, dlen
, errmsg
, code
->expr2
->ts
.kind
,
7438 slen
, errmsg_str
, gfc_default_character_kind
);
7439 tmp
= gfc_finish_block (&errmsg_block
);
7441 cond
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
, stat
,
7442 build_int_cst (TREE_TYPE (stat
), 0));
7443 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
7444 gfc_unlikely (cond
, PRED_FORTRAN_FAIL_ALLOC
), tmp
,
7445 build_empty_stmt (input_location
));
7447 gfc_add_expr_to_block (&block
, tmp
);
7450 if (code
->expr1
&& TREE_USED (label_finish
))
7452 tmp
= build1_v (LABEL_EXPR
, label_finish
);
7453 gfc_add_expr_to_block (&block
, tmp
);
7459 gfc_init_se (&se
, NULL
);
7460 gfc_conv_expr_lhs (&se
, code
->expr1
);
7461 tmp
= convert (TREE_TYPE (se
.expr
), stat
);
7462 gfc_add_modify (&block
, se
.expr
, tmp
);
7465 return gfc_finish_block (&block
);
7468 #include "gt-fortran-trans-stmt.h"