1 /* Statement translation -- generate GCC trees from gfc_code.
2 Copyright (C) 2002-2019 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
;
202 for (loopss
= &(se
->loop
->ss
); *loopss
!= gfc_ss_terminator
;
203 loopss
= &((*loopss
)->loop_chain
))
204 if (*loopss
== old_ss
)
206 gcc_assert (*loopss
!= gfc_ss_terminator
);
209 new_ss
->loop_chain
= old_ss
->loop_chain
;
210 new_ss
->loop
= old_ss
->loop
;
212 gfc_free_ss (old_ss
);
216 /* Check for dependencies between INTENT(IN) and INTENT(OUT) arguments of
217 elemental subroutines. Make temporaries for output arguments if any such
218 dependencies are found. Output arguments are chosen because internal_unpack
219 can be used, as is, to copy the result back to the variable. */
221 gfc_conv_elemental_dependencies (gfc_se
* se
, gfc_se
* loopse
,
222 gfc_symbol
* sym
, gfc_actual_arglist
* arg
,
223 gfc_dep_check check_variable
)
225 gfc_actual_arglist
*arg0
;
227 gfc_formal_arglist
*formal
;
235 if (loopse
->ss
== NULL
)
240 formal
= gfc_sym_get_dummy_args (sym
);
242 /* Loop over all the arguments testing for dependencies. */
243 for (; arg
!= NULL
; arg
= arg
->next
, formal
= formal
? formal
->next
: NULL
)
249 /* Obtain the info structure for the current argument. */
250 for (ss
= loopse
->ss
; ss
&& ss
!= gfc_ss_terminator
; ss
= ss
->next
)
251 if (ss
->info
->expr
== e
)
254 /* If there is a dependency, create a temporary and use it
255 instead of the variable. */
256 fsym
= formal
? formal
->sym
: NULL
;
257 if (e
->expr_type
== EXPR_VARIABLE
259 && fsym
->attr
.intent
!= INTENT_IN
260 && gfc_check_fncall_dependency (e
, fsym
->attr
.intent
,
261 sym
, arg0
, check_variable
))
263 tree initial
, temptype
;
264 stmtblock_t temp_post
;
267 tmp_ss
= gfc_get_array_ss (gfc_ss_terminator
, NULL
, ss
->dimen
,
269 gfc_mark_ss_chain_used (tmp_ss
, 1);
270 tmp_ss
->info
->expr
= ss
->info
->expr
;
271 replace_ss (loopse
, ss
, tmp_ss
);
273 /* Obtain the argument descriptor for unpacking. */
274 gfc_init_se (&parmse
, NULL
);
275 parmse
.want_pointer
= 1;
276 gfc_conv_expr_descriptor (&parmse
, e
);
277 gfc_add_block_to_block (&se
->pre
, &parmse
.pre
);
279 /* If we've got INTENT(INOUT) or a derived type with INTENT(OUT),
280 initialize the array temporary with a copy of the values. */
281 if (fsym
->attr
.intent
== INTENT_INOUT
282 || (fsym
->ts
.type
==BT_DERIVED
283 && fsym
->attr
.intent
== INTENT_OUT
))
284 initial
= parmse
.expr
;
285 /* For class expressions, we always initialize with the copy of
287 else if (e
->ts
.type
== BT_CLASS
)
288 initial
= parmse
.expr
;
292 if (e
->ts
.type
!= BT_CLASS
)
294 /* Find the type of the temporary to create; we don't use the type
295 of e itself as this breaks for subcomponent-references in e
296 (where the type of e is that of the final reference, but
297 parmse.expr's type corresponds to the full derived-type). */
298 /* TODO: Fix this somehow so we don't need a temporary of the whole
299 array but instead only the components referenced. */
300 temptype
= TREE_TYPE (parmse
.expr
); /* Pointer to descriptor. */
301 gcc_assert (TREE_CODE (temptype
) == POINTER_TYPE
);
302 temptype
= TREE_TYPE (temptype
);
303 temptype
= gfc_get_element_type (temptype
);
307 /* For class arrays signal that the size of the dynamic type has to
308 be obtained from the vtable, using the 'initial' expression. */
309 temptype
= NULL_TREE
;
311 /* Generate the temporary. Cleaning up the temporary should be the
312 very last thing done, so we add the code to a new block and add it
313 to se->post as last instructions. */
314 size
= gfc_create_var (gfc_array_index_type
, NULL
);
315 data
= gfc_create_var (pvoid_type_node
, NULL
);
316 gfc_init_block (&temp_post
);
317 tmp
= gfc_trans_create_temp_array (&se
->pre
, &temp_post
, tmp_ss
,
318 temptype
, initial
, false, true,
319 false, &arg
->expr
->where
);
320 gfc_add_modify (&se
->pre
, size
, tmp
);
321 tmp
= fold_convert (pvoid_type_node
, tmp_ss
->info
->data
.array
.data
);
322 gfc_add_modify (&se
->pre
, data
, tmp
);
324 /* Update other ss' delta. */
325 gfc_set_delta (loopse
->loop
);
327 /* Copy the result back using unpack..... */
328 if (e
->ts
.type
!= BT_CLASS
)
329 tmp
= build_call_expr_loc (input_location
,
330 gfor_fndecl_in_unpack
, 2, parmse
.expr
, data
);
333 /* ... except for class results where the copy is
335 tmp
= build_fold_indirect_ref_loc (input_location
, parmse
.expr
);
336 tmp
= gfc_conv_descriptor_data_get (tmp
);
337 tmp
= build_call_expr_loc (input_location
,
338 builtin_decl_explicit (BUILT_IN_MEMCPY
),
340 fold_convert (size_type_node
, size
));
342 gfc_add_expr_to_block (&se
->post
, tmp
);
344 /* parmse.pre is already added above. */
345 gfc_add_block_to_block (&se
->post
, &parmse
.post
);
346 gfc_add_block_to_block (&se
->post
, &temp_post
);
352 /* Get the interface symbol for the procedure corresponding to the given call.
353 We can't get the procedure symbol directly as we have to handle the case
354 of (deferred) type-bound procedures. */
357 get_proc_ifc_for_call (gfc_code
*c
)
361 gcc_assert (c
->op
== EXEC_ASSIGN_CALL
|| c
->op
== EXEC_CALL
);
363 sym
= gfc_get_proc_ifc_for_expr (c
->expr1
);
365 /* Fall back/last resort try. */
367 sym
= c
->resolved_sym
;
373 /* Translate the CALL statement. Builds a call to an F95 subroutine. */
376 gfc_trans_call (gfc_code
* code
, bool dependency_check
,
377 tree mask
, tree count1
, bool invert
)
381 int has_alternate_specifier
;
382 gfc_dep_check check_variable
;
383 tree index
= NULL_TREE
;
384 tree maskexpr
= NULL_TREE
;
387 /* A CALL starts a new block because the actual arguments may have to
388 be evaluated first. */
389 gfc_init_se (&se
, NULL
);
390 gfc_start_block (&se
.pre
);
392 gcc_assert (code
->resolved_sym
);
394 ss
= gfc_ss_terminator
;
395 if (code
->resolved_sym
->attr
.elemental
)
396 ss
= gfc_walk_elemental_function_args (ss
, code
->ext
.actual
,
397 get_proc_ifc_for_call (code
),
400 /* Is not an elemental subroutine call with array valued arguments. */
401 if (ss
== gfc_ss_terminator
)
404 /* Translate the call. */
405 has_alternate_specifier
406 = gfc_conv_procedure_call (&se
, code
->resolved_sym
, code
->ext
.actual
,
409 /* A subroutine without side-effect, by definition, does nothing! */
410 TREE_SIDE_EFFECTS (se
.expr
) = 1;
412 /* Chain the pieces together and return the block. */
413 if (has_alternate_specifier
)
415 gfc_code
*select_code
;
417 select_code
= code
->next
;
418 gcc_assert(select_code
->op
== EXEC_SELECT
);
419 sym
= select_code
->expr1
->symtree
->n
.sym
;
420 se
.expr
= convert (gfc_typenode_for_spec (&sym
->ts
), se
.expr
);
421 if (sym
->backend_decl
== NULL
)
422 sym
->backend_decl
= gfc_get_symbol_decl (sym
);
423 gfc_add_modify (&se
.pre
, sym
->backend_decl
, se
.expr
);
426 gfc_add_expr_to_block (&se
.pre
, se
.expr
);
428 gfc_add_block_to_block (&se
.pre
, &se
.post
);
433 /* An elemental subroutine call with array valued arguments has
441 /* gfc_walk_elemental_function_args renders the ss chain in the
442 reverse order to the actual argument order. */
443 ss
= gfc_reverse_ss (ss
);
445 /* Initialize the loop. */
446 gfc_init_se (&loopse
, NULL
);
447 gfc_init_loopinfo (&loop
);
448 gfc_add_ss_to_loop (&loop
, ss
);
450 gfc_conv_ss_startstride (&loop
);
451 /* TODO: gfc_conv_loop_setup generates a temporary for vector
452 subscripts. This could be prevented in the elemental case
453 as temporaries are handled separatedly
454 (below in gfc_conv_elemental_dependencies). */
456 gfc_conv_loop_setup (&loop
, &code
->expr1
->where
);
458 gfc_conv_loop_setup (&loop
, &code
->loc
);
460 gfc_mark_ss_chain_used (ss
, 1);
462 /* Convert the arguments, checking for dependencies. */
463 gfc_copy_loopinfo_to_se (&loopse
, &loop
);
466 /* For operator assignment, do dependency checking. */
467 if (dependency_check
)
468 check_variable
= ELEM_CHECK_VARIABLE
;
470 check_variable
= ELEM_DONT_CHECK_VARIABLE
;
472 gfc_init_se (&depse
, NULL
);
473 gfc_conv_elemental_dependencies (&depse
, &loopse
, code
->resolved_sym
,
474 code
->ext
.actual
, check_variable
);
476 gfc_add_block_to_block (&loop
.pre
, &depse
.pre
);
477 gfc_add_block_to_block (&loop
.post
, &depse
.post
);
479 /* Generate the loop body. */
480 gfc_start_scalarized_body (&loop
, &body
);
481 gfc_init_block (&block
);
485 /* Form the mask expression according to the mask. */
487 maskexpr
= gfc_build_array_ref (mask
, index
, NULL
);
489 maskexpr
= fold_build1_loc (input_location
, TRUTH_NOT_EXPR
,
490 TREE_TYPE (maskexpr
), maskexpr
);
493 /* Add the subroutine call to the block. */
494 gfc_conv_procedure_call (&loopse
, code
->resolved_sym
,
495 code
->ext
.actual
, code
->expr1
,
500 tmp
= build3_v (COND_EXPR
, maskexpr
, loopse
.expr
,
501 build_empty_stmt (input_location
));
502 gfc_add_expr_to_block (&loopse
.pre
, tmp
);
503 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
504 gfc_array_index_type
,
505 count1
, gfc_index_one_node
);
506 gfc_add_modify (&loopse
.pre
, count1
, tmp
);
509 gfc_add_expr_to_block (&loopse
.pre
, loopse
.expr
);
511 gfc_add_block_to_block (&block
, &loopse
.pre
);
512 gfc_add_block_to_block (&block
, &loopse
.post
);
514 /* Finish up the loop block and the loop. */
515 gfc_add_expr_to_block (&body
, gfc_finish_block (&block
));
516 gfc_trans_scalarizing_loops (&loop
, &body
);
517 gfc_add_block_to_block (&se
.pre
, &loop
.pre
);
518 gfc_add_block_to_block (&se
.pre
, &loop
.post
);
519 gfc_add_block_to_block (&se
.pre
, &se
.post
);
520 gfc_cleanup_loop (&loop
);
523 return gfc_finish_block (&se
.pre
);
527 /* Translate the RETURN statement. */
530 gfc_trans_return (gfc_code
* code
)
538 /* If code->expr is not NULL, this return statement must appear
539 in a subroutine and current_fake_result_decl has already
542 result
= gfc_get_fake_result_decl (NULL
, 0);
546 "An alternate return at %L without a * dummy argument",
547 &code
->expr1
->where
);
548 return gfc_generate_return ();
551 /* Start a new block for this statement. */
552 gfc_init_se (&se
, NULL
);
553 gfc_start_block (&se
.pre
);
555 gfc_conv_expr (&se
, code
->expr1
);
557 /* Note that the actually returned expression is a simple value and
558 does not depend on any pointers or such; thus we can clean-up with
559 se.post before returning. */
560 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
, TREE_TYPE (result
),
561 result
, fold_convert (TREE_TYPE (result
),
563 gfc_add_expr_to_block (&se
.pre
, tmp
);
564 gfc_add_block_to_block (&se
.pre
, &se
.post
);
566 tmp
= gfc_generate_return ();
567 gfc_add_expr_to_block (&se
.pre
, tmp
);
568 return gfc_finish_block (&se
.pre
);
571 return gfc_generate_return ();
575 /* Translate the PAUSE statement. We have to translate this statement
576 to a runtime library call. */
579 gfc_trans_pause (gfc_code
* code
)
581 tree gfc_int8_type_node
= gfc_get_int_type (8);
585 /* Start a new block for this statement. */
586 gfc_init_se (&se
, NULL
);
587 gfc_start_block (&se
.pre
);
590 if (code
->expr1
== NULL
)
592 tmp
= build_int_cst (size_type_node
, 0);
593 tmp
= build_call_expr_loc (input_location
,
594 gfor_fndecl_pause_string
, 2,
595 build_int_cst (pchar_type_node
, 0), tmp
);
597 else if (code
->expr1
->ts
.type
== BT_INTEGER
)
599 gfc_conv_expr (&se
, code
->expr1
);
600 tmp
= build_call_expr_loc (input_location
,
601 gfor_fndecl_pause_numeric
, 1,
602 fold_convert (gfc_int8_type_node
, se
.expr
));
606 gfc_conv_expr_reference (&se
, code
->expr1
);
607 tmp
= build_call_expr_loc (input_location
,
608 gfor_fndecl_pause_string
, 2,
609 se
.expr
, fold_convert (size_type_node
,
613 gfc_add_expr_to_block (&se
.pre
, tmp
);
615 gfc_add_block_to_block (&se
.pre
, &se
.post
);
617 return gfc_finish_block (&se
.pre
);
621 /* Translate the STOP statement. We have to translate this statement
622 to a runtime library call. */
625 gfc_trans_stop (gfc_code
*code
, bool error_stop
)
630 /* Start a new block for this statement. */
631 gfc_init_se (&se
, NULL
);
632 gfc_start_block (&se
.pre
);
634 if (code
->expr1
== NULL
)
636 tmp
= build_int_cst (size_type_node
, 0);
637 tmp
= build_call_expr_loc (input_location
,
639 ? (flag_coarray
== GFC_FCOARRAY_LIB
640 ? gfor_fndecl_caf_error_stop_str
641 : gfor_fndecl_error_stop_string
)
642 : (flag_coarray
== GFC_FCOARRAY_LIB
643 ? gfor_fndecl_caf_stop_str
644 : gfor_fndecl_stop_string
),
645 3, build_int_cst (pchar_type_node
, 0), tmp
,
648 else if (code
->expr1
->ts
.type
== BT_INTEGER
)
650 gfc_conv_expr (&se
, code
->expr1
);
651 tmp
= build_call_expr_loc (input_location
,
653 ? (flag_coarray
== GFC_FCOARRAY_LIB
654 ? gfor_fndecl_caf_error_stop
655 : gfor_fndecl_error_stop_numeric
)
656 : (flag_coarray
== GFC_FCOARRAY_LIB
657 ? gfor_fndecl_caf_stop_numeric
658 : gfor_fndecl_stop_numeric
), 2,
659 fold_convert (integer_type_node
, se
.expr
),
664 gfc_conv_expr_reference (&se
, code
->expr1
);
665 tmp
= build_call_expr_loc (input_location
,
667 ? (flag_coarray
== GFC_FCOARRAY_LIB
668 ? gfor_fndecl_caf_error_stop_str
669 : gfor_fndecl_error_stop_string
)
670 : (flag_coarray
== GFC_FCOARRAY_LIB
671 ? gfor_fndecl_caf_stop_str
672 : gfor_fndecl_stop_string
),
673 3, se
.expr
, fold_convert (size_type_node
,
678 gfc_add_expr_to_block (&se
.pre
, tmp
);
680 gfc_add_block_to_block (&se
.pre
, &se
.post
);
682 return gfc_finish_block (&se
.pre
);
685 /* Translate the FAIL IMAGE statement. */
688 gfc_trans_fail_image (gfc_code
*code ATTRIBUTE_UNUSED
)
690 if (flag_coarray
== GFC_FCOARRAY_LIB
)
691 return build_call_expr_loc (input_location
,
692 gfor_fndecl_caf_fail_image
, 1,
693 build_int_cst (pchar_type_node
, 0));
696 const char *name
= gfc_get_string (PREFIX ("exit_i%d"), 4);
697 gfc_symbol
*exsym
= gfc_get_intrinsic_sub_symbol (name
);
698 tree tmp
= gfc_get_symbol_decl (exsym
);
699 return build_call_expr_loc (input_location
, tmp
, 1, integer_zero_node
);
703 /* Translate the FORM TEAM statement. */
706 gfc_trans_form_team (gfc_code
*code
)
708 if (flag_coarray
== GFC_FCOARRAY_LIB
)
711 gfc_se argse1
, argse2
;
712 tree team_id
, team_type
, tmp
;
714 gfc_init_se (&se
, NULL
);
715 gfc_init_se (&argse1
, NULL
);
716 gfc_init_se (&argse2
, NULL
);
717 gfc_start_block (&se
.pre
);
719 gfc_conv_expr_val (&argse1
, code
->expr1
);
720 gfc_conv_expr_val (&argse2
, code
->expr2
);
721 team_id
= fold_convert (integer_type_node
, argse1
.expr
);
722 team_type
= gfc_build_addr_expr (ppvoid_type_node
, argse2
.expr
);
724 gfc_add_block_to_block (&se
.pre
, &argse1
.pre
);
725 gfc_add_block_to_block (&se
.pre
, &argse2
.pre
);
726 tmp
= build_call_expr_loc (input_location
,
727 gfor_fndecl_caf_form_team
, 3,
729 build_int_cst (integer_type_node
, 0));
730 gfc_add_expr_to_block (&se
.pre
, tmp
);
731 gfc_add_block_to_block (&se
.pre
, &argse1
.post
);
732 gfc_add_block_to_block (&se
.pre
, &argse2
.post
);
733 return gfc_finish_block (&se
.pre
);
737 const char *name
= gfc_get_string (PREFIX ("exit_i%d"), 4);
738 gfc_symbol
*exsym
= gfc_get_intrinsic_sub_symbol (name
);
739 tree tmp
= gfc_get_symbol_decl (exsym
);
740 return build_call_expr_loc (input_location
, tmp
, 1, integer_zero_node
);
744 /* Translate the CHANGE TEAM statement. */
747 gfc_trans_change_team (gfc_code
*code
)
749 if (flag_coarray
== GFC_FCOARRAY_LIB
)
754 gfc_init_se (&argse
, NULL
);
755 gfc_conv_expr_val (&argse
, code
->expr1
);
756 team_type
= gfc_build_addr_expr (ppvoid_type_node
, argse
.expr
);
758 tmp
= build_call_expr_loc (input_location
,
759 gfor_fndecl_caf_change_team
, 2, team_type
,
760 build_int_cst (integer_type_node
, 0));
761 gfc_add_expr_to_block (&argse
.pre
, tmp
);
762 gfc_add_block_to_block (&argse
.pre
, &argse
.post
);
763 return gfc_finish_block (&argse
.pre
);
767 const char *name
= gfc_get_string (PREFIX ("exit_i%d"), 4);
768 gfc_symbol
*exsym
= gfc_get_intrinsic_sub_symbol (name
);
769 tree tmp
= gfc_get_symbol_decl (exsym
);
770 return build_call_expr_loc (input_location
, tmp
, 1, integer_zero_node
);
774 /* Translate the END TEAM statement. */
777 gfc_trans_end_team (gfc_code
*code ATTRIBUTE_UNUSED
)
779 if (flag_coarray
== GFC_FCOARRAY_LIB
)
781 return build_call_expr_loc (input_location
,
782 gfor_fndecl_caf_end_team
, 1,
783 build_int_cst (pchar_type_node
, 0));
787 const char *name
= gfc_get_string (PREFIX ("exit_i%d"), 4);
788 gfc_symbol
*exsym
= gfc_get_intrinsic_sub_symbol (name
);
789 tree tmp
= gfc_get_symbol_decl (exsym
);
790 return build_call_expr_loc (input_location
, tmp
, 1, integer_zero_node
);
794 /* Translate the SYNC TEAM statement. */
797 gfc_trans_sync_team (gfc_code
*code
)
799 if (flag_coarray
== GFC_FCOARRAY_LIB
)
804 gfc_init_se (&argse
, NULL
);
805 gfc_conv_expr_val (&argse
, code
->expr1
);
806 team_type
= gfc_build_addr_expr (ppvoid_type_node
, argse
.expr
);
808 tmp
= build_call_expr_loc (input_location
,
809 gfor_fndecl_caf_sync_team
, 2,
811 build_int_cst (integer_type_node
, 0));
812 gfc_add_expr_to_block (&argse
.pre
, tmp
);
813 gfc_add_block_to_block (&argse
.pre
, &argse
.post
);
814 return gfc_finish_block (&argse
.pre
);
818 const char *name
= gfc_get_string (PREFIX ("exit_i%d"), 4);
819 gfc_symbol
*exsym
= gfc_get_intrinsic_sub_symbol (name
);
820 tree tmp
= gfc_get_symbol_decl (exsym
);
821 return build_call_expr_loc (input_location
, tmp
, 1, integer_zero_node
);
826 gfc_trans_lock_unlock (gfc_code
*code
, gfc_exec_op op
)
829 tree stat
= NULL_TREE
, stat2
= NULL_TREE
;
830 tree lock_acquired
= NULL_TREE
, lock_acquired2
= NULL_TREE
;
832 /* Short cut: For single images without STAT= or LOCK_ACQUIRED
833 return early. (ERRMSG= is always untouched for -fcoarray=single.) */
834 if (!code
->expr2
&& !code
->expr4
&& flag_coarray
!= GFC_FCOARRAY_LIB
)
839 gcc_assert (code
->expr2
->expr_type
== EXPR_VARIABLE
);
840 gfc_init_se (&argse
, NULL
);
841 gfc_conv_expr_val (&argse
, code
->expr2
);
844 else if (flag_coarray
== GFC_FCOARRAY_LIB
)
845 stat
= null_pointer_node
;
849 gcc_assert (code
->expr4
->expr_type
== EXPR_VARIABLE
);
850 gfc_init_se (&argse
, NULL
);
851 gfc_conv_expr_val (&argse
, code
->expr4
);
852 lock_acquired
= argse
.expr
;
854 else if (flag_coarray
== GFC_FCOARRAY_LIB
)
855 lock_acquired
= null_pointer_node
;
857 gfc_start_block (&se
.pre
);
858 if (flag_coarray
== GFC_FCOARRAY_LIB
)
860 tree tmp
, token
, image_index
, errmsg
, errmsg_len
;
861 tree index
= build_zero_cst (gfc_array_index_type
);
862 tree caf_decl
= gfc_get_tree_for_caf_expr (code
->expr1
);
864 if (code
->expr1
->symtree
->n
.sym
->ts
.type
!= BT_DERIVED
865 || code
->expr1
->symtree
->n
.sym
->ts
.u
.derived
->from_intmod
866 != INTMOD_ISO_FORTRAN_ENV
867 || code
->expr1
->symtree
->n
.sym
->ts
.u
.derived
->intmod_sym_id
868 != ISOFORTRAN_LOCK_TYPE
)
870 gfc_error ("Sorry, the lock component of derived type at %L is not "
871 "yet supported", &code
->expr1
->where
);
875 gfc_get_caf_token_offset (&se
, &token
, NULL
, caf_decl
, NULL_TREE
,
878 if (gfc_is_coindexed (code
->expr1
))
879 image_index
= gfc_caf_get_image_index (&se
.pre
, code
->expr1
, caf_decl
);
881 image_index
= integer_zero_node
;
883 /* For arrays, obtain the array index. */
884 if (gfc_expr_attr (code
->expr1
).dimension
)
886 tree desc
, tmp
, extent
, lbound
, ubound
;
887 gfc_array_ref
*ar
, ar2
;
890 /* TODO: Extend this, once DT components are supported. */
891 ar
= &code
->expr1
->ref
->u
.ar
;
893 memset (ar
, '\0', sizeof (*ar
));
897 gfc_init_se (&argse
, NULL
);
898 argse
.descriptor_only
= 1;
899 gfc_conv_expr_descriptor (&argse
, code
->expr1
);
900 gfc_add_block_to_block (&se
.pre
, &argse
.pre
);
904 extent
= build_one_cst (gfc_array_index_type
);
905 for (i
= 0; i
< ar
->dimen
; i
++)
907 gfc_init_se (&argse
, NULL
);
908 gfc_conv_expr_type (&argse
, ar
->start
[i
], gfc_array_index_type
);
909 gfc_add_block_to_block (&argse
.pre
, &argse
.pre
);
910 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[i
]);
911 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
912 TREE_TYPE (lbound
), argse
.expr
, lbound
);
913 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
914 TREE_TYPE (tmp
), extent
, tmp
);
915 index
= fold_build2_loc (input_location
, PLUS_EXPR
,
916 TREE_TYPE (tmp
), index
, tmp
);
917 if (i
< ar
->dimen
- 1)
919 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[i
]);
920 tmp
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
921 extent
= fold_build2_loc (input_location
, MULT_EXPR
,
922 TREE_TYPE (tmp
), extent
, tmp
);
930 gfc_init_se (&argse
, NULL
);
931 argse
.want_pointer
= 1;
932 gfc_conv_expr (&argse
, code
->expr3
);
933 gfc_add_block_to_block (&se
.pre
, &argse
.pre
);
935 errmsg_len
= fold_convert (size_type_node
, argse
.string_length
);
939 errmsg
= null_pointer_node
;
940 errmsg_len
= build_zero_cst (size_type_node
);
943 if (stat
!= null_pointer_node
&& TREE_TYPE (stat
) != integer_type_node
)
946 stat
= gfc_create_var (integer_type_node
, "stat");
949 if (lock_acquired
!= null_pointer_node
950 && TREE_TYPE (lock_acquired
) != integer_type_node
)
952 lock_acquired2
= lock_acquired
;
953 lock_acquired
= gfc_create_var (integer_type_node
, "acquired");
956 index
= fold_convert (size_type_node
, index
);
958 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_lock
, 7,
959 token
, index
, image_index
,
960 lock_acquired
!= null_pointer_node
961 ? gfc_build_addr_expr (NULL
, lock_acquired
)
963 stat
!= null_pointer_node
964 ? gfc_build_addr_expr (NULL
, stat
) : stat
,
967 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_unlock
, 6,
968 token
, index
, image_index
,
969 stat
!= null_pointer_node
970 ? gfc_build_addr_expr (NULL
, stat
) : stat
,
972 gfc_add_expr_to_block (&se
.pre
, tmp
);
974 /* It guarantees memory consistency within the same segment */
975 tmp
= gfc_build_string_const (strlen ("memory")+1, "memory"),
976 tmp
= build5_loc (input_location
, ASM_EXPR
, void_type_node
,
977 gfc_build_string_const (1, ""), NULL_TREE
, NULL_TREE
,
978 tree_cons (NULL_TREE
, tmp
, NULL_TREE
), NULL_TREE
);
979 ASM_VOLATILE_P (tmp
) = 1;
981 gfc_add_expr_to_block (&se
.pre
, tmp
);
983 if (stat2
!= NULL_TREE
)
984 gfc_add_modify (&se
.pre
, stat2
,
985 fold_convert (TREE_TYPE (stat2
), stat
));
987 if (lock_acquired2
!= NULL_TREE
)
988 gfc_add_modify (&se
.pre
, lock_acquired2
,
989 fold_convert (TREE_TYPE (lock_acquired2
),
992 return gfc_finish_block (&se
.pre
);
995 if (stat
!= NULL_TREE
)
996 gfc_add_modify (&se
.pre
, stat
, build_int_cst (TREE_TYPE (stat
), 0));
998 if (lock_acquired
!= NULL_TREE
)
999 gfc_add_modify (&se
.pre
, lock_acquired
,
1000 fold_convert (TREE_TYPE (lock_acquired
),
1001 boolean_true_node
));
1003 return gfc_finish_block (&se
.pre
);
1007 gfc_trans_event_post_wait (gfc_code
*code
, gfc_exec_op op
)
1010 tree stat
= NULL_TREE
, stat2
= NULL_TREE
;
1011 tree until_count
= NULL_TREE
;
1015 gcc_assert (code
->expr2
->expr_type
== EXPR_VARIABLE
);
1016 gfc_init_se (&argse
, NULL
);
1017 gfc_conv_expr_val (&argse
, code
->expr2
);
1020 else if (flag_coarray
== GFC_FCOARRAY_LIB
)
1021 stat
= null_pointer_node
;
1025 gfc_init_se (&argse
, NULL
);
1026 gfc_conv_expr_val (&argse
, code
->expr4
);
1027 until_count
= fold_convert (integer_type_node
, argse
.expr
);
1030 until_count
= integer_one_node
;
1032 if (flag_coarray
!= GFC_FCOARRAY_LIB
)
1034 gfc_start_block (&se
.pre
);
1035 gfc_init_se (&argse
, NULL
);
1036 gfc_conv_expr_val (&argse
, code
->expr1
);
1038 if (op
== EXEC_EVENT_POST
)
1039 gfc_add_modify (&se
.pre
, argse
.expr
,
1040 fold_build2_loc (input_location
, PLUS_EXPR
,
1041 TREE_TYPE (argse
.expr
), argse
.expr
,
1042 build_int_cst (TREE_TYPE (argse
.expr
), 1)));
1044 gfc_add_modify (&se
.pre
, argse
.expr
,
1045 fold_build2_loc (input_location
, MINUS_EXPR
,
1046 TREE_TYPE (argse
.expr
), argse
.expr
,
1047 fold_convert (TREE_TYPE (argse
.expr
),
1049 if (stat
!= NULL_TREE
)
1050 gfc_add_modify (&se
.pre
, stat
, build_int_cst (TREE_TYPE (stat
), 0));
1052 return gfc_finish_block (&se
.pre
);
1055 gfc_start_block (&se
.pre
);
1056 tree tmp
, token
, image_index
, errmsg
, errmsg_len
;
1057 tree index
= build_zero_cst (gfc_array_index_type
);
1058 tree caf_decl
= gfc_get_tree_for_caf_expr (code
->expr1
);
1060 if (code
->expr1
->symtree
->n
.sym
->ts
.type
!= BT_DERIVED
1061 || code
->expr1
->symtree
->n
.sym
->ts
.u
.derived
->from_intmod
1062 != INTMOD_ISO_FORTRAN_ENV
1063 || code
->expr1
->symtree
->n
.sym
->ts
.u
.derived
->intmod_sym_id
1064 != ISOFORTRAN_EVENT_TYPE
)
1066 gfc_error ("Sorry, the event component of derived type at %L is not "
1067 "yet supported", &code
->expr1
->where
);
1071 gfc_init_se (&argse
, NULL
);
1072 gfc_get_caf_token_offset (&argse
, &token
, NULL
, caf_decl
, NULL_TREE
,
1074 gfc_add_block_to_block (&se
.pre
, &argse
.pre
);
1076 if (gfc_is_coindexed (code
->expr1
))
1077 image_index
= gfc_caf_get_image_index (&se
.pre
, code
->expr1
, caf_decl
);
1079 image_index
= integer_zero_node
;
1081 /* For arrays, obtain the array index. */
1082 if (gfc_expr_attr (code
->expr1
).dimension
)
1084 tree desc
, tmp
, extent
, lbound
, ubound
;
1085 gfc_array_ref
*ar
, ar2
;
1088 /* TODO: Extend this, once DT components are supported. */
1089 ar
= &code
->expr1
->ref
->u
.ar
;
1091 memset (ar
, '\0', sizeof (*ar
));
1095 gfc_init_se (&argse
, NULL
);
1096 argse
.descriptor_only
= 1;
1097 gfc_conv_expr_descriptor (&argse
, code
->expr1
);
1098 gfc_add_block_to_block (&se
.pre
, &argse
.pre
);
1102 extent
= build_one_cst (gfc_array_index_type
);
1103 for (i
= 0; i
< ar
->dimen
; i
++)
1105 gfc_init_se (&argse
, NULL
);
1106 gfc_conv_expr_type (&argse
, ar
->start
[i
], gfc_array_index_type
);
1107 gfc_add_block_to_block (&argse
.pre
, &argse
.pre
);
1108 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[i
]);
1109 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
1110 TREE_TYPE (lbound
), argse
.expr
, lbound
);
1111 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
1112 TREE_TYPE (tmp
), extent
, tmp
);
1113 index
= fold_build2_loc (input_location
, PLUS_EXPR
,
1114 TREE_TYPE (tmp
), index
, tmp
);
1115 if (i
< ar
->dimen
- 1)
1117 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[i
]);
1118 tmp
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
1119 extent
= fold_build2_loc (input_location
, MULT_EXPR
,
1120 TREE_TYPE (tmp
), extent
, tmp
);
1128 gfc_init_se (&argse
, NULL
);
1129 argse
.want_pointer
= 1;
1130 gfc_conv_expr (&argse
, code
->expr3
);
1131 gfc_add_block_to_block (&se
.pre
, &argse
.pre
);
1132 errmsg
= argse
.expr
;
1133 errmsg_len
= fold_convert (size_type_node
, argse
.string_length
);
1137 errmsg
= null_pointer_node
;
1138 errmsg_len
= build_zero_cst (size_type_node
);
1141 if (stat
!= null_pointer_node
&& TREE_TYPE (stat
) != integer_type_node
)
1144 stat
= gfc_create_var (integer_type_node
, "stat");
1147 index
= fold_convert (size_type_node
, index
);
1148 if (op
== EXEC_EVENT_POST
)
1149 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_event_post
, 6,
1150 token
, index
, image_index
,
1151 stat
!= null_pointer_node
1152 ? gfc_build_addr_expr (NULL
, stat
) : stat
,
1153 errmsg
, errmsg_len
);
1155 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_event_wait
, 6,
1156 token
, index
, until_count
,
1157 stat
!= null_pointer_node
1158 ? gfc_build_addr_expr (NULL
, stat
) : stat
,
1159 errmsg
, errmsg_len
);
1160 gfc_add_expr_to_block (&se
.pre
, tmp
);
1162 /* It guarantees memory consistency within the same segment */
1163 tmp
= gfc_build_string_const (strlen ("memory")+1, "memory"),
1164 tmp
= build5_loc (input_location
, ASM_EXPR
, void_type_node
,
1165 gfc_build_string_const (1, ""), NULL_TREE
, NULL_TREE
,
1166 tree_cons (NULL_TREE
, tmp
, NULL_TREE
), NULL_TREE
);
1167 ASM_VOLATILE_P (tmp
) = 1;
1168 gfc_add_expr_to_block (&se
.pre
, tmp
);
1170 if (stat2
!= NULL_TREE
)
1171 gfc_add_modify (&se
.pre
, stat2
, fold_convert (TREE_TYPE (stat2
), stat
));
1173 return gfc_finish_block (&se
.pre
);
1177 gfc_trans_sync (gfc_code
*code
, gfc_exec_op type
)
1181 tree images
= NULL_TREE
, stat
= NULL_TREE
,
1182 errmsg
= NULL_TREE
, errmsglen
= NULL_TREE
;
1184 /* Short cut: For single images without bound checking or without STAT=,
1185 return early. (ERRMSG= is always untouched for -fcoarray=single.) */
1186 if (!code
->expr2
&& !(gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
1187 && flag_coarray
!= GFC_FCOARRAY_LIB
)
1190 gfc_init_se (&se
, NULL
);
1191 gfc_start_block (&se
.pre
);
1193 if (code
->expr1
&& code
->expr1
->rank
== 0)
1195 gfc_init_se (&argse
, NULL
);
1196 gfc_conv_expr_val (&argse
, code
->expr1
);
1197 images
= argse
.expr
;
1202 gcc_assert (code
->expr2
->expr_type
== EXPR_VARIABLE
);
1203 gfc_init_se (&argse
, NULL
);
1204 gfc_conv_expr_val (&argse
, code
->expr2
);
1208 stat
= null_pointer_node
;
1210 if (code
->expr3
&& flag_coarray
== GFC_FCOARRAY_LIB
)
1212 gcc_assert (code
->expr3
->expr_type
== EXPR_VARIABLE
);
1213 gfc_init_se (&argse
, NULL
);
1214 argse
.want_pointer
= 1;
1215 gfc_conv_expr (&argse
, code
->expr3
);
1216 gfc_conv_string_parameter (&argse
);
1217 errmsg
= gfc_build_addr_expr (NULL
, argse
.expr
);
1218 errmsglen
= fold_convert (size_type_node
, argse
.string_length
);
1220 else if (flag_coarray
== GFC_FCOARRAY_LIB
)
1222 errmsg
= null_pointer_node
;
1223 errmsglen
= build_int_cst (size_type_node
, 0);
1226 /* Check SYNC IMAGES(imageset) for valid image index.
1227 FIXME: Add a check for image-set arrays. */
1228 if (code
->expr1
&& (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
1229 && code
->expr1
->rank
== 0)
1232 if (flag_coarray
!= GFC_FCOARRAY_LIB
)
1233 cond
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
1234 images
, build_int_cst (TREE_TYPE (images
), 1));
1238 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_num_images
,
1239 2, integer_zero_node
,
1240 build_int_cst (integer_type_node
, -1));
1241 cond
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
,
1243 cond2
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
1245 build_int_cst (TREE_TYPE (images
), 1));
1246 cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
1247 logical_type_node
, cond
, cond2
);
1249 gfc_trans_runtime_check (true, false, cond
, &se
.pre
,
1250 &code
->expr1
->where
, "Invalid image number "
1251 "%d in SYNC IMAGES",
1252 fold_convert (integer_type_node
, images
));
1255 /* Per F2008, 8.5.1, a SYNC MEMORY is implied by calling the
1256 image control statements SYNC IMAGES and SYNC ALL. */
1257 if (flag_coarray
== GFC_FCOARRAY_LIB
)
1259 tmp
= gfc_build_string_const (strlen ("memory")+1, "memory"),
1260 tmp
= build5_loc (input_location
, ASM_EXPR
, void_type_node
,
1261 gfc_build_string_const (1, ""), NULL_TREE
, NULL_TREE
,
1262 tree_cons (NULL_TREE
, tmp
, NULL_TREE
), NULL_TREE
);
1263 ASM_VOLATILE_P (tmp
) = 1;
1264 gfc_add_expr_to_block (&se
.pre
, tmp
);
1267 if (flag_coarray
!= GFC_FCOARRAY_LIB
)
1269 /* Set STAT to zero. */
1271 gfc_add_modify (&se
.pre
, stat
, build_int_cst (TREE_TYPE (stat
), 0));
1273 else if (type
== EXEC_SYNC_ALL
|| type
== EXEC_SYNC_MEMORY
)
1275 /* SYNC ALL => stat == null_pointer_node
1276 SYNC ALL(stat=s) => stat has an integer type
1278 If "stat" has the wrong integer type, use a temp variable of
1279 the right type and later cast the result back into "stat". */
1280 if (stat
== null_pointer_node
|| TREE_TYPE (stat
) == integer_type_node
)
1282 if (TREE_TYPE (stat
) == integer_type_node
)
1283 stat
= gfc_build_addr_expr (NULL
, stat
);
1285 if(type
== EXEC_SYNC_MEMORY
)
1286 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_sync_memory
,
1287 3, stat
, errmsg
, errmsglen
);
1289 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_sync_all
,
1290 3, stat
, errmsg
, errmsglen
);
1292 gfc_add_expr_to_block (&se
.pre
, tmp
);
1296 tree tmp_stat
= gfc_create_var (integer_type_node
, "stat");
1298 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_sync_all
,
1299 3, gfc_build_addr_expr (NULL
, tmp_stat
),
1301 gfc_add_expr_to_block (&se
.pre
, tmp
);
1303 gfc_add_modify (&se
.pre
, stat
,
1304 fold_convert (TREE_TYPE (stat
), tmp_stat
));
1311 gcc_assert (type
== EXEC_SYNC_IMAGES
);
1315 len
= build_int_cst (integer_type_node
, -1);
1316 images
= null_pointer_node
;
1318 else if (code
->expr1
->rank
== 0)
1320 len
= build_int_cst (integer_type_node
, 1);
1321 images
= gfc_build_addr_expr (NULL_TREE
, images
);
1326 if (code
->expr1
->ts
.kind
!= gfc_c_int_kind
)
1327 gfc_fatal_error ("Sorry, only support for integer kind %d "
1328 "implemented for image-set at %L",
1329 gfc_c_int_kind
, &code
->expr1
->where
);
1331 gfc_conv_array_parameter (&se
, code
->expr1
, true, NULL
, NULL
, &len
);
1334 tmp
= gfc_typenode_for_spec (&code
->expr1
->ts
);
1335 if (GFC_ARRAY_TYPE_P (tmp
) || GFC_DESCRIPTOR_TYPE_P (tmp
))
1336 tmp
= gfc_get_element_type (tmp
);
1338 len
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
,
1339 TREE_TYPE (len
), len
,
1340 fold_convert (TREE_TYPE (len
),
1341 TYPE_SIZE_UNIT (tmp
)));
1342 len
= fold_convert (integer_type_node
, len
);
1345 /* SYNC IMAGES(imgs) => stat == null_pointer_node
1346 SYNC IMAGES(imgs,stat=s) => stat has an integer type
1348 If "stat" has the wrong integer type, use a temp variable of
1349 the right type and later cast the result back into "stat". */
1350 if (stat
== null_pointer_node
|| TREE_TYPE (stat
) == integer_type_node
)
1352 if (TREE_TYPE (stat
) == integer_type_node
)
1353 stat
= gfc_build_addr_expr (NULL
, stat
);
1355 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_sync_images
,
1356 5, fold_convert (integer_type_node
, len
),
1357 images
, stat
, errmsg
, errmsglen
);
1358 gfc_add_expr_to_block (&se
.pre
, tmp
);
1362 tree tmp_stat
= gfc_create_var (integer_type_node
, "stat");
1364 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_sync_images
,
1365 5, fold_convert (integer_type_node
, len
),
1366 images
, gfc_build_addr_expr (NULL
, tmp_stat
),
1368 gfc_add_expr_to_block (&se
.pre
, tmp
);
1370 gfc_add_modify (&se
.pre
, stat
,
1371 fold_convert (TREE_TYPE (stat
), tmp_stat
));
1375 return gfc_finish_block (&se
.pre
);
1379 /* Generate GENERIC for the IF construct. This function also deals with
1380 the simple IF statement, because the front end translates the IF
1381 statement into an IF construct.
1413 where COND_S is the simplified version of the predicate. PRE_COND_S
1414 are the pre side-effects produced by the translation of the
1416 We need to build the chain recursively otherwise we run into
1417 problems with folding incomplete statements. */
1420 gfc_trans_if_1 (gfc_code
* code
)
1423 tree stmt
, elsestmt
;
1427 /* Check for an unconditional ELSE clause. */
1429 return gfc_trans_code (code
->next
);
1431 /* Initialize a statement builder for each block. Puts in NULL_TREEs. */
1432 gfc_init_se (&if_se
, NULL
);
1433 gfc_start_block (&if_se
.pre
);
1435 /* Calculate the IF condition expression. */
1436 if (code
->expr1
->where
.lb
)
1438 gfc_save_backend_locus (&saved_loc
);
1439 gfc_set_backend_locus (&code
->expr1
->where
);
1442 gfc_conv_expr_val (&if_se
, code
->expr1
);
1444 if (code
->expr1
->where
.lb
)
1445 gfc_restore_backend_locus (&saved_loc
);
1447 /* Translate the THEN clause. */
1448 stmt
= gfc_trans_code (code
->next
);
1450 /* Translate the ELSE clause. */
1452 elsestmt
= gfc_trans_if_1 (code
->block
);
1454 elsestmt
= build_empty_stmt (input_location
);
1456 /* Build the condition expression and add it to the condition block. */
1457 loc
= code
->expr1
->where
.lb
? code
->expr1
->where
.lb
->location
: input_location
;
1458 stmt
= fold_build3_loc (loc
, COND_EXPR
, void_type_node
, if_se
.expr
, stmt
,
1461 gfc_add_expr_to_block (&if_se
.pre
, stmt
);
1463 /* Finish off this statement. */
1464 return gfc_finish_block (&if_se
.pre
);
1468 gfc_trans_if (gfc_code
* code
)
1473 /* Create exit label so it is available for trans'ing the body code. */
1474 exit_label
= gfc_build_label_decl (NULL_TREE
);
1475 code
->exit_label
= exit_label
;
1477 /* Translate the actual code in code->block. */
1478 gfc_init_block (&body
);
1479 gfc_add_expr_to_block (&body
, gfc_trans_if_1 (code
->block
));
1481 /* Add exit label. */
1482 gfc_add_expr_to_block (&body
, build1_v (LABEL_EXPR
, exit_label
));
1484 return gfc_finish_block (&body
);
1488 /* Translate an arithmetic IF expression.
1490 IF (cond) label1, label2, label3 translates to
1502 An optimized version can be generated in case of equal labels.
1503 E.g., if label1 is equal to label2, we can translate it to
1512 gfc_trans_arithmetic_if (gfc_code
* code
)
1520 /* Start a new block. */
1521 gfc_init_se (&se
, NULL
);
1522 gfc_start_block (&se
.pre
);
1524 /* Pre-evaluate COND. */
1525 gfc_conv_expr_val (&se
, code
->expr1
);
1526 se
.expr
= gfc_evaluate_now (se
.expr
, &se
.pre
);
1528 /* Build something to compare with. */
1529 zero
= gfc_build_const (TREE_TYPE (se
.expr
), integer_zero_node
);
1531 if (code
->label1
->value
!= code
->label2
->value
)
1533 /* If (cond < 0) take branch1 else take branch2.
1534 First build jumps to the COND .LT. 0 and the COND .EQ. 0 cases. */
1535 branch1
= build1_v (GOTO_EXPR
, gfc_get_label_decl (code
->label1
));
1536 branch2
= build1_v (GOTO_EXPR
, gfc_get_label_decl (code
->label2
));
1538 if (code
->label1
->value
!= code
->label3
->value
)
1539 tmp
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
1542 tmp
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
1545 branch1
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
1546 tmp
, branch1
, branch2
);
1549 branch1
= build1_v (GOTO_EXPR
, gfc_get_label_decl (code
->label1
));
1551 if (code
->label1
->value
!= code
->label3
->value
1552 && code
->label2
->value
!= code
->label3
->value
)
1554 /* if (cond <= 0) take branch1 else take branch2. */
1555 branch2
= build1_v (GOTO_EXPR
, gfc_get_label_decl (code
->label3
));
1556 tmp
= fold_build2_loc (input_location
, LE_EXPR
, logical_type_node
,
1558 branch1
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
1559 tmp
, branch1
, branch2
);
1562 /* Append the COND_EXPR to the evaluation of COND, and return. */
1563 gfc_add_expr_to_block (&se
.pre
, branch1
);
1564 return gfc_finish_block (&se
.pre
);
1568 /* Translate a CRITICAL block. */
1570 gfc_trans_critical (gfc_code
*code
)
1573 tree tmp
, token
= NULL_TREE
;
1575 gfc_start_block (&block
);
1577 if (flag_coarray
== GFC_FCOARRAY_LIB
)
1579 token
= gfc_get_symbol_decl (code
->resolved_sym
);
1580 token
= GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (token
));
1581 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_lock
, 7,
1582 token
, integer_zero_node
, integer_one_node
,
1583 null_pointer_node
, null_pointer_node
,
1584 null_pointer_node
, integer_zero_node
);
1585 gfc_add_expr_to_block (&block
, tmp
);
1587 /* It guarantees memory consistency within the same segment */
1588 tmp
= gfc_build_string_const (strlen ("memory")+1, "memory"),
1589 tmp
= build5_loc (input_location
, ASM_EXPR
, void_type_node
,
1590 gfc_build_string_const (1, ""),
1591 NULL_TREE
, NULL_TREE
,
1592 tree_cons (NULL_TREE
, tmp
, NULL_TREE
),
1594 ASM_VOLATILE_P (tmp
) = 1;
1596 gfc_add_expr_to_block (&block
, tmp
);
1599 tmp
= gfc_trans_code (code
->block
->next
);
1600 gfc_add_expr_to_block (&block
, tmp
);
1602 if (flag_coarray
== GFC_FCOARRAY_LIB
)
1604 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_unlock
, 6,
1605 token
, integer_zero_node
, integer_one_node
,
1606 null_pointer_node
, null_pointer_node
,
1608 gfc_add_expr_to_block (&block
, tmp
);
1610 /* It guarantees memory consistency within the same segment */
1611 tmp
= gfc_build_string_const (strlen ("memory")+1, "memory"),
1612 tmp
= build5_loc (input_location
, ASM_EXPR
, void_type_node
,
1613 gfc_build_string_const (1, ""),
1614 NULL_TREE
, NULL_TREE
,
1615 tree_cons (NULL_TREE
, tmp
, NULL_TREE
),
1617 ASM_VOLATILE_P (tmp
) = 1;
1619 gfc_add_expr_to_block (&block
, tmp
);
1622 return gfc_finish_block (&block
);
1626 /* Return true, when the class has a _len component. */
1629 class_has_len_component (gfc_symbol
*sym
)
1631 gfc_component
*comp
= sym
->ts
.u
.derived
->components
;
1634 if (strcmp (comp
->name
, "_len") == 0)
1642 /* Do proper initialization for ASSOCIATE names. */
1645 trans_associate_var (gfc_symbol
*sym
, gfc_wrapped_block
*block
)
1656 bool need_len_assign
;
1657 bool whole_array
= true;
1660 gcc_assert (sym
->assoc
);
1661 e
= sym
->assoc
->target
;
1663 class_target
= (e
->expr_type
== EXPR_VARIABLE
)
1664 && (gfc_is_class_scalar_expr (e
)
1665 || gfc_is_class_array_ref (e
, NULL
));
1667 unlimited
= UNLIMITED_POLY (e
);
1669 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
1670 if (ref
->type
== REF_ARRAY
1671 && ref
->u
.ar
.type
== AR_FULL
1674 whole_array
= false;
1678 /* Assignments to the string length need to be generated, when
1679 ( sym is a char array or
1680 sym has a _len component)
1681 and the associated expression is unlimited polymorphic, which is
1682 not (yet) correctly in 'unlimited', because for an already associated
1683 BT_DERIVED the u-poly flag is not set, i.e.,
1684 __tmp_CHARACTER_0_1 => w => arg
1685 ^ generated temp ^ from code, the w does not have the u-poly
1686 flag set, where UNLIMITED_POLY(e) expects it. */
1687 need_len_assign
= ((unlimited
|| (e
->ts
.type
== BT_DERIVED
1688 && e
->ts
.u
.derived
->attr
.unlimited_polymorphic
))
1689 && (sym
->ts
.type
== BT_CHARACTER
1690 || ((sym
->ts
.type
== BT_CLASS
|| sym
->ts
.type
== BT_DERIVED
)
1691 && class_has_len_component (sym
))));
1692 /* Do a `pointer assignment' with updated descriptor (or assign descriptor
1693 to array temporary) for arrays with either unknown shape or if associating
1695 if (sym
->attr
.dimension
&& !class_target
1696 && (sym
->as
->type
== AS_DEFERRED
|| sym
->assoc
->variable
))
1700 bool cst_array_ctor
;
1702 desc
= sym
->backend_decl
;
1703 cst_array_ctor
= e
->expr_type
== EXPR_ARRAY
1704 && gfc_constant_array_constructor_p (e
->value
.constructor
)
1705 && e
->ts
.type
!= BT_CHARACTER
;
1707 /* If association is to an expression, evaluate it and create temporary.
1708 Otherwise, get descriptor of target for pointer assignment. */
1709 gfc_init_se (&se
, NULL
);
1710 if (sym
->assoc
->variable
|| cst_array_ctor
)
1712 se
.direct_byref
= 1;
1717 gfc_conv_expr_descriptor (&se
, e
);
1719 if (sym
->ts
.type
== BT_CHARACTER
1721 && !sym
->attr
.select_type_temporary
1722 && VAR_P (sym
->ts
.u
.cl
->backend_decl
)
1723 && se
.string_length
!= sym
->ts
.u
.cl
->backend_decl
)
1725 gfc_add_modify (&se
.pre
, sym
->ts
.u
.cl
->backend_decl
,
1726 fold_convert (TREE_TYPE (sym
->ts
.u
.cl
->backend_decl
),
1730 /* If we didn't already do the pointer assignment, set associate-name
1731 descriptor to the one generated for the temporary. */
1732 if ((!sym
->assoc
->variable
&& !cst_array_ctor
)
1738 gfc_add_modify (&se
.pre
, desc
, se
.expr
);
1740 /* The generated descriptor has lower bound zero (as array
1741 temporary), shift bounds so we get lower bounds of 1. */
1742 for (dim
= 0; dim
< e
->rank
; ++dim
)
1743 gfc_conv_shift_descriptor_lbound (&se
.pre
, desc
,
1744 dim
, gfc_index_one_node
);
1747 /* If this is a subreference array pointer associate name use the
1748 associate variable element size for the value of 'span'. */
1749 if (sym
->attr
.subref_array_pointer
)
1751 gcc_assert (e
->expr_type
== EXPR_VARIABLE
);
1752 tmp
= gfc_get_array_span (se
.expr
, e
);
1754 gfc_conv_descriptor_span_set (&se
.pre
, desc
, tmp
);
1757 if (e
->expr_type
== EXPR_FUNCTION
1758 && sym
->ts
.type
== BT_DERIVED
1759 && sym
->ts
.u
.derived
1760 && sym
->ts
.u
.derived
->attr
.pdt_type
)
1762 tmp
= gfc_deallocate_pdt_comp (sym
->ts
.u
.derived
, se
.expr
,
1764 gfc_add_expr_to_block (&se
.post
, tmp
);
1767 /* Done, register stuff as init / cleanup code. */
1768 gfc_add_init_cleanup (block
, gfc_finish_block (&se
.pre
),
1769 gfc_finish_block (&se
.post
));
1772 /* Temporaries, arising from TYPE IS, just need the descriptor of class
1773 arrays to be assigned directly. */
1774 else if (class_target
&& sym
->attr
.dimension
1775 && (sym
->ts
.type
== BT_DERIVED
|| unlimited
))
1779 gfc_init_se (&se
, NULL
);
1780 se
.descriptor_only
= 1;
1781 /* In a select type the (temporary) associate variable shall point to
1782 a standard fortran array (lower bound == 1), but conv_expr ()
1783 just maps to the input array in the class object, whose lbound may
1784 be arbitrary. conv_expr_descriptor solves this by inserting a
1785 temporary array descriptor. */
1786 gfc_conv_expr_descriptor (&se
, e
);
1788 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se
.expr
))
1789 || GFC_ARRAY_TYPE_P (TREE_TYPE (se
.expr
)));
1790 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (sym
->backend_decl
)));
1792 if (GFC_ARRAY_TYPE_P (TREE_TYPE (se
.expr
)))
1794 if (INDIRECT_REF_P (se
.expr
))
1795 tmp
= TREE_OPERAND (se
.expr
, 0);
1799 gfc_add_modify (&se
.pre
, sym
->backend_decl
,
1800 gfc_class_data_get (GFC_DECL_SAVED_DESCRIPTOR (tmp
)));
1803 gfc_add_modify (&se
.pre
, sym
->backend_decl
, se
.expr
);
1807 /* Recover the dtype, which has been overwritten by the
1808 assignment from an unlimited polymorphic object. */
1809 tmp
= gfc_conv_descriptor_dtype (sym
->backend_decl
);
1810 gfc_add_modify (&se
.pre
, tmp
,
1811 gfc_get_dtype (TREE_TYPE (sym
->backend_decl
)));
1814 gfc_add_init_cleanup (block
, gfc_finish_block (&se
.pre
),
1815 gfc_finish_block (&se
.post
));
1818 /* Do a scalar pointer assignment; this is for scalar variable targets. */
1819 else if (gfc_is_associate_pointer (sym
))
1823 gcc_assert (!sym
->attr
.dimension
);
1825 gfc_init_se (&se
, NULL
);
1827 /* Class associate-names come this way because they are
1828 unconditionally associate pointers and the symbol is scalar. */
1829 if (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)->attr
.dimension
)
1832 /* For a class array we need a descriptor for the selector. */
1833 gfc_conv_expr_descriptor (&se
, e
);
1834 /* Needed to get/set the _len component below. */
1835 target_expr
= se
.expr
;
1837 /* Obtain a temporary class container for the result. */
1838 gfc_conv_class_to_class (&se
, e
, sym
->ts
, false, true, false, false);
1839 se
.expr
= build_fold_indirect_ref_loc (input_location
, se
.expr
);
1841 /* Set the offset. */
1842 desc
= gfc_class_data_get (se
.expr
);
1843 offset
= gfc_index_zero_node
;
1844 for (n
= 0; n
< e
->rank
; n
++)
1846 dim
= gfc_rank_cst
[n
];
1847 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
1848 gfc_array_index_type
,
1849 gfc_conv_descriptor_stride_get (desc
, dim
),
1850 gfc_conv_descriptor_lbound_get (desc
, dim
));
1851 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
1852 gfc_array_index_type
,
1855 if (need_len_assign
)
1858 && DECL_LANG_SPECIFIC (e
->symtree
->n
.sym
->backend_decl
)
1859 && GFC_DECL_SAVED_DESCRIPTOR (e
->symtree
->n
.sym
->backend_decl
))
1860 /* Use the original class descriptor stored in the saved
1861 descriptor to get the target_expr. */
1863 GFC_DECL_SAVED_DESCRIPTOR (e
->symtree
->n
.sym
->backend_decl
);
1865 /* Strip the _data component from the target_expr. */
1866 target_expr
= TREE_OPERAND (target_expr
, 0);
1867 /* Add a reference to the _len comp to the target expr. */
1868 tmp
= gfc_class_len_get (target_expr
);
1869 /* Get the component-ref for the temp structure's _len comp. */
1870 charlen
= gfc_class_len_get (se
.expr
);
1871 /* Add the assign to the beginning of the block... */
1872 gfc_add_modify (&se
.pre
, charlen
,
1873 fold_convert (TREE_TYPE (charlen
), tmp
));
1874 /* and the oposite way at the end of the block, to hand changes
1875 on the string length back. */
1876 gfc_add_modify (&se
.post
, tmp
,
1877 fold_convert (TREE_TYPE (tmp
), charlen
));
1878 /* Length assignment done, prevent adding it again below. */
1879 need_len_assign
= false;
1881 gfc_conv_descriptor_offset_set (&se
.pre
, desc
, offset
);
1883 else if (sym
->ts
.type
== BT_CLASS
&& e
->ts
.type
== BT_CLASS
1884 && CLASS_DATA (e
)->attr
.dimension
)
1886 /* This is bound to be a class array element. */
1887 gfc_conv_expr_reference (&se
, e
);
1888 /* Get the _vptr component of the class object. */
1889 tmp
= gfc_get_vptr_from_expr (se
.expr
);
1890 /* Obtain a temporary class container for the result. */
1891 gfc_conv_derived_to_class (&se
, e
, sym
->ts
, tmp
, false, false);
1892 se
.expr
= build_fold_indirect_ref_loc (input_location
, se
.expr
);
1896 /* For BT_CLASS and BT_DERIVED, this boils down to a pointer assign,
1897 which has the string length included. For CHARACTERS it is still
1898 needed and will be done at the end of this routine. */
1899 gfc_conv_expr (&se
, e
);
1900 need_len_assign
= need_len_assign
&& sym
->ts
.type
== BT_CHARACTER
;
1903 if (sym
->ts
.type
== BT_CHARACTER
1904 && !sym
->attr
.select_type_temporary
1905 && VAR_P (sym
->ts
.u
.cl
->backend_decl
)
1906 && se
.string_length
!= sym
->ts
.u
.cl
->backend_decl
)
1908 gfc_add_modify (&se
.pre
, sym
->ts
.u
.cl
->backend_decl
,
1909 fold_convert (TREE_TYPE (sym
->ts
.u
.cl
->backend_decl
),
1911 if (e
->expr_type
== EXPR_FUNCTION
)
1913 tmp
= gfc_call_free (sym
->backend_decl
);
1914 gfc_add_expr_to_block (&se
.post
, tmp
);
1918 if (sym
->ts
.type
== BT_CHARACTER
&& e
->ts
.type
== BT_CHARACTER
1919 && POINTER_TYPE_P (TREE_TYPE (se
.expr
)))
1921 /* These are pointer types already. */
1922 tmp
= fold_convert (TREE_TYPE (sym
->backend_decl
), se
.expr
);
1926 tmp
= TREE_TYPE (sym
->backend_decl
);
1927 tmp
= gfc_build_addr_expr (tmp
, se
.expr
);
1930 gfc_add_modify (&se
.pre
, sym
->backend_decl
, tmp
);
1932 gfc_add_init_cleanup (block
, gfc_finish_block( &se
.pre
),
1933 gfc_finish_block (&se
.post
));
1936 /* Do a simple assignment. This is for scalar expressions, where we
1937 can simply use expression assignment. */
1944 gfc_init_se (&se
, NULL
);
1946 /* resolve.c converts some associate names to allocatable so that
1947 allocation can take place automatically in gfc_trans_assignment.
1948 The frontend prevents them from being either allocated,
1949 deallocated or reallocated. */
1950 if (sym
->attr
.allocatable
)
1952 tmp
= sym
->backend_decl
;
1953 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp
)))
1954 tmp
= gfc_conv_descriptor_data_get (tmp
);
1955 gfc_add_modify (&se
.pre
, tmp
, fold_convert (TREE_TYPE (tmp
),
1956 null_pointer_node
));
1959 lhs
= gfc_lval_expr_from_sym (sym
);
1960 res
= gfc_trans_assignment (lhs
, e
, false, true);
1961 gfc_add_expr_to_block (&se
.pre
, res
);
1963 tmp
= sym
->backend_decl
;
1964 if (e
->expr_type
== EXPR_FUNCTION
1965 && sym
->ts
.type
== BT_DERIVED
1966 && sym
->ts
.u
.derived
1967 && sym
->ts
.u
.derived
->attr
.pdt_type
)
1969 tmp
= gfc_deallocate_pdt_comp (sym
->ts
.u
.derived
, tmp
,
1972 else if (e
->expr_type
== EXPR_FUNCTION
1973 && sym
->ts
.type
== BT_CLASS
1974 && CLASS_DATA (sym
)->ts
.u
.derived
1975 && CLASS_DATA (sym
)->ts
.u
.derived
->attr
.pdt_type
)
1977 tmp
= gfc_class_data_get (tmp
);
1978 tmp
= gfc_deallocate_pdt_comp (CLASS_DATA (sym
)->ts
.u
.derived
,
1981 else if (sym
->attr
.allocatable
)
1983 tmp
= sym
->backend_decl
;
1985 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp
)))
1986 tmp
= gfc_conv_descriptor_data_get (tmp
);
1988 /* A simple call to free suffices here. */
1989 tmp
= gfc_call_free (tmp
);
1991 /* Make sure that reallocation on assignment cannot occur. */
1992 sym
->attr
.allocatable
= 0;
1997 res
= gfc_finish_block (&se
.pre
);
1998 gfc_add_init_cleanup (block
, res
, tmp
);
1999 gfc_free_expr (lhs
);
2002 /* Set the stringlength, when needed. */
2003 if (need_len_assign
)
2006 gfc_init_se (&se
, NULL
);
2007 if (e
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
)
2009 /* Deferred strings are dealt with in the preceeding. */
2010 gcc_assert (!e
->symtree
->n
.sym
->ts
.deferred
);
2011 tmp
= e
->symtree
->n
.sym
->ts
.u
.cl
->backend_decl
;
2013 else if (e
->symtree
->n
.sym
->attr
.function
2014 && e
->symtree
->n
.sym
== e
->symtree
->n
.sym
->result
)
2016 tmp
= gfc_get_fake_result_decl (e
->symtree
->n
.sym
, 0);
2017 tmp
= gfc_class_len_get (tmp
);
2020 tmp
= gfc_class_len_get (gfc_get_symbol_decl (e
->symtree
->n
.sym
));
2021 gfc_get_symbol_decl (sym
);
2022 charlen
= sym
->ts
.type
== BT_CHARACTER
? sym
->ts
.u
.cl
->backend_decl
2023 : gfc_class_len_get (sym
->backend_decl
);
2024 /* Prevent adding a noop len= len. */
2027 gfc_add_modify (&se
.pre
, charlen
,
2028 fold_convert (TREE_TYPE (charlen
), tmp
));
2029 gfc_add_init_cleanup (block
, gfc_finish_block (&se
.pre
),
2030 gfc_finish_block (&se
.post
));
2036 /* Translate a BLOCK construct. This is basically what we would do for a
2040 gfc_trans_block_construct (gfc_code
* code
)
2044 gfc_wrapped_block block
;
2047 gfc_association_list
*ass
;
2049 ns
= code
->ext
.block
.ns
;
2051 sym
= ns
->proc_name
;
2054 /* Process local variables. */
2055 gcc_assert (!sym
->tlink
);
2057 gfc_process_block_locals (ns
);
2059 /* Generate code including exit-label. */
2060 gfc_init_block (&body
);
2061 exit_label
= gfc_build_label_decl (NULL_TREE
);
2062 code
->exit_label
= exit_label
;
2064 finish_oacc_declare (ns
, sym
, true);
2066 gfc_add_expr_to_block (&body
, gfc_trans_code (ns
->code
));
2067 gfc_add_expr_to_block (&body
, build1_v (LABEL_EXPR
, exit_label
));
2069 /* Finish everything. */
2070 gfc_start_wrapped_block (&block
, gfc_finish_block (&body
));
2071 gfc_trans_deferred_vars (sym
, &block
);
2072 for (ass
= code
->ext
.block
.assoc
; ass
; ass
= ass
->next
)
2073 trans_associate_var (ass
->st
->n
.sym
, &block
);
2075 return gfc_finish_wrapped_block (&block
);
2078 /* Translate the simple DO construct in a C-style manner.
2079 This is where the loop variable has integer type and step +-1.
2080 Following code will generate infinite loop in case where TO is INT_MAX
2081 (for +1 step) or INT_MIN (for -1 step)
2083 We translate a do loop from:
2085 DO dovar = from, to, step
2091 [Evaluate loop bounds and step]
2103 This helps the optimizers by avoiding the extra pre-header condition and
2104 we save a register as we just compare the updated IV (not a value in
2108 gfc_trans_simple_do (gfc_code
* code
, stmtblock_t
*pblock
, tree dovar
,
2109 tree from
, tree to
, tree step
, tree exit_cond
)
2115 tree saved_dovar
= NULL
;
2119 type
= TREE_TYPE (dovar
);
2120 bool is_step_positive
= tree_int_cst_sgn (step
) > 0;
2122 loc
= code
->ext
.iterator
->start
->where
.lb
->location
;
2124 /* Initialize the DO variable: dovar = from. */
2125 gfc_add_modify_loc (loc
, pblock
, dovar
,
2126 fold_convert (TREE_TYPE (dovar
), from
));
2128 /* Save value for do-tinkering checking. */
2129 if (gfc_option
.rtcheck
& GFC_RTCHECK_DO
)
2131 saved_dovar
= gfc_create_var (type
, ".saved_dovar");
2132 gfc_add_modify_loc (loc
, pblock
, saved_dovar
, dovar
);
2135 /* Cycle and exit statements are implemented with gotos. */
2136 cycle_label
= gfc_build_label_decl (NULL_TREE
);
2137 exit_label
= gfc_build_label_decl (NULL_TREE
);
2139 /* Put the labels where they can be found later. See gfc_trans_do(). */
2140 code
->cycle_label
= cycle_label
;
2141 code
->exit_label
= exit_label
;
2144 gfc_start_block (&body
);
2146 /* Exit the loop if there is an I/O result condition or error. */
2149 tmp
= build1_v (GOTO_EXPR
, exit_label
);
2150 tmp
= fold_build3_loc (loc
, COND_EXPR
, void_type_node
,
2152 build_empty_stmt (loc
));
2153 gfc_add_expr_to_block (&body
, tmp
);
2156 /* Evaluate the loop condition. */
2157 if (is_step_positive
)
2158 cond
= fold_build2_loc (loc
, GT_EXPR
, logical_type_node
, dovar
,
2159 fold_convert (type
, to
));
2161 cond
= fold_build2_loc (loc
, LT_EXPR
, logical_type_node
, dovar
,
2162 fold_convert (type
, to
));
2164 cond
= gfc_evaluate_now_loc (loc
, cond
, &body
);
2165 if (code
->ext
.iterator
->unroll
&& cond
!= error_mark_node
)
2167 = build3 (ANNOTATE_EXPR
, TREE_TYPE (cond
), cond
,
2168 build_int_cst (integer_type_node
, annot_expr_unroll_kind
),
2169 build_int_cst (integer_type_node
, code
->ext
.iterator
->unroll
));
2171 /* The loop exit. */
2172 tmp
= fold_build1_loc (loc
, GOTO_EXPR
, void_type_node
, exit_label
);
2173 TREE_USED (exit_label
) = 1;
2174 tmp
= fold_build3_loc (loc
, COND_EXPR
, void_type_node
,
2175 cond
, tmp
, build_empty_stmt (loc
));
2176 gfc_add_expr_to_block (&body
, tmp
);
2178 /* Check whether the induction variable is equal to INT_MAX
2179 (respectively to INT_MIN). */
2180 if (gfc_option
.rtcheck
& GFC_RTCHECK_DO
)
2182 tree boundary
= is_step_positive
? TYPE_MAX_VALUE (type
)
2183 : TYPE_MIN_VALUE (type
);
2185 tmp
= fold_build2_loc (loc
, EQ_EXPR
, logical_type_node
,
2187 gfc_trans_runtime_check (true, false, tmp
, &body
, &code
->loc
,
2188 "Loop iterates infinitely");
2191 /* Main loop body. */
2192 tmp
= gfc_trans_code_cond (code
->block
->next
, exit_cond
);
2193 gfc_add_expr_to_block (&body
, tmp
);
2195 /* Label for cycle statements (if needed). */
2196 if (TREE_USED (cycle_label
))
2198 tmp
= build1_v (LABEL_EXPR
, cycle_label
);
2199 gfc_add_expr_to_block (&body
, tmp
);
2202 /* Check whether someone has modified the loop variable. */
2203 if (gfc_option
.rtcheck
& GFC_RTCHECK_DO
)
2205 tmp
= fold_build2_loc (loc
, NE_EXPR
, logical_type_node
,
2206 dovar
, saved_dovar
);
2207 gfc_trans_runtime_check (true, false, tmp
, &body
, &code
->loc
,
2208 "Loop variable has been modified");
2211 /* Increment the loop variable. */
2212 tmp
= fold_build2_loc (loc
, PLUS_EXPR
, type
, dovar
, step
);
2213 gfc_add_modify_loc (loc
, &body
, dovar
, tmp
);
2215 if (gfc_option
.rtcheck
& GFC_RTCHECK_DO
)
2216 gfc_add_modify_loc (loc
, &body
, saved_dovar
, dovar
);
2218 /* Finish the loop body. */
2219 tmp
= gfc_finish_block (&body
);
2220 tmp
= fold_build1_loc (loc
, LOOP_EXPR
, void_type_node
, tmp
);
2222 gfc_add_expr_to_block (pblock
, tmp
);
2224 /* Add the exit label. */
2225 tmp
= build1_v (LABEL_EXPR
, exit_label
);
2226 gfc_add_expr_to_block (pblock
, tmp
);
2228 return gfc_finish_block (pblock
);
2231 /* Translate the DO construct. This obviously is one of the most
2232 important ones to get right with any compiler, but especially
2235 We special case some loop forms as described in gfc_trans_simple_do.
2236 For other cases we implement them with a separate loop count,
2237 as described in the standard.
2239 We translate a do loop from:
2241 DO dovar = from, to, step
2247 [evaluate loop bounds and step]
2248 empty = (step > 0 ? to < from : to > from);
2249 countm1 = (to - from) / step;
2251 if (empty) goto exit_label;
2259 if (countm1t == 0) goto exit_label;
2263 countm1 is an unsigned integer. It is equal to the loop count minus one,
2264 because the loop count itself can overflow. */
2267 gfc_trans_do (gfc_code
* code
, tree exit_cond
)
2271 tree saved_dovar
= NULL
;
2286 gfc_start_block (&block
);
2288 loc
= code
->ext
.iterator
->start
->where
.lb
->location
;
2290 /* Evaluate all the expressions in the iterator. */
2291 gfc_init_se (&se
, NULL
);
2292 gfc_conv_expr_lhs (&se
, code
->ext
.iterator
->var
);
2293 gfc_add_block_to_block (&block
, &se
.pre
);
2295 type
= TREE_TYPE (dovar
);
2297 gfc_init_se (&se
, NULL
);
2298 gfc_conv_expr_val (&se
, code
->ext
.iterator
->start
);
2299 gfc_add_block_to_block (&block
, &se
.pre
);
2300 from
= gfc_evaluate_now (se
.expr
, &block
);
2302 gfc_init_se (&se
, NULL
);
2303 gfc_conv_expr_val (&se
, code
->ext
.iterator
->end
);
2304 gfc_add_block_to_block (&block
, &se
.pre
);
2305 to
= gfc_evaluate_now (se
.expr
, &block
);
2307 gfc_init_se (&se
, NULL
);
2308 gfc_conv_expr_val (&se
, code
->ext
.iterator
->step
);
2309 gfc_add_block_to_block (&block
, &se
.pre
);
2310 step
= gfc_evaluate_now (se
.expr
, &block
);
2312 if (gfc_option
.rtcheck
& GFC_RTCHECK_DO
)
2314 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
, step
,
2315 build_zero_cst (type
));
2316 gfc_trans_runtime_check (true, false, tmp
, &block
, &code
->loc
,
2317 "DO step value is zero");
2320 /* Special case simple loops. */
2321 if (TREE_CODE (type
) == INTEGER_TYPE
2322 && (integer_onep (step
)
2323 || tree_int_cst_equal (step
, integer_minus_one_node
)))
2324 return gfc_trans_simple_do (code
, &block
, dovar
, from
, to
, step
,
2327 if (TREE_CODE (type
) == INTEGER_TYPE
)
2328 utype
= unsigned_type_for (type
);
2330 utype
= unsigned_type_for (gfc_array_index_type
);
2331 countm1
= gfc_create_var (utype
, "countm1");
2333 /* Cycle and exit statements are implemented with gotos. */
2334 cycle_label
= gfc_build_label_decl (NULL_TREE
);
2335 exit_label
= gfc_build_label_decl (NULL_TREE
);
2336 TREE_USED (exit_label
) = 1;
2338 /* Put these labels where they can be found later. */
2339 code
->cycle_label
= cycle_label
;
2340 code
->exit_label
= exit_label
;
2342 /* Initialize the DO variable: dovar = from. */
2343 gfc_add_modify (&block
, dovar
, from
);
2345 /* Save value for do-tinkering checking. */
2346 if (gfc_option
.rtcheck
& GFC_RTCHECK_DO
)
2348 saved_dovar
= gfc_create_var (type
, ".saved_dovar");
2349 gfc_add_modify_loc (loc
, &block
, saved_dovar
, dovar
);
2352 /* Initialize loop count and jump to exit label if the loop is empty.
2353 This code is executed before we enter the loop body. We generate:
2356 countm1 = (to - from) / step;
2362 countm1 = (from - to) / -step;
2368 if (TREE_CODE (type
) == INTEGER_TYPE
)
2370 tree pos
, neg
, tou
, fromu
, stepu
, tmp2
;
2372 /* The distance from FROM to TO cannot always be represented in a signed
2373 type, thus use unsigned arithmetic, also to avoid any undefined
2375 tou
= fold_convert (utype
, to
);
2376 fromu
= fold_convert (utype
, from
);
2377 stepu
= fold_convert (utype
, step
);
2379 /* For a positive step, when to < from, exit, otherwise compute
2380 countm1 = ((unsigned)to - (unsigned)from) / (unsigned)step */
2381 tmp
= fold_build2_loc (loc
, LT_EXPR
, logical_type_node
, to
, from
);
2382 tmp2
= fold_build2_loc (loc
, TRUNC_DIV_EXPR
, utype
,
2383 fold_build2_loc (loc
, MINUS_EXPR
, utype
,
2386 pos
= build2 (COMPOUND_EXPR
, void_type_node
,
2387 fold_build2 (MODIFY_EXPR
, void_type_node
,
2389 build3_loc (loc
, COND_EXPR
, void_type_node
,
2390 gfc_unlikely (tmp
, PRED_FORTRAN_LOOP_PREHEADER
),
2391 build1_loc (loc
, GOTO_EXPR
, void_type_node
,
2392 exit_label
), NULL_TREE
));
2394 /* For a negative step, when to > from, exit, otherwise compute
2395 countm1 = ((unsigned)from - (unsigned)to) / -(unsigned)step */
2396 tmp
= fold_build2_loc (loc
, GT_EXPR
, logical_type_node
, to
, from
);
2397 tmp2
= fold_build2_loc (loc
, TRUNC_DIV_EXPR
, utype
,
2398 fold_build2_loc (loc
, MINUS_EXPR
, utype
,
2400 fold_build1_loc (loc
, NEGATE_EXPR
, utype
, stepu
));
2401 neg
= build2 (COMPOUND_EXPR
, void_type_node
,
2402 fold_build2 (MODIFY_EXPR
, void_type_node
,
2404 build3_loc (loc
, COND_EXPR
, void_type_node
,
2405 gfc_unlikely (tmp
, PRED_FORTRAN_LOOP_PREHEADER
),
2406 build1_loc (loc
, GOTO_EXPR
, void_type_node
,
2407 exit_label
), NULL_TREE
));
2409 tmp
= fold_build2_loc (loc
, LT_EXPR
, logical_type_node
, step
,
2410 build_int_cst (TREE_TYPE (step
), 0));
2411 tmp
= fold_build3_loc (loc
, COND_EXPR
, void_type_node
, tmp
, neg
, pos
);
2413 gfc_add_expr_to_block (&block
, tmp
);
2419 /* TODO: We could use the same width as the real type.
2420 This would probably cause more problems that it solves
2421 when we implement "long double" types. */
2423 tmp
= fold_build2_loc (loc
, MINUS_EXPR
, type
, to
, from
);
2424 tmp
= fold_build2_loc (loc
, RDIV_EXPR
, type
, tmp
, step
);
2425 tmp
= fold_build1_loc (loc
, FIX_TRUNC_EXPR
, utype
, tmp
);
2426 gfc_add_modify (&block
, countm1
, tmp
);
2428 /* We need a special check for empty loops:
2429 empty = (step > 0 ? to < from : to > from); */
2430 pos_step
= fold_build2_loc (loc
, GT_EXPR
, logical_type_node
, step
,
2431 build_zero_cst (type
));
2432 tmp
= fold_build3_loc (loc
, COND_EXPR
, logical_type_node
, pos_step
,
2433 fold_build2_loc (loc
, LT_EXPR
,
2434 logical_type_node
, to
, from
),
2435 fold_build2_loc (loc
, GT_EXPR
,
2436 logical_type_node
, to
, from
));
2437 /* If the loop is empty, go directly to the exit label. */
2438 tmp
= fold_build3_loc (loc
, COND_EXPR
, void_type_node
, tmp
,
2439 build1_v (GOTO_EXPR
, exit_label
),
2440 build_empty_stmt (input_location
));
2441 gfc_add_expr_to_block (&block
, tmp
);
2445 gfc_start_block (&body
);
2447 /* Main loop body. */
2448 tmp
= gfc_trans_code_cond (code
->block
->next
, exit_cond
);
2449 gfc_add_expr_to_block (&body
, tmp
);
2451 /* Label for cycle statements (if needed). */
2452 if (TREE_USED (cycle_label
))
2454 tmp
= build1_v (LABEL_EXPR
, cycle_label
);
2455 gfc_add_expr_to_block (&body
, tmp
);
2458 /* Check whether someone has modified the loop variable. */
2459 if (gfc_option
.rtcheck
& GFC_RTCHECK_DO
)
2461 tmp
= fold_build2_loc (loc
, NE_EXPR
, logical_type_node
, dovar
,
2463 gfc_trans_runtime_check (true, false, tmp
, &body
, &code
->loc
,
2464 "Loop variable has been modified");
2467 /* Exit the loop if there is an I/O result condition or error. */
2470 tmp
= build1_v (GOTO_EXPR
, exit_label
);
2471 tmp
= fold_build3_loc (loc
, COND_EXPR
, void_type_node
,
2473 build_empty_stmt (input_location
));
2474 gfc_add_expr_to_block (&body
, tmp
);
2477 /* Increment the loop variable. */
2478 tmp
= fold_build2_loc (loc
, PLUS_EXPR
, type
, dovar
, step
);
2479 gfc_add_modify_loc (loc
, &body
, dovar
, tmp
);
2481 if (gfc_option
.rtcheck
& GFC_RTCHECK_DO
)
2482 gfc_add_modify_loc (loc
, &body
, saved_dovar
, dovar
);
2484 /* Initialize countm1t. */
2485 tree countm1t
= gfc_create_var (utype
, "countm1t");
2486 gfc_add_modify_loc (loc
, &body
, countm1t
, countm1
);
2488 /* Decrement the loop count. */
2489 tmp
= fold_build2_loc (loc
, MINUS_EXPR
, utype
, countm1
,
2490 build_int_cst (utype
, 1));
2491 gfc_add_modify_loc (loc
, &body
, countm1
, tmp
);
2493 /* End with the loop condition. Loop until countm1t == 0. */
2494 cond
= fold_build2_loc (loc
, EQ_EXPR
, logical_type_node
, countm1t
,
2495 build_int_cst (utype
, 0));
2496 if (code
->ext
.iterator
->unroll
&& cond
!= error_mark_node
)
2498 = build3 (ANNOTATE_EXPR
, TREE_TYPE (cond
), cond
,
2499 build_int_cst (integer_type_node
, annot_expr_unroll_kind
),
2500 build_int_cst (integer_type_node
, code
->ext
.iterator
->unroll
));
2501 tmp
= fold_build1_loc (loc
, GOTO_EXPR
, void_type_node
, exit_label
);
2502 tmp
= fold_build3_loc (loc
, COND_EXPR
, void_type_node
,
2503 cond
, tmp
, build_empty_stmt (loc
));
2504 gfc_add_expr_to_block (&body
, tmp
);
2506 /* End of loop body. */
2507 tmp
= gfc_finish_block (&body
);
2509 /* The for loop itself. */
2510 tmp
= fold_build1_loc (loc
, LOOP_EXPR
, void_type_node
, tmp
);
2511 gfc_add_expr_to_block (&block
, tmp
);
2513 /* Add the exit label. */
2514 tmp
= build1_v (LABEL_EXPR
, exit_label
);
2515 gfc_add_expr_to_block (&block
, tmp
);
2517 return gfc_finish_block (&block
);
2521 /* Translate the DO WHILE construct.
2534 if (! cond) goto exit_label;
2540 Because the evaluation of the exit condition `cond' may have side
2541 effects, we can't do much for empty loop bodies. The backend optimizers
2542 should be smart enough to eliminate any dead loops. */
2545 gfc_trans_do_while (gfc_code
* code
)
2553 /* Everything we build here is part of the loop body. */
2554 gfc_start_block (&block
);
2556 /* Cycle and exit statements are implemented with gotos. */
2557 cycle_label
= gfc_build_label_decl (NULL_TREE
);
2558 exit_label
= gfc_build_label_decl (NULL_TREE
);
2560 /* Put the labels where they can be found later. See gfc_trans_do(). */
2561 code
->cycle_label
= cycle_label
;
2562 code
->exit_label
= exit_label
;
2564 /* Create a GIMPLE version of the exit condition. */
2565 gfc_init_se (&cond
, NULL
);
2566 gfc_conv_expr_val (&cond
, code
->expr1
);
2567 gfc_add_block_to_block (&block
, &cond
.pre
);
2568 cond
.expr
= fold_build1_loc (code
->expr1
->where
.lb
->location
,
2569 TRUTH_NOT_EXPR
, TREE_TYPE (cond
.expr
), cond
.expr
);
2571 /* Build "IF (! cond) GOTO exit_label". */
2572 tmp
= build1_v (GOTO_EXPR
, exit_label
);
2573 TREE_USED (exit_label
) = 1;
2574 tmp
= fold_build3_loc (code
->expr1
->where
.lb
->location
, COND_EXPR
,
2575 void_type_node
, cond
.expr
, tmp
,
2576 build_empty_stmt (code
->expr1
->where
.lb
->location
));
2577 gfc_add_expr_to_block (&block
, tmp
);
2579 /* The main body of the loop. */
2580 tmp
= gfc_trans_code (code
->block
->next
);
2581 gfc_add_expr_to_block (&block
, tmp
);
2583 /* Label for cycle statements (if needed). */
2584 if (TREE_USED (cycle_label
))
2586 tmp
= build1_v (LABEL_EXPR
, cycle_label
);
2587 gfc_add_expr_to_block (&block
, tmp
);
2590 /* End of loop body. */
2591 tmp
= gfc_finish_block (&block
);
2593 gfc_init_block (&block
);
2594 /* Build the loop. */
2595 tmp
= fold_build1_loc (code
->expr1
->where
.lb
->location
, LOOP_EXPR
,
2596 void_type_node
, tmp
);
2597 gfc_add_expr_to_block (&block
, tmp
);
2599 /* Add the exit label. */
2600 tmp
= build1_v (LABEL_EXPR
, exit_label
);
2601 gfc_add_expr_to_block (&block
, tmp
);
2603 return gfc_finish_block (&block
);
2607 /* Deal with the particular case of SELECT_TYPE, where the vtable
2608 addresses are used for the selection. Since these are not sorted,
2609 the selection has to be made by a series of if statements. */
2612 gfc_trans_select_type_cases (gfc_code
* code
)
2626 gfc_start_block (&block
);
2628 /* Calculate the switch expression. */
2629 gfc_init_se (&se
, NULL
);
2630 gfc_conv_expr_val (&se
, code
->expr1
);
2631 gfc_add_block_to_block (&block
, &se
.pre
);
2633 /* Generate an expression for the selector hash value, for
2634 use to resolve character cases. */
2635 e
= gfc_copy_expr (code
->expr1
->value
.function
.actual
->expr
);
2636 gfc_add_hash_component (e
);
2638 TREE_USED (code
->exit_label
) = 0;
2641 for (c
= code
->block
; c
; c
= c
->block
)
2643 cp
= c
->ext
.block
.case_list
;
2645 /* Assume it's the default case. */
2650 /* Put the default case at the end. */
2651 if ((!def
&& !cp
->low
) || (def
&& cp
->low
))
2654 if (cp
->low
&& (cp
->ts
.type
== BT_CLASS
2655 || cp
->ts
.type
== BT_DERIVED
))
2657 gfc_init_se (&cse
, NULL
);
2658 gfc_conv_expr_val (&cse
, cp
->low
);
2659 gfc_add_block_to_block (&block
, &cse
.pre
);
2662 else if (cp
->ts
.type
!= BT_UNKNOWN
)
2664 gcc_assert (cp
->high
);
2665 gfc_init_se (&cse
, NULL
);
2666 gfc_conv_expr_val (&cse
, cp
->high
);
2667 gfc_add_block_to_block (&block
, &cse
.pre
);
2671 gfc_init_block (&body
);
2673 /* Add the statements for this case. */
2674 tmp
= gfc_trans_code (c
->next
);
2675 gfc_add_expr_to_block (&body
, tmp
);
2677 /* Break to the end of the SELECT TYPE construct. The default
2678 case just falls through. */
2681 TREE_USED (code
->exit_label
) = 1;
2682 tmp
= build1_v (GOTO_EXPR
, code
->exit_label
);
2683 gfc_add_expr_to_block (&body
, tmp
);
2686 tmp
= gfc_finish_block (&body
);
2688 if (low
!= NULL_TREE
)
2690 /* Compare vtable pointers. */
2691 cond
= fold_build2_loc (input_location
, EQ_EXPR
,
2692 TREE_TYPE (se
.expr
), se
.expr
, low
);
2693 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
2695 build_empty_stmt (input_location
));
2697 else if (high
!= NULL_TREE
)
2699 /* Compare hash values for character cases. */
2700 gfc_init_se (&cse
, NULL
);
2701 gfc_conv_expr_val (&cse
, e
);
2702 gfc_add_block_to_block (&block
, &cse
.pre
);
2704 cond
= fold_build2_loc (input_location
, EQ_EXPR
,
2705 TREE_TYPE (se
.expr
), high
, cse
.expr
);
2706 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
2708 build_empty_stmt (input_location
));
2711 gfc_add_expr_to_block (&block
, tmp
);
2722 return gfc_finish_block (&block
);
2726 /* Translate the SELECT CASE construct for INTEGER case expressions,
2727 without killing all potential optimizations. The problem is that
2728 Fortran allows unbounded cases, but the back-end does not, so we
2729 need to intercept those before we enter the equivalent SWITCH_EXPR
2732 For example, we translate this,
2735 CASE (:100,101,105:115)
2745 to the GENERIC equivalent,
2749 case (minimum value for typeof(expr) ... 100:
2755 case 200 ... (maximum value for typeof(expr):
2772 gfc_trans_integer_select (gfc_code
* code
)
2782 gfc_start_block (&block
);
2784 /* Calculate the switch expression. */
2785 gfc_init_se (&se
, NULL
);
2786 gfc_conv_expr_val (&se
, code
->expr1
);
2787 gfc_add_block_to_block (&block
, &se
.pre
);
2789 end_label
= gfc_build_label_decl (NULL_TREE
);
2791 gfc_init_block (&body
);
2793 for (c
= code
->block
; c
; c
= c
->block
)
2795 for (cp
= c
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
2800 /* Assume it's the default case. */
2801 low
= high
= NULL_TREE
;
2805 low
= gfc_conv_mpz_to_tree (cp
->low
->value
.integer
,
2808 /* If there's only a lower bound, set the high bound to the
2809 maximum value of the case expression. */
2811 high
= TYPE_MAX_VALUE (TREE_TYPE (se
.expr
));
2816 /* Three cases are possible here:
2818 1) There is no lower bound, e.g. CASE (:N).
2819 2) There is a lower bound .NE. high bound, that is
2820 a case range, e.g. CASE (N:M) where M>N (we make
2821 sure that M>N during type resolution).
2822 3) There is a lower bound, and it has the same value
2823 as the high bound, e.g. CASE (N:N). This is our
2824 internal representation of CASE(N).
2826 In the first and second case, we need to set a value for
2827 high. In the third case, we don't because the GCC middle
2828 end represents a single case value by just letting high be
2829 a NULL_TREE. We can't do that because we need to be able
2830 to represent unbounded cases. */
2833 || (mpz_cmp (cp
->low
->value
.integer
,
2834 cp
->high
->value
.integer
) != 0))
2835 high
= gfc_conv_mpz_to_tree (cp
->high
->value
.integer
,
2838 /* Unbounded case. */
2840 low
= TYPE_MIN_VALUE (TREE_TYPE (se
.expr
));
2843 /* Build a label. */
2844 label
= gfc_build_label_decl (NULL_TREE
);
2846 /* Add this case label.
2847 Add parameter 'label', make it match GCC backend. */
2848 tmp
= build_case_label (low
, high
, label
);
2849 gfc_add_expr_to_block (&body
, tmp
);
2852 /* Add the statements for this case. */
2853 tmp
= gfc_trans_code (c
->next
);
2854 gfc_add_expr_to_block (&body
, tmp
);
2856 /* Break to the end of the construct. */
2857 tmp
= build1_v (GOTO_EXPR
, end_label
);
2858 gfc_add_expr_to_block (&body
, tmp
);
2861 tmp
= gfc_finish_block (&body
);
2862 tmp
= fold_build2_loc (input_location
, SWITCH_EXPR
, NULL_TREE
, se
.expr
, tmp
);
2863 gfc_add_expr_to_block (&block
, tmp
);
2865 tmp
= build1_v (LABEL_EXPR
, end_label
);
2866 gfc_add_expr_to_block (&block
, tmp
);
2868 return gfc_finish_block (&block
);
2872 /* Translate the SELECT CASE construct for LOGICAL case expressions.
2874 There are only two cases possible here, even though the standard
2875 does allow three cases in a LOGICAL SELECT CASE construct: .TRUE.,
2876 .FALSE., and DEFAULT.
2878 We never generate more than two blocks here. Instead, we always
2879 try to eliminate the DEFAULT case. This way, we can translate this
2880 kind of SELECT construct to a simple
2884 expression in GENERIC. */
2887 gfc_trans_logical_select (gfc_code
* code
)
2890 gfc_code
*t
, *f
, *d
;
2895 /* Assume we don't have any cases at all. */
2898 /* Now see which ones we actually do have. We can have at most two
2899 cases in a single case list: one for .TRUE. and one for .FALSE.
2900 The default case is always separate. If the cases for .TRUE. and
2901 .FALSE. are in the same case list, the block for that case list
2902 always executed, and we don't generate code a COND_EXPR. */
2903 for (c
= code
->block
; c
; c
= c
->block
)
2905 for (cp
= c
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
2909 if (cp
->low
->value
.logical
== 0) /* .FALSE. */
2911 else /* if (cp->value.logical != 0), thus .TRUE. */
2919 /* Start a new block. */
2920 gfc_start_block (&block
);
2922 /* Calculate the switch expression. We always need to do this
2923 because it may have side effects. */
2924 gfc_init_se (&se
, NULL
);
2925 gfc_conv_expr_val (&se
, code
->expr1
);
2926 gfc_add_block_to_block (&block
, &se
.pre
);
2928 if (t
== f
&& t
!= NULL
)
2930 /* Cases for .TRUE. and .FALSE. are in the same block. Just
2931 translate the code for these cases, append it to the current
2933 gfc_add_expr_to_block (&block
, gfc_trans_code (t
->next
));
2937 tree true_tree
, false_tree
, stmt
;
2939 true_tree
= build_empty_stmt (input_location
);
2940 false_tree
= build_empty_stmt (input_location
);
2942 /* If we have a case for .TRUE. and for .FALSE., discard the default case.
2943 Otherwise, if .TRUE. or .FALSE. is missing and there is a default case,
2944 make the missing case the default case. */
2945 if (t
!= NULL
&& f
!= NULL
)
2955 /* Translate the code for each of these blocks, and append it to
2956 the current block. */
2958 true_tree
= gfc_trans_code (t
->next
);
2961 false_tree
= gfc_trans_code (f
->next
);
2963 stmt
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
2964 se
.expr
, true_tree
, false_tree
);
2965 gfc_add_expr_to_block (&block
, stmt
);
2968 return gfc_finish_block (&block
);
2972 /* The jump table types are stored in static variables to avoid
2973 constructing them from scratch every single time. */
2974 static GTY(()) tree select_struct
[2];
2976 /* Translate the SELECT CASE construct for CHARACTER case expressions.
2977 Instead of generating compares and jumps, it is far simpler to
2978 generate a data structure describing the cases in order and call a
2979 library subroutine that locates the right case.
2980 This is particularly true because this is the only case where we
2981 might have to dispose of a temporary.
2982 The library subroutine returns a pointer to jump to or NULL if no
2983 branches are to be taken. */
2986 gfc_trans_character_select (gfc_code
*code
)
2988 tree init
, end_label
, tmp
, type
, case_num
, label
, fndecl
;
2989 stmtblock_t block
, body
;
2994 vec
<constructor_elt
, va_gc
> *inits
= NULL
;
2996 tree pchartype
= gfc_get_pchar_type (code
->expr1
->ts
.kind
);
2998 /* The jump table types are stored in static variables to avoid
2999 constructing them from scratch every single time. */
3000 static tree ss_string1
[2], ss_string1_len
[2];
3001 static tree ss_string2
[2], ss_string2_len
[2];
3002 static tree ss_target
[2];
3004 cp
= code
->block
->ext
.block
.case_list
;
3005 while (cp
->left
!= NULL
)
3008 /* Generate the body */
3009 gfc_start_block (&block
);
3010 gfc_init_se (&expr1se
, NULL
);
3011 gfc_conv_expr_reference (&expr1se
, code
->expr1
);
3013 gfc_add_block_to_block (&block
, &expr1se
.pre
);
3015 end_label
= gfc_build_label_decl (NULL_TREE
);
3017 gfc_init_block (&body
);
3019 /* Attempt to optimize length 1 selects. */
3020 if (integer_onep (expr1se
.string_length
))
3022 for (d
= cp
; d
; d
= d
->right
)
3027 gcc_assert (d
->low
->expr_type
== EXPR_CONSTANT
3028 && d
->low
->ts
.type
== BT_CHARACTER
);
3029 if (d
->low
->value
.character
.length
> 1)
3031 for (i
= 1; i
< d
->low
->value
.character
.length
; i
++)
3032 if (d
->low
->value
.character
.string
[i
] != ' ')
3034 if (i
!= d
->low
->value
.character
.length
)
3036 if (optimize
&& d
->high
&& i
== 1)
3038 gcc_assert (d
->high
->expr_type
== EXPR_CONSTANT
3039 && d
->high
->ts
.type
== BT_CHARACTER
);
3040 if (d
->high
->value
.character
.length
> 1
3041 && (d
->low
->value
.character
.string
[0]
3042 == d
->high
->value
.character
.string
[0])
3043 && d
->high
->value
.character
.string
[1] != ' '
3044 && ((d
->low
->value
.character
.string
[1] < ' ')
3045 == (d
->high
->value
.character
.string
[1]
3055 gcc_assert (d
->high
->expr_type
== EXPR_CONSTANT
3056 && d
->high
->ts
.type
== BT_CHARACTER
);
3057 if (d
->high
->value
.character
.length
> 1)
3059 for (i
= 1; i
< d
->high
->value
.character
.length
; i
++)
3060 if (d
->high
->value
.character
.string
[i
] != ' ')
3062 if (i
!= d
->high
->value
.character
.length
)
3069 tree ctype
= gfc_get_char_type (code
->expr1
->ts
.kind
);
3071 for (c
= code
->block
; c
; c
= c
->block
)
3073 for (cp
= c
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
3079 /* Assume it's the default case. */
3080 low
= high
= NULL_TREE
;
3084 /* CASE ('ab') or CASE ('ab':'az') will never match
3085 any length 1 character. */
3086 if (cp
->low
->value
.character
.length
> 1
3087 && cp
->low
->value
.character
.string
[1] != ' ')
3090 if (cp
->low
->value
.character
.length
> 0)
3091 r
= cp
->low
->value
.character
.string
[0];
3094 low
= build_int_cst (ctype
, r
);
3096 /* If there's only a lower bound, set the high bound
3097 to the maximum value of the case expression. */
3099 high
= TYPE_MAX_VALUE (ctype
);
3105 || (cp
->low
->value
.character
.string
[0]
3106 != cp
->high
->value
.character
.string
[0]))
3108 if (cp
->high
->value
.character
.length
> 0)
3109 r
= cp
->high
->value
.character
.string
[0];
3112 high
= build_int_cst (ctype
, r
);
3115 /* Unbounded case. */
3117 low
= TYPE_MIN_VALUE (ctype
);
3120 /* Build a label. */
3121 label
= gfc_build_label_decl (NULL_TREE
);
3123 /* Add this case label.
3124 Add parameter 'label', make it match GCC backend. */
3125 tmp
= build_case_label (low
, high
, label
);
3126 gfc_add_expr_to_block (&body
, tmp
);
3129 /* Add the statements for this case. */
3130 tmp
= gfc_trans_code (c
->next
);
3131 gfc_add_expr_to_block (&body
, tmp
);
3133 /* Break to the end of the construct. */
3134 tmp
= build1_v (GOTO_EXPR
, end_label
);
3135 gfc_add_expr_to_block (&body
, tmp
);
3138 tmp
= gfc_string_to_single_character (expr1se
.string_length
,
3140 code
->expr1
->ts
.kind
);
3141 case_num
= gfc_create_var (ctype
, "case_num");
3142 gfc_add_modify (&block
, case_num
, tmp
);
3144 gfc_add_block_to_block (&block
, &expr1se
.post
);
3146 tmp
= gfc_finish_block (&body
);
3147 tmp
= fold_build2_loc (input_location
, SWITCH_EXPR
, NULL_TREE
,
3149 gfc_add_expr_to_block (&block
, tmp
);
3151 tmp
= build1_v (LABEL_EXPR
, end_label
);
3152 gfc_add_expr_to_block (&block
, tmp
);
3154 return gfc_finish_block (&block
);
3158 if (code
->expr1
->ts
.kind
== 1)
3160 else if (code
->expr1
->ts
.kind
== 4)
3165 if (select_struct
[k
] == NULL
)
3168 select_struct
[k
] = make_node (RECORD_TYPE
);
3170 if (code
->expr1
->ts
.kind
== 1)
3171 TYPE_NAME (select_struct
[k
]) = get_identifier ("_jump_struct_char1");
3172 else if (code
->expr1
->ts
.kind
== 4)
3173 TYPE_NAME (select_struct
[k
]) = get_identifier ("_jump_struct_char4");
3178 #define ADD_FIELD(NAME, TYPE) \
3179 ss_##NAME[k] = gfc_add_field_to_struct (select_struct[k], \
3180 get_identifier (stringize(NAME)), \
3184 ADD_FIELD (string1
, pchartype
);
3185 ADD_FIELD (string1_len
, gfc_charlen_type_node
);
3187 ADD_FIELD (string2
, pchartype
);
3188 ADD_FIELD (string2_len
, gfc_charlen_type_node
);
3190 ADD_FIELD (target
, integer_type_node
);
3193 gfc_finish_type (select_struct
[k
]);
3197 for (d
= cp
; d
; d
= d
->right
)
3200 for (c
= code
->block
; c
; c
= c
->block
)
3202 for (d
= c
->ext
.block
.case_list
; d
; d
= d
->next
)
3204 label
= gfc_build_label_decl (NULL_TREE
);
3205 tmp
= build_case_label ((d
->low
== NULL
&& d
->high
== NULL
)
3207 : build_int_cst (integer_type_node
, d
->n
),
3209 gfc_add_expr_to_block (&body
, tmp
);
3212 tmp
= gfc_trans_code (c
->next
);
3213 gfc_add_expr_to_block (&body
, tmp
);
3215 tmp
= build1_v (GOTO_EXPR
, end_label
);
3216 gfc_add_expr_to_block (&body
, tmp
);
3219 /* Generate the structure describing the branches */
3220 for (d
= cp
; d
; d
= d
->right
)
3222 vec
<constructor_elt
, va_gc
> *node
= NULL
;
3224 gfc_init_se (&se
, NULL
);
3228 CONSTRUCTOR_APPEND_ELT (node
, ss_string1
[k
], null_pointer_node
);
3229 CONSTRUCTOR_APPEND_ELT (node
, ss_string1_len
[k
], build_zero_cst (gfc_charlen_type_node
));
3233 gfc_conv_expr_reference (&se
, d
->low
);
3235 CONSTRUCTOR_APPEND_ELT (node
, ss_string1
[k
], se
.expr
);
3236 CONSTRUCTOR_APPEND_ELT (node
, ss_string1_len
[k
], se
.string_length
);
3239 if (d
->high
== NULL
)
3241 CONSTRUCTOR_APPEND_ELT (node
, ss_string2
[k
], null_pointer_node
);
3242 CONSTRUCTOR_APPEND_ELT (node
, ss_string2_len
[k
], build_zero_cst (gfc_charlen_type_node
));
3246 gfc_init_se (&se
, NULL
);
3247 gfc_conv_expr_reference (&se
, d
->high
);
3249 CONSTRUCTOR_APPEND_ELT (node
, ss_string2
[k
], se
.expr
);
3250 CONSTRUCTOR_APPEND_ELT (node
, ss_string2_len
[k
], se
.string_length
);
3253 CONSTRUCTOR_APPEND_ELT (node
, ss_target
[k
],
3254 build_int_cst (integer_type_node
, d
->n
));
3256 tmp
= build_constructor (select_struct
[k
], node
);
3257 CONSTRUCTOR_APPEND_ELT (inits
, NULL_TREE
, tmp
);
3260 type
= build_array_type (select_struct
[k
],
3261 build_index_type (size_int (n
-1)));
3263 init
= build_constructor (type
, inits
);
3264 TREE_CONSTANT (init
) = 1;
3265 TREE_STATIC (init
) = 1;
3266 /* Create a static variable to hold the jump table. */
3267 tmp
= gfc_create_var (type
, "jumptable");
3268 TREE_CONSTANT (tmp
) = 1;
3269 TREE_STATIC (tmp
) = 1;
3270 TREE_READONLY (tmp
) = 1;
3271 DECL_INITIAL (tmp
) = init
;
3274 /* Build the library call */
3275 init
= gfc_build_addr_expr (pvoid_type_node
, init
);
3277 if (code
->expr1
->ts
.kind
== 1)
3278 fndecl
= gfor_fndecl_select_string
;
3279 else if (code
->expr1
->ts
.kind
== 4)
3280 fndecl
= gfor_fndecl_select_string_char4
;
3284 tmp
= build_call_expr_loc (input_location
,
3286 build_int_cst (gfc_charlen_type_node
, n
),
3287 expr1se
.expr
, expr1se
.string_length
);
3288 case_num
= gfc_create_var (integer_type_node
, "case_num");
3289 gfc_add_modify (&block
, case_num
, tmp
);
3291 gfc_add_block_to_block (&block
, &expr1se
.post
);
3293 tmp
= gfc_finish_block (&body
);
3294 tmp
= fold_build2_loc (input_location
, SWITCH_EXPR
, NULL_TREE
,
3296 gfc_add_expr_to_block (&block
, tmp
);
3298 tmp
= build1_v (LABEL_EXPR
, end_label
);
3299 gfc_add_expr_to_block (&block
, tmp
);
3301 return gfc_finish_block (&block
);
3305 /* Translate the three variants of the SELECT CASE construct.
3307 SELECT CASEs with INTEGER case expressions can be translated to an
3308 equivalent GENERIC switch statement, and for LOGICAL case
3309 expressions we build one or two if-else compares.
3311 SELECT CASEs with CHARACTER case expressions are a whole different
3312 story, because they don't exist in GENERIC. So we sort them and
3313 do a binary search at runtime.
3315 Fortran has no BREAK statement, and it does not allow jumps from
3316 one case block to another. That makes things a lot easier for
3320 gfc_trans_select (gfc_code
* code
)
3326 gcc_assert (code
&& code
->expr1
);
3327 gfc_init_block (&block
);
3329 /* Build the exit label and hang it in. */
3330 exit_label
= gfc_build_label_decl (NULL_TREE
);
3331 code
->exit_label
= exit_label
;
3333 /* Empty SELECT constructs are legal. */
3334 if (code
->block
== NULL
)
3335 body
= build_empty_stmt (input_location
);
3337 /* Select the correct translation function. */
3339 switch (code
->expr1
->ts
.type
)
3342 body
= gfc_trans_logical_select (code
);
3346 body
= gfc_trans_integer_select (code
);
3350 body
= gfc_trans_character_select (code
);
3354 gfc_internal_error ("gfc_trans_select(): Bad type for case expr.");
3358 /* Build everything together. */
3359 gfc_add_expr_to_block (&block
, body
);
3360 gfc_add_expr_to_block (&block
, build1_v (LABEL_EXPR
, exit_label
));
3362 return gfc_finish_block (&block
);
3366 gfc_trans_select_type (gfc_code
* code
)
3372 gcc_assert (code
&& code
->expr1
);
3373 gfc_init_block (&block
);
3375 /* Build the exit label and hang it in. */
3376 exit_label
= gfc_build_label_decl (NULL_TREE
);
3377 code
->exit_label
= exit_label
;
3379 /* Empty SELECT constructs are legal. */
3380 if (code
->block
== NULL
)
3381 body
= build_empty_stmt (input_location
);
3383 body
= gfc_trans_select_type_cases (code
);
3385 /* Build everything together. */
3386 gfc_add_expr_to_block (&block
, body
);
3388 if (TREE_USED (exit_label
))
3389 gfc_add_expr_to_block (&block
, build1_v (LABEL_EXPR
, exit_label
));
3391 return gfc_finish_block (&block
);
3395 /* Traversal function to substitute a replacement symtree if the symbol
3396 in the expression is the same as that passed. f == 2 signals that
3397 that variable itself is not to be checked - only the references.
3398 This group of functions is used when the variable expression in a
3399 FORALL assignment has internal references. For example:
3400 FORALL (i = 1:4) p(p(i)) = i
3401 The only recourse here is to store a copy of 'p' for the index
3404 static gfc_symtree
*new_symtree
;
3405 static gfc_symtree
*old_symtree
;
3408 forall_replace (gfc_expr
*expr
, gfc_symbol
*sym
, int *f
)
3410 if (expr
->expr_type
!= EXPR_VARIABLE
)
3415 else if (expr
->symtree
->n
.sym
== sym
)
3416 expr
->symtree
= new_symtree
;
3422 forall_replace_symtree (gfc_expr
*e
, gfc_symbol
*sym
, int f
)
3424 gfc_traverse_expr (e
, sym
, forall_replace
, f
);
3428 forall_restore (gfc_expr
*expr
,
3429 gfc_symbol
*sym ATTRIBUTE_UNUSED
,
3430 int *f ATTRIBUTE_UNUSED
)
3432 if (expr
->expr_type
!= EXPR_VARIABLE
)
3435 if (expr
->symtree
== new_symtree
)
3436 expr
->symtree
= old_symtree
;
3442 forall_restore_symtree (gfc_expr
*e
)
3444 gfc_traverse_expr (e
, NULL
, forall_restore
, 0);
3448 forall_make_variable_temp (gfc_code
*c
, stmtblock_t
*pre
, stmtblock_t
*post
)
3453 gfc_symbol
*new_sym
;
3454 gfc_symbol
*old_sym
;
3458 /* Build a copy of the lvalue. */
3459 old_symtree
= c
->expr1
->symtree
;
3460 old_sym
= old_symtree
->n
.sym
;
3461 e
= gfc_lval_expr_from_sym (old_sym
);
3462 if (old_sym
->attr
.dimension
)
3464 gfc_init_se (&tse
, NULL
);
3465 gfc_conv_subref_array_arg (&tse
, e
, 0, INTENT_IN
, false);
3466 gfc_add_block_to_block (pre
, &tse
.pre
);
3467 gfc_add_block_to_block (post
, &tse
.post
);
3468 tse
.expr
= build_fold_indirect_ref_loc (input_location
, tse
.expr
);
3470 if (c
->expr1
->ref
->u
.ar
.type
!= AR_SECTION
)
3472 /* Use the variable offset for the temporary. */
3473 tmp
= gfc_conv_array_offset (old_sym
->backend_decl
);
3474 gfc_conv_descriptor_offset_set (pre
, tse
.expr
, tmp
);
3479 gfc_init_se (&tse
, NULL
);
3480 gfc_init_se (&rse
, NULL
);
3481 gfc_conv_expr (&rse
, e
);
3482 if (e
->ts
.type
== BT_CHARACTER
)
3484 tse
.string_length
= rse
.string_length
;
3485 tmp
= gfc_get_character_type_len (gfc_default_character_kind
,
3487 tse
.expr
= gfc_conv_string_tmp (&tse
, build_pointer_type (tmp
),
3489 gfc_add_block_to_block (pre
, &tse
.pre
);
3490 gfc_add_block_to_block (post
, &tse
.post
);
3494 tmp
= gfc_typenode_for_spec (&e
->ts
);
3495 tse
.expr
= gfc_create_var (tmp
, "temp");
3498 tmp
= gfc_trans_scalar_assign (&tse
, &rse
, e
->ts
,
3499 e
->expr_type
== EXPR_VARIABLE
, false);
3500 gfc_add_expr_to_block (pre
, tmp
);
3504 /* Create a new symbol to represent the lvalue. */
3505 new_sym
= gfc_new_symbol (old_sym
->name
, NULL
);
3506 new_sym
->ts
= old_sym
->ts
;
3507 new_sym
->attr
.referenced
= 1;
3508 new_sym
->attr
.temporary
= 1;
3509 new_sym
->attr
.dimension
= old_sym
->attr
.dimension
;
3510 new_sym
->attr
.flavor
= old_sym
->attr
.flavor
;
3512 /* Use the temporary as the backend_decl. */
3513 new_sym
->backend_decl
= tse
.expr
;
3515 /* Create a fake symtree for it. */
3517 new_symtree
= gfc_new_symtree (&root
, old_sym
->name
);
3518 new_symtree
->n
.sym
= new_sym
;
3519 gcc_assert (new_symtree
== root
);
3521 /* Go through the expression reference replacing the old_symtree
3523 forall_replace_symtree (c
->expr1
, old_sym
, 2);
3525 /* Now we have made this temporary, we might as well use it for
3526 the right hand side. */
3527 forall_replace_symtree (c
->expr2
, old_sym
, 1);
3531 /* Handles dependencies in forall assignments. */
3533 check_forall_dependencies (gfc_code
*c
, stmtblock_t
*pre
, stmtblock_t
*post
)
3540 lsym
= c
->expr1
->symtree
->n
.sym
;
3541 need_temp
= gfc_check_dependency (c
->expr1
, c
->expr2
, 0);
3543 /* Now check for dependencies within the 'variable'
3544 expression itself. These are treated by making a complete
3545 copy of variable and changing all the references to it
3546 point to the copy instead. Note that the shallow copy of
3547 the variable will not suffice for derived types with
3548 pointer components. We therefore leave these to their
3550 if (lsym
->ts
.type
== BT_DERIVED
3551 && lsym
->ts
.u
.derived
->attr
.pointer_comp
)
3555 if (find_forall_index (c
->expr1
, lsym
, 2))
3557 forall_make_variable_temp (c
, pre
, post
);
3561 /* Substrings with dependencies are treated in the same
3563 if (c
->expr1
->ts
.type
== BT_CHARACTER
3565 && c
->expr2
->expr_type
== EXPR_VARIABLE
3566 && lsym
== c
->expr2
->symtree
->n
.sym
)
3568 for (lref
= c
->expr1
->ref
; lref
; lref
= lref
->next
)
3569 if (lref
->type
== REF_SUBSTRING
)
3571 for (rref
= c
->expr2
->ref
; rref
; rref
= rref
->next
)
3572 if (rref
->type
== REF_SUBSTRING
)
3576 && gfc_dep_compare_expr (rref
->u
.ss
.start
, lref
->u
.ss
.start
) < 0)
3578 forall_make_variable_temp (c
, pre
, post
);
3587 cleanup_forall_symtrees (gfc_code
*c
)
3589 forall_restore_symtree (c
->expr1
);
3590 forall_restore_symtree (c
->expr2
);
3591 free (new_symtree
->n
.sym
);
3596 /* Generate the loops for a FORALL block, specified by FORALL_TMP. BODY
3597 is the contents of the FORALL block/stmt to be iterated. MASK_FLAG
3598 indicates whether we should generate code to test the FORALLs mask
3599 array. OUTER is the loop header to be used for initializing mask
3602 The generated loop format is:
3603 count = (end - start + step) / step
3616 gfc_trans_forall_loop (forall_info
*forall_tmp
, tree body
,
3617 int mask_flag
, stmtblock_t
*outer
)
3625 tree var
, start
, end
, step
;
3628 /* Initialize the mask index outside the FORALL nest. */
3629 if (mask_flag
&& forall_tmp
->mask
)
3630 gfc_add_modify (outer
, forall_tmp
->maskindex
, gfc_index_zero_node
);
3632 iter
= forall_tmp
->this_loop
;
3633 nvar
= forall_tmp
->nvar
;
3634 for (n
= 0; n
< nvar
; n
++)
3637 start
= iter
->start
;
3641 exit_label
= gfc_build_label_decl (NULL_TREE
);
3642 TREE_USED (exit_label
) = 1;
3644 /* The loop counter. */
3645 count
= gfc_create_var (TREE_TYPE (var
), "count");
3647 /* The body of the loop. */
3648 gfc_init_block (&block
);
3650 /* The exit condition. */
3651 cond
= fold_build2_loc (input_location
, LE_EXPR
, logical_type_node
,
3652 count
, build_int_cst (TREE_TYPE (count
), 0));
3654 /* PR 83064 means that we cannot use annot_expr_parallel_kind until
3655 the autoparallelizer can hande this. */
3656 if (forall_tmp
->do_concurrent
)
3657 cond
= build3 (ANNOTATE_EXPR
, TREE_TYPE (cond
), cond
,
3658 build_int_cst (integer_type_node
,
3659 annot_expr_ivdep_kind
),
3662 tmp
= build1_v (GOTO_EXPR
, exit_label
);
3663 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
3664 cond
, tmp
, build_empty_stmt (input_location
));
3665 gfc_add_expr_to_block (&block
, tmp
);
3667 /* The main loop body. */
3668 gfc_add_expr_to_block (&block
, body
);
3670 /* Increment the loop variable. */
3671 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (var
), var
,
3673 gfc_add_modify (&block
, var
, tmp
);
3675 /* Advance to the next mask element. Only do this for the
3677 if (n
== 0 && mask_flag
&& forall_tmp
->mask
)
3679 tree maskindex
= forall_tmp
->maskindex
;
3680 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
3681 maskindex
, gfc_index_one_node
);
3682 gfc_add_modify (&block
, maskindex
, tmp
);
3685 /* Decrement the loop counter. */
3686 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (var
), count
,
3687 build_int_cst (TREE_TYPE (var
), 1));
3688 gfc_add_modify (&block
, count
, tmp
);
3690 body
= gfc_finish_block (&block
);
3692 /* Loop var initialization. */
3693 gfc_init_block (&block
);
3694 gfc_add_modify (&block
, var
, start
);
3697 /* Initialize the loop counter. */
3698 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (var
), step
,
3700 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (var
), end
,
3702 tmp
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
, TREE_TYPE (var
),
3704 gfc_add_modify (&block
, count
, tmp
);
3706 /* The loop expression. */
3707 tmp
= build1_v (LOOP_EXPR
, body
);
3708 gfc_add_expr_to_block (&block
, tmp
);
3710 /* The exit label. */
3711 tmp
= build1_v (LABEL_EXPR
, exit_label
);
3712 gfc_add_expr_to_block (&block
, tmp
);
3714 body
= gfc_finish_block (&block
);
3721 /* Generate the body and loops according to MASK_FLAG. If MASK_FLAG
3722 is nonzero, the body is controlled by all masks in the forall nest.
3723 Otherwise, the innermost loop is not controlled by it's mask. This
3724 is used for initializing that mask. */
3727 gfc_trans_nested_forall_loop (forall_info
* nested_forall_info
, tree body
,
3732 forall_info
*forall_tmp
;
3733 tree mask
, maskindex
;
3735 gfc_start_block (&header
);
3737 forall_tmp
= nested_forall_info
;
3738 while (forall_tmp
!= NULL
)
3740 /* Generate body with masks' control. */
3743 mask
= forall_tmp
->mask
;
3744 maskindex
= forall_tmp
->maskindex
;
3746 /* If a mask was specified make the assignment conditional. */
3749 tmp
= gfc_build_array_ref (mask
, maskindex
, NULL
);
3750 body
= build3_v (COND_EXPR
, tmp
, body
,
3751 build_empty_stmt (input_location
));
3754 body
= gfc_trans_forall_loop (forall_tmp
, body
, mask_flag
, &header
);
3755 forall_tmp
= forall_tmp
->prev_nest
;
3759 gfc_add_expr_to_block (&header
, body
);
3760 return gfc_finish_block (&header
);
3764 /* Allocate data for holding a temporary array. Returns either a local
3765 temporary array or a pointer variable. */
3768 gfc_do_allocate (tree bytesize
, tree size
, tree
* pdata
, stmtblock_t
* pblock
,
3775 if (INTEGER_CST_P (size
))
3776 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
3777 size
, gfc_index_one_node
);
3781 type
= build_range_type (gfc_array_index_type
, gfc_index_zero_node
, tmp
);
3782 type
= build_array_type (elem_type
, type
);
3783 if (gfc_can_put_var_on_stack (bytesize
) && INTEGER_CST_P (size
))
3785 tmpvar
= gfc_create_var (type
, "temp");
3790 tmpvar
= gfc_create_var (build_pointer_type (type
), "temp");
3791 *pdata
= convert (pvoid_type_node
, tmpvar
);
3793 tmp
= gfc_call_malloc (pblock
, TREE_TYPE (tmpvar
), bytesize
);
3794 gfc_add_modify (pblock
, tmpvar
, tmp
);
3800 /* Generate codes to copy the temporary to the actual lhs. */
3803 generate_loop_for_temp_to_lhs (gfc_expr
*expr
, tree tmp1
, tree count3
,
3805 gfc_ss
*lss
, gfc_ss
*rss
,
3806 tree wheremask
, bool invert
)
3808 stmtblock_t block
, body1
;
3815 (void) rss
; /* TODO: unused. */
3817 gfc_start_block (&block
);
3819 gfc_init_se (&rse
, NULL
);
3820 gfc_init_se (&lse
, NULL
);
3822 if (lss
== gfc_ss_terminator
)
3824 gfc_init_block (&body1
);
3825 gfc_conv_expr (&lse
, expr
);
3826 rse
.expr
= gfc_build_array_ref (tmp1
, count1
, NULL
);
3830 /* Initialize the loop. */
3831 gfc_init_loopinfo (&loop
);
3833 /* We may need LSS to determine the shape of the expression. */
3834 gfc_add_ss_to_loop (&loop
, lss
);
3836 gfc_conv_ss_startstride (&loop
);
3837 gfc_conv_loop_setup (&loop
, &expr
->where
);
3839 gfc_mark_ss_chain_used (lss
, 1);
3840 /* Start the loop body. */
3841 gfc_start_scalarized_body (&loop
, &body1
);
3843 /* Translate the expression. */
3844 gfc_copy_loopinfo_to_se (&lse
, &loop
);
3846 gfc_conv_expr (&lse
, expr
);
3848 /* Form the expression of the temporary. */
3849 rse
.expr
= gfc_build_array_ref (tmp1
, count1
, NULL
);
3852 /* Use the scalar assignment. */
3853 rse
.string_length
= lse
.string_length
;
3854 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
,
3855 expr
->expr_type
== EXPR_VARIABLE
, false);
3857 /* Form the mask expression according to the mask tree list. */
3860 wheremaskexpr
= gfc_build_array_ref (wheremask
, count3
, NULL
);
3862 wheremaskexpr
= fold_build1_loc (input_location
, TRUTH_NOT_EXPR
,
3863 TREE_TYPE (wheremaskexpr
),
3865 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
3867 build_empty_stmt (input_location
));
3870 gfc_add_expr_to_block (&body1
, tmp
);
3872 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (count1
),
3873 count1
, gfc_index_one_node
);
3874 gfc_add_modify (&body1
, count1
, tmp
);
3876 if (lss
== gfc_ss_terminator
)
3877 gfc_add_block_to_block (&block
, &body1
);
3880 /* Increment count3. */
3883 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
3884 gfc_array_index_type
,
3885 count3
, gfc_index_one_node
);
3886 gfc_add_modify (&body1
, count3
, tmp
);
3889 /* Generate the copying loops. */
3890 gfc_trans_scalarizing_loops (&loop
, &body1
);
3892 gfc_add_block_to_block (&block
, &loop
.pre
);
3893 gfc_add_block_to_block (&block
, &loop
.post
);
3895 gfc_cleanup_loop (&loop
);
3896 /* TODO: Reuse lss and rss when copying temp->lhs. Need to be careful
3897 as tree nodes in SS may not be valid in different scope. */
3900 tmp
= gfc_finish_block (&block
);
3905 /* Generate codes to copy rhs to the temporary. TMP1 is the address of
3906 temporary, LSS and RSS are formed in function compute_inner_temp_size(),
3907 and should not be freed. WHEREMASK is the conditional execution mask
3908 whose sense may be inverted by INVERT. */
3911 generate_loop_for_rhs_to_temp (gfc_expr
*expr2
, tree tmp1
, tree count3
,
3912 tree count1
, gfc_ss
*lss
, gfc_ss
*rss
,
3913 tree wheremask
, bool invert
)
3915 stmtblock_t block
, body1
;
3922 gfc_start_block (&block
);
3924 gfc_init_se (&rse
, NULL
);
3925 gfc_init_se (&lse
, NULL
);
3927 if (lss
== gfc_ss_terminator
)
3929 gfc_init_block (&body1
);
3930 gfc_conv_expr (&rse
, expr2
);
3931 lse
.expr
= gfc_build_array_ref (tmp1
, count1
, NULL
);
3935 /* Initialize the loop. */
3936 gfc_init_loopinfo (&loop
);
3938 /* We may need LSS to determine the shape of the expression. */
3939 gfc_add_ss_to_loop (&loop
, lss
);
3940 gfc_add_ss_to_loop (&loop
, rss
);
3942 gfc_conv_ss_startstride (&loop
);
3943 gfc_conv_loop_setup (&loop
, &expr2
->where
);
3945 gfc_mark_ss_chain_used (rss
, 1);
3946 /* Start the loop body. */
3947 gfc_start_scalarized_body (&loop
, &body1
);
3949 /* Translate the expression. */
3950 gfc_copy_loopinfo_to_se (&rse
, &loop
);
3952 gfc_conv_expr (&rse
, expr2
);
3954 /* Form the expression of the temporary. */
3955 lse
.expr
= gfc_build_array_ref (tmp1
, count1
, NULL
);
3958 /* Use the scalar assignment. */
3959 lse
.string_length
= rse
.string_length
;
3960 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr2
->ts
,
3961 expr2
->expr_type
== EXPR_VARIABLE
, false);
3963 /* Form the mask expression according to the mask tree list. */
3966 wheremaskexpr
= gfc_build_array_ref (wheremask
, count3
, NULL
);
3968 wheremaskexpr
= fold_build1_loc (input_location
, TRUTH_NOT_EXPR
,
3969 TREE_TYPE (wheremaskexpr
),
3971 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
3973 build_empty_stmt (input_location
));
3976 gfc_add_expr_to_block (&body1
, tmp
);
3978 if (lss
== gfc_ss_terminator
)
3980 gfc_add_block_to_block (&block
, &body1
);
3982 /* Increment count1. */
3983 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (count1
),
3984 count1
, gfc_index_one_node
);
3985 gfc_add_modify (&block
, count1
, tmp
);
3989 /* Increment count1. */
3990 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
3991 count1
, gfc_index_one_node
);
3992 gfc_add_modify (&body1
, count1
, tmp
);
3994 /* Increment count3. */
3997 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
3998 gfc_array_index_type
,
3999 count3
, gfc_index_one_node
);
4000 gfc_add_modify (&body1
, count3
, tmp
);
4003 /* Generate the copying loops. */
4004 gfc_trans_scalarizing_loops (&loop
, &body1
);
4006 gfc_add_block_to_block (&block
, &loop
.pre
);
4007 gfc_add_block_to_block (&block
, &loop
.post
);
4009 gfc_cleanup_loop (&loop
);
4010 /* TODO: Reuse lss and rss when copying temp->lhs. Need to be careful
4011 as tree nodes in SS may not be valid in different scope. */
4014 tmp
= gfc_finish_block (&block
);
4019 /* Calculate the size of temporary needed in the assignment inside forall.
4020 LSS and RSS are filled in this function. */
4023 compute_inner_temp_size (gfc_expr
*expr1
, gfc_expr
*expr2
,
4024 stmtblock_t
* pblock
,
4025 gfc_ss
**lss
, gfc_ss
**rss
)
4033 *lss
= gfc_walk_expr (expr1
);
4036 size
= gfc_index_one_node
;
4037 if (*lss
!= gfc_ss_terminator
)
4039 gfc_init_loopinfo (&loop
);
4041 /* Walk the RHS of the expression. */
4042 *rss
= gfc_walk_expr (expr2
);
4043 if (*rss
== gfc_ss_terminator
)
4044 /* The rhs is scalar. Add a ss for the expression. */
4045 *rss
= gfc_get_scalar_ss (gfc_ss_terminator
, expr2
);
4047 /* Associate the SS with the loop. */
4048 gfc_add_ss_to_loop (&loop
, *lss
);
4049 /* We don't actually need to add the rhs at this point, but it might
4050 make guessing the loop bounds a bit easier. */
4051 gfc_add_ss_to_loop (&loop
, *rss
);
4053 /* We only want the shape of the expression, not rest of the junk
4054 generated by the scalarizer. */
4055 loop
.array_parameter
= 1;
4057 /* Calculate the bounds of the scalarization. */
4058 save_flag
= gfc_option
.rtcheck
;
4059 gfc_option
.rtcheck
&= ~GFC_RTCHECK_BOUNDS
;
4060 gfc_conv_ss_startstride (&loop
);
4061 gfc_option
.rtcheck
= save_flag
;
4062 gfc_conv_loop_setup (&loop
, &expr2
->where
);
4064 /* Figure out how many elements we need. */
4065 for (i
= 0; i
< loop
.dimen
; i
++)
4067 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4068 gfc_array_index_type
,
4069 gfc_index_one_node
, loop
.from
[i
]);
4070 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
4071 gfc_array_index_type
, tmp
, loop
.to
[i
]);
4072 size
= fold_build2_loc (input_location
, MULT_EXPR
,
4073 gfc_array_index_type
, size
, tmp
);
4075 gfc_add_block_to_block (pblock
, &loop
.pre
);
4076 size
= gfc_evaluate_now (size
, pblock
);
4077 gfc_add_block_to_block (pblock
, &loop
.post
);
4079 /* TODO: write a function that cleans up a loopinfo without freeing
4080 the SS chains. Currently a NOP. */
4087 /* Calculate the overall iterator number of the nested forall construct.
4088 This routine actually calculates the number of times the body of the
4089 nested forall specified by NESTED_FORALL_INFO is executed and multiplies
4090 that by the expression INNER_SIZE. The BLOCK argument specifies the
4091 block in which to calculate the result, and the optional INNER_SIZE_BODY
4092 argument contains any statements that need to executed (inside the loop)
4093 to initialize or calculate INNER_SIZE. */
4096 compute_overall_iter_number (forall_info
*nested_forall_info
, tree inner_size
,
4097 stmtblock_t
*inner_size_body
, stmtblock_t
*block
)
4099 forall_info
*forall_tmp
= nested_forall_info
;
4103 /* We can eliminate the innermost unconditional loops with constant
4105 if (INTEGER_CST_P (inner_size
))
4108 && !forall_tmp
->mask
4109 && INTEGER_CST_P (forall_tmp
->size
))
4111 inner_size
= fold_build2_loc (input_location
, MULT_EXPR
,
4112 gfc_array_index_type
,
4113 inner_size
, forall_tmp
->size
);
4114 forall_tmp
= forall_tmp
->prev_nest
;
4117 /* If there are no loops left, we have our constant result. */
4122 /* Otherwise, create a temporary variable to compute the result. */
4123 number
= gfc_create_var (gfc_array_index_type
, "num");
4124 gfc_add_modify (block
, number
, gfc_index_zero_node
);
4126 gfc_start_block (&body
);
4127 if (inner_size_body
)
4128 gfc_add_block_to_block (&body
, inner_size_body
);
4130 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
4131 gfc_array_index_type
, number
, inner_size
);
4134 gfc_add_modify (&body
, number
, tmp
);
4135 tmp
= gfc_finish_block (&body
);
4137 /* Generate loops. */
4138 if (forall_tmp
!= NULL
)
4139 tmp
= gfc_trans_nested_forall_loop (forall_tmp
, tmp
, 1);
4141 gfc_add_expr_to_block (block
, tmp
);
4147 /* Allocate temporary for forall construct. SIZE is the size of temporary
4148 needed. PTEMP1 is returned for space free. */
4151 allocate_temp_for_forall_nest_1 (tree type
, tree size
, stmtblock_t
* block
,
4158 unit
= fold_convert (gfc_array_index_type
, TYPE_SIZE_UNIT (type
));
4159 if (!integer_onep (unit
))
4160 bytesize
= fold_build2_loc (input_location
, MULT_EXPR
,
4161 gfc_array_index_type
, size
, unit
);
4166 tmp
= gfc_do_allocate (bytesize
, size
, ptemp1
, block
, type
);
4169 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
4174 /* Allocate temporary for forall construct according to the information in
4175 nested_forall_info. INNER_SIZE is the size of temporary needed in the
4176 assignment inside forall. PTEMP1 is returned for space free. */
4179 allocate_temp_for_forall_nest (forall_info
* nested_forall_info
, tree type
,
4180 tree inner_size
, stmtblock_t
* inner_size_body
,
4181 stmtblock_t
* block
, tree
* ptemp1
)
4185 /* Calculate the total size of temporary needed in forall construct. */
4186 size
= compute_overall_iter_number (nested_forall_info
, inner_size
,
4187 inner_size_body
, block
);
4189 return allocate_temp_for_forall_nest_1 (type
, size
, block
, ptemp1
);
4193 /* Handle assignments inside forall which need temporary.
4195 forall (i=start:end:stride; maskexpr)
4198 (where e,f<i> are arbitrary expressions possibly involving i
4199 and there is a dependency between e<i> and f<i>)
4201 masktmp(:) = maskexpr(:)
4206 for (i = start; i <= end; i += stride)
4210 for (i = start; i <= end; i += stride)
4212 if (masktmp[maskindex++])
4213 tmp[count1++] = f<i>
4217 for (i = start; i <= end; i += stride)
4219 if (masktmp[maskindex++])
4220 e<i> = tmp[count1++]
4225 gfc_trans_assign_need_temp (gfc_expr
* expr1
, gfc_expr
* expr2
,
4226 tree wheremask
, bool invert
,
4227 forall_info
* nested_forall_info
,
4228 stmtblock_t
* block
)
4236 stmtblock_t inner_size_body
;
4238 /* Create vars. count1 is the current iterator number of the nested
4240 count1
= gfc_create_var (gfc_array_index_type
, "count1");
4242 /* Count is the wheremask index. */
4245 count
= gfc_create_var (gfc_array_index_type
, "count");
4246 gfc_add_modify (block
, count
, gfc_index_zero_node
);
4251 /* Initialize count1. */
4252 gfc_add_modify (block
, count1
, gfc_index_zero_node
);
4254 /* Calculate the size of temporary needed in the assignment. Return loop, lss
4255 and rss which are used in function generate_loop_for_rhs_to_temp(). */
4256 /* The type of LHS. Used in function allocate_temp_for_forall_nest */
4257 if (expr1
->ts
.type
== BT_CHARACTER
)
4260 if (expr1
->ref
&& expr1
->ref
->type
== REF_SUBSTRING
)
4263 gfc_init_se (&ssse
, NULL
);
4264 gfc_conv_expr (&ssse
, expr1
);
4265 type
= gfc_get_character_type_len (gfc_default_character_kind
,
4266 ssse
.string_length
);
4270 if (!expr1
->ts
.u
.cl
->backend_decl
)
4273 gcc_assert (expr1
->ts
.u
.cl
->length
);
4274 gfc_init_se (&tse
, NULL
);
4275 gfc_conv_expr (&tse
, expr1
->ts
.u
.cl
->length
);
4276 expr1
->ts
.u
.cl
->backend_decl
= tse
.expr
;
4278 type
= gfc_get_character_type_len (gfc_default_character_kind
,
4279 expr1
->ts
.u
.cl
->backend_decl
);
4283 type
= gfc_typenode_for_spec (&expr1
->ts
);
4285 gfc_init_block (&inner_size_body
);
4286 inner_size
= compute_inner_temp_size (expr1
, expr2
, &inner_size_body
,
4289 /* Allocate temporary for nested forall construct according to the
4290 information in nested_forall_info and inner_size. */
4291 tmp1
= allocate_temp_for_forall_nest (nested_forall_info
, type
, inner_size
,
4292 &inner_size_body
, block
, &ptemp1
);
4294 /* Generate codes to copy rhs to the temporary . */
4295 tmp
= generate_loop_for_rhs_to_temp (expr2
, tmp1
, count
, count1
, lss
, rss
,
4298 /* Generate body and loops according to the information in
4299 nested_forall_info. */
4300 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, tmp
, 1);
4301 gfc_add_expr_to_block (block
, tmp
);
4304 gfc_add_modify (block
, count1
, gfc_index_zero_node
);
4308 gfc_add_modify (block
, count
, gfc_index_zero_node
);
4310 /* TODO: Second call to compute_inner_temp_size to initialize lss and
4311 rss; there must be a better way. */
4312 inner_size
= compute_inner_temp_size (expr1
, expr2
, &inner_size_body
,
4315 /* Generate codes to copy the temporary to lhs. */
4316 tmp
= generate_loop_for_temp_to_lhs (expr1
, tmp1
, count
, count1
,
4320 /* Generate body and loops according to the information in
4321 nested_forall_info. */
4322 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, tmp
, 1);
4323 gfc_add_expr_to_block (block
, tmp
);
4327 /* Free the temporary. */
4328 tmp
= gfc_call_free (ptemp1
);
4329 gfc_add_expr_to_block (block
, tmp
);
4334 /* Translate pointer assignment inside FORALL which need temporary. */
4337 gfc_trans_pointer_assign_need_temp (gfc_expr
* expr1
, gfc_expr
* expr2
,
4338 forall_info
* nested_forall_info
,
4339 stmtblock_t
* block
)
4346 gfc_array_info
*info
;
4353 tree tmp
, tmp1
, ptemp1
;
4355 count
= gfc_create_var (gfc_array_index_type
, "count");
4356 gfc_add_modify (block
, count
, gfc_index_zero_node
);
4358 inner_size
= gfc_index_one_node
;
4359 lss
= gfc_walk_expr (expr1
);
4360 rss
= gfc_walk_expr (expr2
);
4361 if (lss
== gfc_ss_terminator
)
4363 type
= gfc_typenode_for_spec (&expr1
->ts
);
4364 type
= build_pointer_type (type
);
4366 /* Allocate temporary for nested forall construct according to the
4367 information in nested_forall_info and inner_size. */
4368 tmp1
= allocate_temp_for_forall_nest (nested_forall_info
, type
,
4369 inner_size
, NULL
, block
, &ptemp1
);
4370 gfc_start_block (&body
);
4371 gfc_init_se (&lse
, NULL
);
4372 lse
.expr
= gfc_build_array_ref (tmp1
, count
, NULL
);
4373 gfc_init_se (&rse
, NULL
);
4374 rse
.want_pointer
= 1;
4375 gfc_conv_expr (&rse
, expr2
);
4376 gfc_add_block_to_block (&body
, &rse
.pre
);
4377 gfc_add_modify (&body
, lse
.expr
,
4378 fold_convert (TREE_TYPE (lse
.expr
), rse
.expr
));
4379 gfc_add_block_to_block (&body
, &rse
.post
);
4381 /* Increment count. */
4382 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
4383 count
, gfc_index_one_node
);
4384 gfc_add_modify (&body
, count
, tmp
);
4386 tmp
= gfc_finish_block (&body
);
4388 /* Generate body and loops according to the information in
4389 nested_forall_info. */
4390 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, tmp
, 1);
4391 gfc_add_expr_to_block (block
, tmp
);
4394 gfc_add_modify (block
, count
, gfc_index_zero_node
);
4396 gfc_start_block (&body
);
4397 gfc_init_se (&lse
, NULL
);
4398 gfc_init_se (&rse
, NULL
);
4399 rse
.expr
= gfc_build_array_ref (tmp1
, count
, NULL
);
4400 lse
.want_pointer
= 1;
4401 gfc_conv_expr (&lse
, expr1
);
4402 gfc_add_block_to_block (&body
, &lse
.pre
);
4403 gfc_add_modify (&body
, lse
.expr
, rse
.expr
);
4404 gfc_add_block_to_block (&body
, &lse
.post
);
4405 /* Increment count. */
4406 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
4407 count
, gfc_index_one_node
);
4408 gfc_add_modify (&body
, count
, tmp
);
4409 tmp
= gfc_finish_block (&body
);
4411 /* Generate body and loops according to the information in
4412 nested_forall_info. */
4413 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, tmp
, 1);
4414 gfc_add_expr_to_block (block
, tmp
);
4418 gfc_init_loopinfo (&loop
);
4420 /* Associate the SS with the loop. */
4421 gfc_add_ss_to_loop (&loop
, rss
);
4423 /* Setup the scalarizing loops and bounds. */
4424 gfc_conv_ss_startstride (&loop
);
4426 gfc_conv_loop_setup (&loop
, &expr2
->where
);
4428 info
= &rss
->info
->data
.array
;
4429 desc
= info
->descriptor
;
4431 /* Make a new descriptor. */
4432 parmtype
= gfc_get_element_type (TREE_TYPE (desc
));
4433 parmtype
= gfc_get_array_type_bounds (parmtype
, loop
.dimen
, 0,
4434 loop
.from
, loop
.to
, 1,
4435 GFC_ARRAY_UNKNOWN
, true);
4437 /* Allocate temporary for nested forall construct. */
4438 tmp1
= allocate_temp_for_forall_nest (nested_forall_info
, parmtype
,
4439 inner_size
, NULL
, block
, &ptemp1
);
4440 gfc_start_block (&body
);
4441 gfc_init_se (&lse
, NULL
);
4442 lse
.expr
= gfc_build_array_ref (tmp1
, count
, NULL
);
4443 lse
.direct_byref
= 1;
4444 gfc_conv_expr_descriptor (&lse
, expr2
);
4446 gfc_add_block_to_block (&body
, &lse
.pre
);
4447 gfc_add_block_to_block (&body
, &lse
.post
);
4449 /* Increment count. */
4450 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
4451 count
, gfc_index_one_node
);
4452 gfc_add_modify (&body
, count
, tmp
);
4454 tmp
= gfc_finish_block (&body
);
4456 /* Generate body and loops according to the information in
4457 nested_forall_info. */
4458 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, tmp
, 1);
4459 gfc_add_expr_to_block (block
, tmp
);
4462 gfc_add_modify (block
, count
, gfc_index_zero_node
);
4464 parm
= gfc_build_array_ref (tmp1
, count
, NULL
);
4465 gfc_init_se (&lse
, NULL
);
4466 gfc_conv_expr_descriptor (&lse
, expr1
);
4467 gfc_add_modify (&lse
.pre
, lse
.expr
, parm
);
4468 gfc_start_block (&body
);
4469 gfc_add_block_to_block (&body
, &lse
.pre
);
4470 gfc_add_block_to_block (&body
, &lse
.post
);
4472 /* Increment count. */
4473 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
4474 count
, gfc_index_one_node
);
4475 gfc_add_modify (&body
, count
, tmp
);
4477 tmp
= gfc_finish_block (&body
);
4479 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, tmp
, 1);
4480 gfc_add_expr_to_block (block
, tmp
);
4482 /* Free the temporary. */
4485 tmp
= gfc_call_free (ptemp1
);
4486 gfc_add_expr_to_block (block
, tmp
);
4491 /* FORALL and WHERE statements are really nasty, especially when you nest
4492 them. All the rhs of a forall assignment must be evaluated before the
4493 actual assignments are performed. Presumably this also applies to all the
4494 assignments in an inner where statement. */
4496 /* Generate code for a FORALL statement. Any temporaries are allocated as a
4497 linear array, relying on the fact that we process in the same order in all
4500 forall (i=start:end:stride; maskexpr)
4504 (where e,f,g,h<i> are arbitrary expressions possibly involving i)
4506 count = ((end + 1 - start) / stride)
4507 masktmp(:) = maskexpr(:)
4510 for (i = start; i <= end; i += stride)
4512 if (masktmp[maskindex++])
4516 for (i = start; i <= end; i += stride)
4518 if (masktmp[maskindex++])
4522 Note that this code only works when there are no dependencies.
4523 Forall loop with array assignments and data dependencies are a real pain,
4524 because the size of the temporary cannot always be determined before the
4525 loop is executed. This problem is compounded by the presence of nested
4530 gfc_trans_forall_1 (gfc_code
* code
, forall_info
* nested_forall_info
)
4547 tree cycle_label
= NULL_TREE
;
4551 gfc_forall_iterator
*fa
;
4554 gfc_saved_var
*saved_vars
;
4555 iter_info
*this_forall
;
4559 /* Do nothing if the mask is false. */
4561 && code
->expr1
->expr_type
== EXPR_CONSTANT
4562 && !code
->expr1
->value
.logical
)
4563 return build_empty_stmt (input_location
);
4566 /* Count the FORALL index number. */
4567 for (fa
= code
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
4571 /* Allocate the space for var, start, end, step, varexpr. */
4572 var
= XCNEWVEC (tree
, nvar
);
4573 start
= XCNEWVEC (tree
, nvar
);
4574 end
= XCNEWVEC (tree
, nvar
);
4575 step
= XCNEWVEC (tree
, nvar
);
4576 varexpr
= XCNEWVEC (gfc_expr
*, nvar
);
4577 saved_vars
= XCNEWVEC (gfc_saved_var
, nvar
);
4579 /* Allocate the space for info. */
4580 info
= XCNEW (forall_info
);
4582 gfc_start_block (&pre
);
4583 gfc_init_block (&post
);
4584 gfc_init_block (&block
);
4587 for (fa
= code
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
4589 gfc_symbol
*sym
= fa
->var
->symtree
->n
.sym
;
4591 /* Allocate space for this_forall. */
4592 this_forall
= XCNEW (iter_info
);
4594 /* Create a temporary variable for the FORALL index. */
4595 tmp
= gfc_typenode_for_spec (&sym
->ts
);
4596 var
[n
] = gfc_create_var (tmp
, sym
->name
);
4597 gfc_shadow_sym (sym
, var
[n
], &saved_vars
[n
]);
4599 /* Record it in this_forall. */
4600 this_forall
->var
= var
[n
];
4602 /* Replace the index symbol's backend_decl with the temporary decl. */
4603 sym
->backend_decl
= var
[n
];
4605 /* Work out the start, end and stride for the loop. */
4606 gfc_init_se (&se
, NULL
);
4607 gfc_conv_expr_val (&se
, fa
->start
);
4608 /* Record it in this_forall. */
4609 this_forall
->start
= se
.expr
;
4610 gfc_add_block_to_block (&block
, &se
.pre
);
4613 gfc_init_se (&se
, NULL
);
4614 gfc_conv_expr_val (&se
, fa
->end
);
4615 /* Record it in this_forall. */
4616 this_forall
->end
= se
.expr
;
4617 gfc_make_safe_expr (&se
);
4618 gfc_add_block_to_block (&block
, &se
.pre
);
4621 gfc_init_se (&se
, NULL
);
4622 gfc_conv_expr_val (&se
, fa
->stride
);
4623 /* Record it in this_forall. */
4624 this_forall
->step
= se
.expr
;
4625 gfc_make_safe_expr (&se
);
4626 gfc_add_block_to_block (&block
, &se
.pre
);
4629 /* Set the NEXT field of this_forall to NULL. */
4630 this_forall
->next
= NULL
;
4631 /* Link this_forall to the info construct. */
4632 if (info
->this_loop
)
4634 iter_info
*iter_tmp
= info
->this_loop
;
4635 while (iter_tmp
->next
!= NULL
)
4636 iter_tmp
= iter_tmp
->next
;
4637 iter_tmp
->next
= this_forall
;
4640 info
->this_loop
= this_forall
;
4646 /* Calculate the size needed for the current forall level. */
4647 size
= gfc_index_one_node
;
4648 for (n
= 0; n
< nvar
; n
++)
4650 /* size = (end + step - start) / step. */
4651 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (start
[n
]),
4653 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (end
[n
]),
4655 tmp
= fold_build2_loc (input_location
, FLOOR_DIV_EXPR
, TREE_TYPE (tmp
),
4657 tmp
= convert (gfc_array_index_type
, tmp
);
4659 size
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
4663 /* Record the nvar and size of current forall level. */
4669 /* If the mask is .true., consider the FORALL unconditional. */
4670 if (code
->expr1
->expr_type
== EXPR_CONSTANT
4671 && code
->expr1
->value
.logical
)
4679 /* First we need to allocate the mask. */
4682 /* As the mask array can be very big, prefer compact boolean types. */
4683 tree mask_type
= gfc_get_logical_type (gfc_logical_kinds
[0].kind
);
4684 mask
= allocate_temp_for_forall_nest (nested_forall_info
, mask_type
,
4685 size
, NULL
, &block
, &pmask
);
4686 maskindex
= gfc_create_var_np (gfc_array_index_type
, "mi");
4688 /* Record them in the info structure. */
4689 info
->maskindex
= maskindex
;
4694 /* No mask was specified. */
4695 maskindex
= NULL_TREE
;
4696 mask
= pmask
= NULL_TREE
;
4699 /* Link the current forall level to nested_forall_info. */
4700 info
->prev_nest
= nested_forall_info
;
4701 nested_forall_info
= info
;
4703 /* Copy the mask into a temporary variable if required.
4704 For now we assume a mask temporary is needed. */
4707 /* As the mask array can be very big, prefer compact boolean types. */
4708 tree mask_type
= gfc_get_logical_type (gfc_logical_kinds
[0].kind
);
4710 gfc_add_modify (&block
, maskindex
, gfc_index_zero_node
);
4712 /* Start of mask assignment loop body. */
4713 gfc_start_block (&body
);
4715 /* Evaluate the mask expression. */
4716 gfc_init_se (&se
, NULL
);
4717 gfc_conv_expr_val (&se
, code
->expr1
);
4718 gfc_add_block_to_block (&body
, &se
.pre
);
4720 /* Store the mask. */
4721 se
.expr
= convert (mask_type
, se
.expr
);
4723 tmp
= gfc_build_array_ref (mask
, maskindex
, NULL
);
4724 gfc_add_modify (&body
, tmp
, se
.expr
);
4726 /* Advance to the next mask element. */
4727 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
4728 maskindex
, gfc_index_one_node
);
4729 gfc_add_modify (&body
, maskindex
, tmp
);
4731 /* Generate the loops. */
4732 tmp
= gfc_finish_block (&body
);
4733 tmp
= gfc_trans_nested_forall_loop (info
, tmp
, 0);
4734 gfc_add_expr_to_block (&block
, tmp
);
4737 if (code
->op
== EXEC_DO_CONCURRENT
)
4739 gfc_init_block (&body
);
4740 cycle_label
= gfc_build_label_decl (NULL_TREE
);
4741 code
->cycle_label
= cycle_label
;
4742 tmp
= gfc_trans_code (code
->block
->next
);
4743 gfc_add_expr_to_block (&body
, tmp
);
4745 if (TREE_USED (cycle_label
))
4747 tmp
= build1_v (LABEL_EXPR
, cycle_label
);
4748 gfc_add_expr_to_block (&body
, tmp
);
4751 tmp
= gfc_finish_block (&body
);
4752 nested_forall_info
->do_concurrent
= true;
4753 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, tmp
, 1);
4754 gfc_add_expr_to_block (&block
, tmp
);
4758 c
= code
->block
->next
;
4760 /* TODO: loop merging in FORALL statements. */
4761 /* Now that we've got a copy of the mask, generate the assignment loops. */
4767 /* A scalar or array assignment. DO the simple check for
4768 lhs to rhs dependencies. These make a temporary for the
4769 rhs and form a second forall block to copy to variable. */
4770 need_temp
= check_forall_dependencies(c
, &pre
, &post
);
4772 /* Temporaries due to array assignment data dependencies introduce
4773 no end of problems. */
4774 if (need_temp
|| flag_test_forall_temp
)
4775 gfc_trans_assign_need_temp (c
->expr1
, c
->expr2
, NULL
, false,
4776 nested_forall_info
, &block
);
4779 /* Use the normal assignment copying routines. */
4780 assign
= gfc_trans_assignment (c
->expr1
, c
->expr2
, false, true);
4782 /* Generate body and loops. */
4783 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
,
4785 gfc_add_expr_to_block (&block
, tmp
);
4788 /* Cleanup any temporary symtrees that have been made to deal
4789 with dependencies. */
4791 cleanup_forall_symtrees (c
);
4796 /* Translate WHERE or WHERE construct nested in FORALL. */
4797 gfc_trans_where_2 (c
, NULL
, false, nested_forall_info
, &block
);
4800 /* Pointer assignment inside FORALL. */
4801 case EXEC_POINTER_ASSIGN
:
4802 need_temp
= gfc_check_dependency (c
->expr1
, c
->expr2
, 0);
4803 /* Avoid cases where a temporary would never be needed and where
4804 the temp code is guaranteed to fail. */
4806 || (flag_test_forall_temp
4807 && c
->expr2
->expr_type
!= EXPR_CONSTANT
4808 && c
->expr2
->expr_type
!= EXPR_NULL
))
4809 gfc_trans_pointer_assign_need_temp (c
->expr1
, c
->expr2
,
4810 nested_forall_info
, &block
);
4813 /* Use the normal assignment copying routines. */
4814 assign
= gfc_trans_pointer_assignment (c
->expr1
, c
->expr2
);
4816 /* Generate body and loops. */
4817 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
,
4819 gfc_add_expr_to_block (&block
, tmp
);
4824 tmp
= gfc_trans_forall_1 (c
, nested_forall_info
);
4825 gfc_add_expr_to_block (&block
, tmp
);
4828 /* Explicit subroutine calls are prevented by the frontend but interface
4829 assignments can legitimately produce them. */
4830 case EXEC_ASSIGN_CALL
:
4831 assign
= gfc_trans_call (c
, true, NULL_TREE
, NULL_TREE
, false);
4832 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, assign
, 1);
4833 gfc_add_expr_to_block (&block
, tmp
);
4844 /* Restore the original index variables. */
4845 for (fa
= code
->ext
.forall_iterator
, n
= 0; fa
; fa
= fa
->next
, n
++)
4846 gfc_restore_sym (fa
->var
->symtree
->n
.sym
, &saved_vars
[n
]);
4848 /* Free the space for var, start, end, step, varexpr. */
4856 for (this_forall
= info
->this_loop
; this_forall
;)
4858 iter_info
*next
= this_forall
->next
;
4863 /* Free the space for this forall_info. */
4868 /* Free the temporary for the mask. */
4869 tmp
= gfc_call_free (pmask
);
4870 gfc_add_expr_to_block (&block
, tmp
);
4873 pushdecl (maskindex
);
4875 gfc_add_block_to_block (&pre
, &block
);
4876 gfc_add_block_to_block (&pre
, &post
);
4878 return gfc_finish_block (&pre
);
4882 /* Translate the FORALL statement or construct. */
4884 tree
gfc_trans_forall (gfc_code
* code
)
4886 return gfc_trans_forall_1 (code
, NULL
);
4890 /* Translate the DO CONCURRENT construct. */
4892 tree
gfc_trans_do_concurrent (gfc_code
* code
)
4894 return gfc_trans_forall_1 (code
, NULL
);
4898 /* Evaluate the WHERE mask expression, copy its value to a temporary.
4899 If the WHERE construct is nested in FORALL, compute the overall temporary
4900 needed by the WHERE mask expression multiplied by the iterator number of
4902 ME is the WHERE mask expression.
4903 MASK is the current execution mask upon input, whose sense may or may
4904 not be inverted as specified by the INVERT argument.
4905 CMASK is the updated execution mask on output, or NULL if not required.
4906 PMASK is the pending execution mask on output, or NULL if not required.
4907 BLOCK is the block in which to place the condition evaluation loops. */
4910 gfc_evaluate_where_mask (gfc_expr
* me
, forall_info
* nested_forall_info
,
4911 tree mask
, bool invert
, tree cmask
, tree pmask
,
4912 tree mask_type
, stmtblock_t
* block
)
4917 stmtblock_t body
, body1
;
4918 tree count
, cond
, mtmp
;
4921 gfc_init_loopinfo (&loop
);
4923 lss
= gfc_walk_expr (me
);
4924 rss
= gfc_walk_expr (me
);
4926 /* Variable to index the temporary. */
4927 count
= gfc_create_var (gfc_array_index_type
, "count");
4928 /* Initialize count. */
4929 gfc_add_modify (block
, count
, gfc_index_zero_node
);
4931 gfc_start_block (&body
);
4933 gfc_init_se (&rse
, NULL
);
4934 gfc_init_se (&lse
, NULL
);
4936 if (lss
== gfc_ss_terminator
)
4938 gfc_init_block (&body1
);
4942 /* Initialize the loop. */
4943 gfc_init_loopinfo (&loop
);
4945 /* We may need LSS to determine the shape of the expression. */
4946 gfc_add_ss_to_loop (&loop
, lss
);
4947 gfc_add_ss_to_loop (&loop
, rss
);
4949 gfc_conv_ss_startstride (&loop
);
4950 gfc_conv_loop_setup (&loop
, &me
->where
);
4952 gfc_mark_ss_chain_used (rss
, 1);
4953 /* Start the loop body. */
4954 gfc_start_scalarized_body (&loop
, &body1
);
4956 /* Translate the expression. */
4957 gfc_copy_loopinfo_to_se (&rse
, &loop
);
4959 gfc_conv_expr (&rse
, me
);
4962 /* Variable to evaluate mask condition. */
4963 cond
= gfc_create_var (mask_type
, "cond");
4964 if (mask
&& (cmask
|| pmask
))
4965 mtmp
= gfc_create_var (mask_type
, "mask");
4966 else mtmp
= NULL_TREE
;
4968 gfc_add_block_to_block (&body1
, &lse
.pre
);
4969 gfc_add_block_to_block (&body1
, &rse
.pre
);
4971 gfc_add_modify (&body1
, cond
, fold_convert (mask_type
, rse
.expr
));
4973 if (mask
&& (cmask
|| pmask
))
4975 tmp
= gfc_build_array_ref (mask
, count
, NULL
);
4977 tmp
= fold_build1_loc (input_location
, TRUTH_NOT_EXPR
, mask_type
, tmp
);
4978 gfc_add_modify (&body1
, mtmp
, tmp
);
4983 tmp1
= gfc_build_array_ref (cmask
, count
, NULL
);
4986 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
, mask_type
,
4988 gfc_add_modify (&body1
, tmp1
, tmp
);
4993 tmp1
= gfc_build_array_ref (pmask
, count
, NULL
);
4994 tmp
= fold_build1_loc (input_location
, TRUTH_NOT_EXPR
, mask_type
, cond
);
4996 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
, mask_type
, mtmp
,
4998 gfc_add_modify (&body1
, tmp1
, tmp
);
5001 gfc_add_block_to_block (&body1
, &lse
.post
);
5002 gfc_add_block_to_block (&body1
, &rse
.post
);
5004 if (lss
== gfc_ss_terminator
)
5006 gfc_add_block_to_block (&body
, &body1
);
5010 /* Increment count. */
5011 tmp1
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
5012 count
, gfc_index_one_node
);
5013 gfc_add_modify (&body1
, count
, tmp1
);
5015 /* Generate the copying loops. */
5016 gfc_trans_scalarizing_loops (&loop
, &body1
);
5018 gfc_add_block_to_block (&body
, &loop
.pre
);
5019 gfc_add_block_to_block (&body
, &loop
.post
);
5021 gfc_cleanup_loop (&loop
);
5022 /* TODO: Reuse lss and rss when copying temp->lhs. Need to be careful
5023 as tree nodes in SS may not be valid in different scope. */
5026 tmp1
= gfc_finish_block (&body
);
5027 /* If the WHERE construct is inside FORALL, fill the full temporary. */
5028 if (nested_forall_info
!= NULL
)
5029 tmp1
= gfc_trans_nested_forall_loop (nested_forall_info
, tmp1
, 1);
5031 gfc_add_expr_to_block (block
, tmp1
);
5035 /* Translate an assignment statement in a WHERE statement or construct
5036 statement. The MASK expression is used to control which elements
5037 of EXPR1 shall be assigned. The sense of MASK is specified by
5041 gfc_trans_where_assign (gfc_expr
*expr1
, gfc_expr
*expr2
,
5042 tree mask
, bool invert
,
5043 tree count1
, tree count2
,
5049 gfc_ss
*lss_section
;
5056 tree index
, maskexpr
;
5058 /* A defined assignment. */
5059 if (cnext
&& cnext
->resolved_sym
)
5060 return gfc_trans_call (cnext
, true, mask
, count1
, invert
);
5063 /* TODO: handle this special case.
5064 Special case a single function returning an array. */
5065 if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->rank
> 0)
5067 tmp
= gfc_trans_arrayfunc_assign (expr1
, expr2
);
5073 /* Assignment of the form lhs = rhs. */
5074 gfc_start_block (&block
);
5076 gfc_init_se (&lse
, NULL
);
5077 gfc_init_se (&rse
, NULL
);
5080 lss
= gfc_walk_expr (expr1
);
5083 /* In each where-assign-stmt, the mask-expr and the variable being
5084 defined shall be arrays of the same shape. */
5085 gcc_assert (lss
!= gfc_ss_terminator
);
5087 /* The assignment needs scalarization. */
5090 /* Find a non-scalar SS from the lhs. */
5091 while (lss_section
!= gfc_ss_terminator
5092 && lss_section
->info
->type
!= GFC_SS_SECTION
)
5093 lss_section
= lss_section
->next
;
5095 gcc_assert (lss_section
!= gfc_ss_terminator
);
5097 /* Initialize the scalarizer. */
5098 gfc_init_loopinfo (&loop
);
5101 rss
= gfc_walk_expr (expr2
);
5102 if (rss
== gfc_ss_terminator
)
5104 /* The rhs is scalar. Add a ss for the expression. */
5105 rss
= gfc_get_scalar_ss (gfc_ss_terminator
, expr2
);
5106 rss
->info
->where
= 1;
5109 /* Associate the SS with the loop. */
5110 gfc_add_ss_to_loop (&loop
, lss
);
5111 gfc_add_ss_to_loop (&loop
, rss
);
5113 /* Calculate the bounds of the scalarization. */
5114 gfc_conv_ss_startstride (&loop
);
5116 /* Resolve any data dependencies in the statement. */
5117 gfc_conv_resolve_dependencies (&loop
, lss_section
, rss
);
5119 /* Setup the scalarizing loops. */
5120 gfc_conv_loop_setup (&loop
, &expr2
->where
);
5122 /* Setup the gfc_se structures. */
5123 gfc_copy_loopinfo_to_se (&lse
, &loop
);
5124 gfc_copy_loopinfo_to_se (&rse
, &loop
);
5127 gfc_mark_ss_chain_used (rss
, 1);
5128 if (loop
.temp_ss
== NULL
)
5131 gfc_mark_ss_chain_used (lss
, 1);
5135 lse
.ss
= loop
.temp_ss
;
5136 gfc_mark_ss_chain_used (lss
, 3);
5137 gfc_mark_ss_chain_used (loop
.temp_ss
, 3);
5140 /* Start the scalarized loop body. */
5141 gfc_start_scalarized_body (&loop
, &body
);
5143 /* Translate the expression. */
5144 gfc_conv_expr (&rse
, expr2
);
5145 if (lss
!= gfc_ss_terminator
&& loop
.temp_ss
!= NULL
)
5146 gfc_conv_tmp_array_ref (&lse
);
5148 gfc_conv_expr (&lse
, expr1
);
5150 /* Form the mask expression according to the mask. */
5152 maskexpr
= gfc_build_array_ref (mask
, index
, NULL
);
5154 maskexpr
= fold_build1_loc (input_location
, TRUTH_NOT_EXPR
,
5155 TREE_TYPE (maskexpr
), maskexpr
);
5157 /* Use the scalar assignment as is. */
5158 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
,
5159 false, loop
.temp_ss
== NULL
);
5161 tmp
= build3_v (COND_EXPR
, maskexpr
, tmp
, build_empty_stmt (input_location
));
5163 gfc_add_expr_to_block (&body
, tmp
);
5165 if (lss
== gfc_ss_terminator
)
5167 /* Increment count1. */
5168 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
5169 count1
, gfc_index_one_node
);
5170 gfc_add_modify (&body
, count1
, tmp
);
5172 /* Use the scalar assignment as is. */
5173 gfc_add_block_to_block (&block
, &body
);
5177 gcc_assert (lse
.ss
== gfc_ss_terminator
5178 && rse
.ss
== gfc_ss_terminator
);
5180 if (loop
.temp_ss
!= NULL
)
5182 /* Increment count1 before finish the main body of a scalarized
5184 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
5185 gfc_array_index_type
, count1
, gfc_index_one_node
);
5186 gfc_add_modify (&body
, count1
, tmp
);
5187 gfc_trans_scalarized_loop_boundary (&loop
, &body
);
5189 /* We need to copy the temporary to the actual lhs. */
5190 gfc_init_se (&lse
, NULL
);
5191 gfc_init_se (&rse
, NULL
);
5192 gfc_copy_loopinfo_to_se (&lse
, &loop
);
5193 gfc_copy_loopinfo_to_se (&rse
, &loop
);
5195 rse
.ss
= loop
.temp_ss
;
5198 gfc_conv_tmp_array_ref (&rse
);
5199 gfc_conv_expr (&lse
, expr1
);
5201 gcc_assert (lse
.ss
== gfc_ss_terminator
5202 && rse
.ss
== gfc_ss_terminator
);
5204 /* Form the mask expression according to the mask tree list. */
5206 maskexpr
= gfc_build_array_ref (mask
, index
, NULL
);
5208 maskexpr
= fold_build1_loc (input_location
, TRUTH_NOT_EXPR
,
5209 TREE_TYPE (maskexpr
), maskexpr
);
5211 /* Use the scalar assignment as is. */
5212 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
, false, true);
5213 tmp
= build3_v (COND_EXPR
, maskexpr
, tmp
,
5214 build_empty_stmt (input_location
));
5215 gfc_add_expr_to_block (&body
, tmp
);
5217 /* Increment count2. */
5218 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
5219 gfc_array_index_type
, count2
,
5220 gfc_index_one_node
);
5221 gfc_add_modify (&body
, count2
, tmp
);
5225 /* Increment count1. */
5226 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
5227 gfc_array_index_type
, count1
,
5228 gfc_index_one_node
);
5229 gfc_add_modify (&body
, count1
, tmp
);
5232 /* Generate the copying loops. */
5233 gfc_trans_scalarizing_loops (&loop
, &body
);
5235 /* Wrap the whole thing up. */
5236 gfc_add_block_to_block (&block
, &loop
.pre
);
5237 gfc_add_block_to_block (&block
, &loop
.post
);
5238 gfc_cleanup_loop (&loop
);
5241 return gfc_finish_block (&block
);
5245 /* Translate the WHERE construct or statement.
5246 This function can be called iteratively to translate the nested WHERE
5247 construct or statement.
5248 MASK is the control mask. */
5251 gfc_trans_where_2 (gfc_code
* code
, tree mask
, bool invert
,
5252 forall_info
* nested_forall_info
, stmtblock_t
* block
)
5254 stmtblock_t inner_size_body
;
5255 tree inner_size
, size
;
5264 tree count1
, count2
;
5268 tree pcmask
= NULL_TREE
;
5269 tree ppmask
= NULL_TREE
;
5270 tree cmask
= NULL_TREE
;
5271 tree pmask
= NULL_TREE
;
5272 gfc_actual_arglist
*arg
;
5274 /* the WHERE statement or the WHERE construct statement. */
5275 cblock
= code
->block
;
5277 /* As the mask array can be very big, prefer compact boolean types. */
5278 mask_type
= gfc_get_logical_type (gfc_logical_kinds
[0].kind
);
5280 /* Determine which temporary masks are needed. */
5283 /* One clause: No ELSEWHEREs. */
5284 need_cmask
= (cblock
->next
!= 0);
5287 else if (cblock
->block
->block
)
5289 /* Three or more clauses: Conditional ELSEWHEREs. */
5293 else if (cblock
->next
)
5295 /* Two clauses, the first non-empty. */
5297 need_pmask
= (mask
!= NULL_TREE
5298 && cblock
->block
->next
!= 0);
5300 else if (!cblock
->block
->next
)
5302 /* Two clauses, both empty. */
5306 /* Two clauses, the first empty, the second non-empty. */
5309 need_cmask
= (cblock
->block
->expr1
!= 0);
5318 if (need_cmask
|| need_pmask
)
5320 /* Calculate the size of temporary needed by the mask-expr. */
5321 gfc_init_block (&inner_size_body
);
5322 inner_size
= compute_inner_temp_size (cblock
->expr1
, cblock
->expr1
,
5323 &inner_size_body
, &lss
, &rss
);
5325 gfc_free_ss_chain (lss
);
5326 gfc_free_ss_chain (rss
);
5328 /* Calculate the total size of temporary needed. */
5329 size
= compute_overall_iter_number (nested_forall_info
, inner_size
,
5330 &inner_size_body
, block
);
5332 /* Check whether the size is negative. */
5333 cond
= fold_build2_loc (input_location
, LE_EXPR
, logical_type_node
, size
,
5334 gfc_index_zero_node
);
5335 size
= fold_build3_loc (input_location
, COND_EXPR
, gfc_array_index_type
,
5336 cond
, gfc_index_zero_node
, size
);
5337 size
= gfc_evaluate_now (size
, block
);
5339 /* Allocate temporary for WHERE mask if needed. */
5341 cmask
= allocate_temp_for_forall_nest_1 (mask_type
, size
, block
,
5344 /* Allocate temporary for !mask if needed. */
5346 pmask
= allocate_temp_for_forall_nest_1 (mask_type
, size
, block
,
5352 /* Each time around this loop, the where clause is conditional
5353 on the value of mask and invert, which are updated at the
5354 bottom of the loop. */
5356 /* Has mask-expr. */
5359 /* Ensure that the WHERE mask will be evaluated exactly once.
5360 If there are no statements in this WHERE/ELSEWHERE clause,
5361 then we don't need to update the control mask (cmask).
5362 If this is the last clause of the WHERE construct, then
5363 we don't need to update the pending control mask (pmask). */
5365 gfc_evaluate_where_mask (cblock
->expr1
, nested_forall_info
,
5367 cblock
->next
? cmask
: NULL_TREE
,
5368 cblock
->block
? pmask
: NULL_TREE
,
5371 gfc_evaluate_where_mask (cblock
->expr1
, nested_forall_info
,
5373 (cblock
->next
|| cblock
->block
)
5374 ? cmask
: NULL_TREE
,
5375 NULL_TREE
, mask_type
, block
);
5379 /* It's a final elsewhere-stmt. No mask-expr is present. */
5383 /* The body of this where clause are controlled by cmask with
5384 sense specified by invert. */
5386 /* Get the assignment statement of a WHERE statement, or the first
5387 statement in where-body-construct of a WHERE construct. */
5388 cnext
= cblock
->next
;
5393 /* WHERE assignment statement. */
5394 case EXEC_ASSIGN_CALL
:
5396 arg
= cnext
->ext
.actual
;
5397 expr1
= expr2
= NULL
;
5398 for (; arg
; arg
= arg
->next
)
5410 expr1
= cnext
->expr1
;
5411 expr2
= cnext
->expr2
;
5413 if (nested_forall_info
!= NULL
)
5415 need_temp
= gfc_check_dependency (expr1
, expr2
, 0);
5416 if ((need_temp
|| flag_test_forall_temp
)
5417 && cnext
->op
!= EXEC_ASSIGN_CALL
)
5418 gfc_trans_assign_need_temp (expr1
, expr2
,
5420 nested_forall_info
, block
);
5423 /* Variables to control maskexpr. */
5424 count1
= gfc_create_var (gfc_array_index_type
, "count1");
5425 count2
= gfc_create_var (gfc_array_index_type
, "count2");
5426 gfc_add_modify (block
, count1
, gfc_index_zero_node
);
5427 gfc_add_modify (block
, count2
, gfc_index_zero_node
);
5429 tmp
= gfc_trans_where_assign (expr1
, expr2
,
5434 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
,
5436 gfc_add_expr_to_block (block
, tmp
);
5441 /* Variables to control maskexpr. */
5442 count1
= gfc_create_var (gfc_array_index_type
, "count1");
5443 count2
= gfc_create_var (gfc_array_index_type
, "count2");
5444 gfc_add_modify (block
, count1
, gfc_index_zero_node
);
5445 gfc_add_modify (block
, count2
, gfc_index_zero_node
);
5447 tmp
= gfc_trans_where_assign (expr1
, expr2
,
5451 gfc_add_expr_to_block (block
, tmp
);
5456 /* WHERE or WHERE construct is part of a where-body-construct. */
5458 gfc_trans_where_2 (cnext
, cmask
, invert
,
5459 nested_forall_info
, block
);
5466 /* The next statement within the same where-body-construct. */
5467 cnext
= cnext
->next
;
5469 /* The next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt. */
5470 cblock
= cblock
->block
;
5471 if (mask
== NULL_TREE
)
5473 /* If we're the initial WHERE, we can simply invert the sense
5474 of the current mask to obtain the "mask" for the remaining
5481 /* Otherwise, for nested WHERE's we need to use the pending mask. */
5487 /* If we allocated a pending mask array, deallocate it now. */
5490 tmp
= gfc_call_free (ppmask
);
5491 gfc_add_expr_to_block (block
, tmp
);
5494 /* If we allocated a current mask array, deallocate it now. */
5497 tmp
= gfc_call_free (pcmask
);
5498 gfc_add_expr_to_block (block
, tmp
);
5502 /* Translate a simple WHERE construct or statement without dependencies.
5503 CBLOCK is the "then" clause of the WHERE statement, where CBLOCK->EXPR
5504 is the mask condition, and EBLOCK if non-NULL is the "else" clause.
5505 Currently both CBLOCK and EBLOCK are restricted to single assignments. */
5508 gfc_trans_where_3 (gfc_code
* cblock
, gfc_code
* eblock
)
5510 stmtblock_t block
, body
;
5511 gfc_expr
*cond
, *tdst
, *tsrc
, *edst
, *esrc
;
5512 tree tmp
, cexpr
, tstmt
, estmt
;
5513 gfc_ss
*css
, *tdss
, *tsss
;
5514 gfc_se cse
, tdse
, tsse
, edse
, esse
;
5518 bool maybe_workshare
= false;
5520 /* Allow the scalarizer to workshare simple where loops. */
5521 if ((ompws_flags
& (OMPWS_WORKSHARE_FLAG
| OMPWS_SCALARIZER_BODY
))
5522 == OMPWS_WORKSHARE_FLAG
)
5524 maybe_workshare
= true;
5525 ompws_flags
|= OMPWS_SCALARIZER_WS
| OMPWS_SCALARIZER_BODY
;
5528 cond
= cblock
->expr1
;
5529 tdst
= cblock
->next
->expr1
;
5530 tsrc
= cblock
->next
->expr2
;
5531 edst
= eblock
? eblock
->next
->expr1
: NULL
;
5532 esrc
= eblock
? eblock
->next
->expr2
: NULL
;
5534 gfc_start_block (&block
);
5535 gfc_init_loopinfo (&loop
);
5537 /* Handle the condition. */
5538 gfc_init_se (&cse
, NULL
);
5539 css
= gfc_walk_expr (cond
);
5540 gfc_add_ss_to_loop (&loop
, css
);
5542 /* Handle the then-clause. */
5543 gfc_init_se (&tdse
, NULL
);
5544 gfc_init_se (&tsse
, NULL
);
5545 tdss
= gfc_walk_expr (tdst
);
5546 tsss
= gfc_walk_expr (tsrc
);
5547 if (tsss
== gfc_ss_terminator
)
5549 tsss
= gfc_get_scalar_ss (gfc_ss_terminator
, tsrc
);
5550 tsss
->info
->where
= 1;
5552 gfc_add_ss_to_loop (&loop
, tdss
);
5553 gfc_add_ss_to_loop (&loop
, tsss
);
5557 /* Handle the else clause. */
5558 gfc_init_se (&edse
, NULL
);
5559 gfc_init_se (&esse
, NULL
);
5560 edss
= gfc_walk_expr (edst
);
5561 esss
= gfc_walk_expr (esrc
);
5562 if (esss
== gfc_ss_terminator
)
5564 esss
= gfc_get_scalar_ss (gfc_ss_terminator
, esrc
);
5565 esss
->info
->where
= 1;
5567 gfc_add_ss_to_loop (&loop
, edss
);
5568 gfc_add_ss_to_loop (&loop
, esss
);
5571 gfc_conv_ss_startstride (&loop
);
5572 gfc_conv_loop_setup (&loop
, &tdst
->where
);
5574 gfc_mark_ss_chain_used (css
, 1);
5575 gfc_mark_ss_chain_used (tdss
, 1);
5576 gfc_mark_ss_chain_used (tsss
, 1);
5579 gfc_mark_ss_chain_used (edss
, 1);
5580 gfc_mark_ss_chain_used (esss
, 1);
5583 gfc_start_scalarized_body (&loop
, &body
);
5585 gfc_copy_loopinfo_to_se (&cse
, &loop
);
5586 gfc_copy_loopinfo_to_se (&tdse
, &loop
);
5587 gfc_copy_loopinfo_to_se (&tsse
, &loop
);
5593 gfc_copy_loopinfo_to_se (&edse
, &loop
);
5594 gfc_copy_loopinfo_to_se (&esse
, &loop
);
5599 gfc_conv_expr (&cse
, cond
);
5600 gfc_add_block_to_block (&body
, &cse
.pre
);
5603 gfc_conv_expr (&tsse
, tsrc
);
5604 if (tdss
!= gfc_ss_terminator
&& loop
.temp_ss
!= NULL
)
5605 gfc_conv_tmp_array_ref (&tdse
);
5607 gfc_conv_expr (&tdse
, tdst
);
5611 gfc_conv_expr (&esse
, esrc
);
5612 if (edss
!= gfc_ss_terminator
&& loop
.temp_ss
!= NULL
)
5613 gfc_conv_tmp_array_ref (&edse
);
5615 gfc_conv_expr (&edse
, edst
);
5618 tstmt
= gfc_trans_scalar_assign (&tdse
, &tsse
, tdst
->ts
, false, true);
5619 estmt
= eblock
? gfc_trans_scalar_assign (&edse
, &esse
, edst
->ts
,
5621 : build_empty_stmt (input_location
);
5622 tmp
= build3_v (COND_EXPR
, cexpr
, tstmt
, estmt
);
5623 gfc_add_expr_to_block (&body
, tmp
);
5624 gfc_add_block_to_block (&body
, &cse
.post
);
5626 if (maybe_workshare
)
5627 ompws_flags
&= ~OMPWS_SCALARIZER_BODY
;
5628 gfc_trans_scalarizing_loops (&loop
, &body
);
5629 gfc_add_block_to_block (&block
, &loop
.pre
);
5630 gfc_add_block_to_block (&block
, &loop
.post
);
5631 gfc_cleanup_loop (&loop
);
5633 return gfc_finish_block (&block
);
5636 /* As the WHERE or WHERE construct statement can be nested, we call
5637 gfc_trans_where_2 to do the translation, and pass the initial
5638 NULL values for both the control mask and the pending control mask. */
5641 gfc_trans_where (gfc_code
* code
)
5647 cblock
= code
->block
;
5649 && cblock
->next
->op
== EXEC_ASSIGN
5650 && !cblock
->next
->next
)
5652 eblock
= cblock
->block
;
5655 /* A simple "WHERE (cond) x = y" statement or block is
5656 dependence free if cond is not dependent upon writing x,
5657 and the source y is unaffected by the destination x. */
5658 if (!gfc_check_dependency (cblock
->next
->expr1
,
5660 && !gfc_check_dependency (cblock
->next
->expr1
,
5661 cblock
->next
->expr2
, 0))
5662 return gfc_trans_where_3 (cblock
, NULL
);
5664 else if (!eblock
->expr1
5667 && eblock
->next
->op
== EXEC_ASSIGN
5668 && !eblock
->next
->next
)
5670 /* A simple "WHERE (cond) x1 = y1 ELSEWHERE x2 = y2 ENDWHERE"
5671 block is dependence free if cond is not dependent on writes
5672 to x1 and x2, y1 is not dependent on writes to x2, and y2
5673 is not dependent on writes to x1, and both y's are not
5674 dependent upon their own x's. In addition to this, the
5675 final two dependency checks below exclude all but the same
5676 array reference if the where and elswhere destinations
5677 are the same. In short, this is VERY conservative and this
5678 is needed because the two loops, required by the standard
5679 are coalesced in gfc_trans_where_3. */
5680 if (!gfc_check_dependency (cblock
->next
->expr1
,
5682 && !gfc_check_dependency (eblock
->next
->expr1
,
5684 && !gfc_check_dependency (cblock
->next
->expr1
,
5685 eblock
->next
->expr2
, 1)
5686 && !gfc_check_dependency (eblock
->next
->expr1
,
5687 cblock
->next
->expr2
, 1)
5688 && !gfc_check_dependency (cblock
->next
->expr1
,
5689 cblock
->next
->expr2
, 1)
5690 && !gfc_check_dependency (eblock
->next
->expr1
,
5691 eblock
->next
->expr2
, 1)
5692 && !gfc_check_dependency (cblock
->next
->expr1
,
5693 eblock
->next
->expr1
, 0)
5694 && !gfc_check_dependency (eblock
->next
->expr1
,
5695 cblock
->next
->expr1
, 0))
5696 return gfc_trans_where_3 (cblock
, eblock
);
5700 gfc_start_block (&block
);
5702 gfc_trans_where_2 (code
, NULL
, false, NULL
, &block
);
5704 return gfc_finish_block (&block
);
5708 /* CYCLE a DO loop. The label decl has already been created by
5709 gfc_trans_do(), it's in TREE_PURPOSE (backend_decl) of the gfc_code
5710 node at the head of the loop. We must mark the label as used. */
5713 gfc_trans_cycle (gfc_code
* code
)
5717 cycle_label
= code
->ext
.which_construct
->cycle_label
;
5718 gcc_assert (cycle_label
);
5720 TREE_USED (cycle_label
) = 1;
5721 return build1_v (GOTO_EXPR
, cycle_label
);
5725 /* EXIT a DO loop. Similar to CYCLE, but now the label is in
5726 TREE_VALUE (backend_decl) of the gfc_code node at the head of the
5730 gfc_trans_exit (gfc_code
* code
)
5734 exit_label
= code
->ext
.which_construct
->exit_label
;
5735 gcc_assert (exit_label
);
5737 TREE_USED (exit_label
) = 1;
5738 return build1_v (GOTO_EXPR
, exit_label
);
5742 /* Get the initializer expression for the code and expr of an allocate.
5743 When no initializer is needed return NULL. */
5746 allocate_get_initializer (gfc_code
* code
, gfc_expr
* expr
)
5748 if (!gfc_bt_struct (expr
->ts
.type
) && expr
->ts
.type
!= BT_CLASS
)
5751 /* An explicit type was given in allocate ( T:: object). */
5752 if (code
->ext
.alloc
.ts
.type
== BT_DERIVED
5753 && (code
->ext
.alloc
.ts
.u
.derived
->attr
.alloc_comp
5754 || gfc_has_default_initializer (code
->ext
.alloc
.ts
.u
.derived
)))
5755 return gfc_default_initializer (&code
->ext
.alloc
.ts
);
5757 if (gfc_bt_struct (expr
->ts
.type
)
5758 && (expr
->ts
.u
.derived
->attr
.alloc_comp
5759 || gfc_has_default_initializer (expr
->ts
.u
.derived
)))
5760 return gfc_default_initializer (&expr
->ts
);
5762 if (expr
->ts
.type
== BT_CLASS
5763 && (CLASS_DATA (expr
)->ts
.u
.derived
->attr
.alloc_comp
5764 || gfc_has_default_initializer (CLASS_DATA (expr
)->ts
.u
.derived
)))
5765 return gfc_default_initializer (&CLASS_DATA (expr
)->ts
);
5770 /* Translate the ALLOCATE statement. */
5773 gfc_trans_allocate (gfc_code
* code
)
5776 gfc_expr
*expr
, *e3rhs
= NULL
, *init_expr
;
5786 tree al_vptr
, al_len
;
5787 /* If an expr3 is present, then store the tree for accessing its
5788 _vptr, and _len components in the variables, respectively. The
5789 element size, i.e. _vptr%size, is stored in expr3_esize. Any of
5790 the trees may be the NULL_TREE indicating that this is not
5791 available for expr3's type. */
5792 tree expr3
, expr3_vptr
, expr3_len
, expr3_esize
;
5793 /* Classify what expr3 stores. */
5794 enum { E3_UNSET
= 0, E3_SOURCE
, E3_MOLD
, E3_DESC
} e3_is
;
5797 stmtblock_t final_block
;
5799 bool upoly_expr
, tmp_expr3_len_flag
= false, al_len_needs_set
, is_coarray
;
5800 bool needs_caf_sync
, caf_refs_comp
;
5801 bool e3_has_nodescriptor
= false;
5802 gfc_symtree
*newsym
= NULL
;
5803 symbol_attribute caf_attr
;
5804 gfc_actual_arglist
*param_list
;
5806 if (!code
->ext
.alloc
.list
)
5809 stat
= tmp
= memsz
= al_vptr
= al_len
= NULL_TREE
;
5810 expr3
= expr3_vptr
= expr3_len
= expr3_esize
= NULL_TREE
;
5811 label_errmsg
= label_finish
= errmsg
= errlen
= NULL_TREE
;
5813 is_coarray
= needs_caf_sync
= false;
5815 gfc_init_block (&block
);
5816 gfc_init_block (&post
);
5817 gfc_init_block (&final_block
);
5819 /* STAT= (and maybe ERRMSG=) is present. */
5823 tree gfc_int4_type_node
= gfc_get_int_type (4);
5824 stat
= gfc_create_var (gfc_int4_type_node
, "stat");
5826 /* ERRMSG= only makes sense with STAT=. */
5829 gfc_init_se (&se
, NULL
);
5830 se
.want_pointer
= 1;
5831 gfc_conv_expr_lhs (&se
, code
->expr2
);
5833 errlen
= se
.string_length
;
5837 errmsg
= null_pointer_node
;
5838 errlen
= build_int_cst (gfc_charlen_type_node
, 0);
5841 /* GOTO destinations. */
5842 label_errmsg
= gfc_build_label_decl (NULL_TREE
);
5843 label_finish
= gfc_build_label_decl (NULL_TREE
);
5844 TREE_USED (label_finish
) = 0;
5847 /* When an expr3 is present evaluate it only once. The standards prevent a
5848 dependency of expr3 on the objects in the allocate list. An expr3 can
5849 be pre-evaluated in all cases. One just has to make sure, to use the
5850 correct way, i.e., to get the descriptor or to get a reference
5854 bool vtab_needed
= false, temp_var_needed
= false,
5855 temp_obj_created
= false;
5857 is_coarray
= gfc_is_coarray (code
->expr3
);
5859 if (code
->expr3
->expr_type
== EXPR_FUNCTION
&& !code
->expr3
->mold
5860 && (gfc_is_class_array_function (code
->expr3
)
5861 || gfc_is_alloc_class_scalar_function (code
->expr3
)))
5862 code
->expr3
->must_finalize
= 1;
5864 /* Figure whether we need the vtab from expr3. */
5865 for (al
= code
->ext
.alloc
.list
; !vtab_needed
&& al
!= NULL
;
5867 vtab_needed
= (al
->expr
->ts
.type
== BT_CLASS
);
5869 gfc_init_se (&se
, NULL
);
5870 /* When expr3 is a variable, i.e., a very simple expression,
5871 then convert it once here. */
5872 if (code
->expr3
->expr_type
== EXPR_VARIABLE
5873 || code
->expr3
->expr_type
== EXPR_ARRAY
5874 || code
->expr3
->expr_type
== EXPR_CONSTANT
)
5876 if (!code
->expr3
->mold
5877 || code
->expr3
->ts
.type
== BT_CHARACTER
5879 || code
->ext
.alloc
.arr_spec_from_expr3
)
5881 /* Convert expr3 to a tree. For all "simple" expression just
5882 get the descriptor or the reference, respectively, depending
5883 on the rank of the expr. */
5884 if (code
->ext
.alloc
.arr_spec_from_expr3
|| code
->expr3
->rank
!= 0)
5885 gfc_conv_expr_descriptor (&se
, code
->expr3
);
5888 gfc_conv_expr_reference (&se
, code
->expr3
);
5890 /* gfc_conv_expr_reference wraps POINTER_PLUS_EXPR in a
5891 NOP_EXPR, which prevents gfortran from getting the vptr
5892 from the source=-expression. Remove the NOP_EXPR and go
5893 with the POINTER_PLUS_EXPR in this case. */
5894 if (code
->expr3
->ts
.type
== BT_CLASS
5895 && TREE_CODE (se
.expr
) == NOP_EXPR
5896 && (TREE_CODE (TREE_OPERAND (se
.expr
, 0))
5897 == POINTER_PLUS_EXPR
5899 se
.expr
= TREE_OPERAND (se
.expr
, 0);
5901 /* Create a temp variable only for component refs to prevent
5902 having to go through the full deref-chain each time and to
5903 simplfy computation of array properties. */
5904 temp_var_needed
= TREE_CODE (se
.expr
) == COMPONENT_REF
;
5909 /* In all other cases evaluate the expr3. */
5910 symbol_attribute attr
;
5911 /* Get the descriptor for all arrays, that are not allocatable or
5912 pointer, because the latter are descriptors already.
5913 The exception are function calls returning a class object:
5914 The descriptor is stored in their results _data component, which
5915 is easier to access, when first a temporary variable for the
5916 result is created and the descriptor retrieved from there. */
5917 attr
= gfc_expr_attr (code
->expr3
);
5918 if (code
->expr3
->rank
!= 0
5919 && ((!attr
.allocatable
&& !attr
.pointer
)
5920 || (code
->expr3
->expr_type
== EXPR_FUNCTION
5921 && (code
->expr3
->ts
.type
!= BT_CLASS
5922 || (code
->expr3
->value
.function
.isym
5923 && code
->expr3
->value
.function
.isym
5924 ->transformational
)))))
5925 gfc_conv_expr_descriptor (&se
, code
->expr3
);
5927 gfc_conv_expr_reference (&se
, code
->expr3
);
5928 if (code
->expr3
->ts
.type
== BT_CLASS
)
5929 gfc_conv_class_to_class (&se
, code
->expr3
,
5933 temp_obj_created
= temp_var_needed
= !VAR_P (se
.expr
);
5935 gfc_add_block_to_block (&block
, &se
.pre
);
5936 if (code
->expr3
->must_finalize
)
5937 gfc_add_block_to_block (&final_block
, &se
.post
);
5939 gfc_add_block_to_block (&post
, &se
.post
);
5941 /* Special case when string in expr3 is zero. */
5942 if (code
->expr3
->ts
.type
== BT_CHARACTER
5943 && integer_zerop (se
.string_length
))
5945 gfc_init_se (&se
, NULL
);
5946 temp_var_needed
= false;
5947 expr3_len
= build_zero_cst (gfc_charlen_type_node
);
5950 /* Prevent aliasing, i.e., se.expr may be already a
5951 variable declaration. */
5952 else if (se
.expr
!= NULL_TREE
&& temp_var_needed
)
5955 tmp
= GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se
.expr
)) || is_coarray
?
5957 : build_fold_indirect_ref_loc (input_location
, se
.expr
);
5959 /* Get the array descriptor and prepare it to be assigned to the
5960 temporary variable var. For classes the array descriptor is
5961 in the _data component and the object goes into the
5962 GFC_DECL_SAVED_DESCRIPTOR. */
5963 if (code
->expr3
->ts
.type
== BT_CLASS
5964 && code
->expr3
->rank
!= 0)
5966 /* When an array_ref was in expr3, then the descriptor is the
5968 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp
)) || is_coarray
)
5970 desc
= TREE_OPERAND (tmp
, 0);
5975 tmp
= gfc_class_data_get (tmp
);
5977 if (code
->ext
.alloc
.arr_spec_from_expr3
)
5981 desc
= !is_coarray
? se
.expr
5982 : TREE_OPERAND (TREE_OPERAND (se
.expr
, 0), 0);
5983 /* We need a regular (non-UID) symbol here, therefore give a
5985 var
= gfc_create_var (TREE_TYPE (tmp
), "source");
5986 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp
)) || is_coarray
)
5988 gfc_allocate_lang_decl (var
);
5989 GFC_DECL_SAVED_DESCRIPTOR (var
) = desc
;
5991 gfc_add_modify_loc (input_location
, &block
, var
, tmp
);
5994 if (se
.string_length
)
5995 /* Evaluate it assuming that it also is complicated like expr3. */
5996 expr3_len
= gfc_evaluate_now (se
.string_length
, &block
);
6001 expr3_len
= se
.string_length
;
6004 /* Deallocate any allocatable components in expressions that use a
6005 temporary object, i.e. are not a simple alias of to an EXPR_VARIABLE.
6006 E.g. temporaries of a function call need freeing of their components
6008 if ((code
->expr3
->ts
.type
== BT_DERIVED
6009 || code
->expr3
->ts
.type
== BT_CLASS
)
6010 && (code
->expr3
->expr_type
!= EXPR_VARIABLE
|| temp_obj_created
)
6011 && code
->expr3
->ts
.u
.derived
->attr
.alloc_comp
6012 && !code
->expr3
->must_finalize
)
6014 tmp
= gfc_deallocate_alloc_comp (code
->expr3
->ts
.u
.derived
,
6015 expr3
, code
->expr3
->rank
);
6016 gfc_prepend_expr_to_block (&post
, tmp
);
6019 /* Store what the expr3 is to be used for. */
6020 if (e3_is
== E3_UNSET
)
6021 e3_is
= expr3
!= NULL_TREE
?
6022 (code
->ext
.alloc
.arr_spec_from_expr3
?
6024 : (code
->expr3
->mold
? E3_MOLD
: E3_SOURCE
))
6027 /* Figure how to get the _vtab entry. This also obtains the tree
6028 expression for accessing the _len component, because only
6029 unlimited polymorphic objects, which are a subcategory of class
6030 types, have a _len component. */
6031 if (code
->expr3
->ts
.type
== BT_CLASS
)
6034 tmp
= expr3
!= NULL_TREE
&& POINTER_TYPE_P (TREE_TYPE (expr3
)) ?
6035 build_fold_indirect_ref (expr3
): expr3
;
6036 /* Polymorphic SOURCE: VPTR must be determined at run time.
6037 expr3 may be a temporary array declaration, therefore check for
6038 GFC_CLASS_TYPE_P before trying to get the _vptr component. */
6039 if (tmp
!= NULL_TREE
6040 && (e3_is
== E3_DESC
6041 || (GFC_CLASS_TYPE_P (TREE_TYPE (tmp
))
6042 && (VAR_P (tmp
) || !code
->expr3
->ref
))
6043 || (VAR_P (tmp
) && DECL_LANG_SPECIFIC (tmp
))))
6044 tmp
= gfc_class_vptr_get (expr3
);
6047 rhs
= gfc_find_and_cut_at_last_class_ref (code
->expr3
);
6048 gfc_add_vptr_component (rhs
);
6049 gfc_init_se (&se
, NULL
);
6050 se
.want_pointer
= 1;
6051 gfc_conv_expr (&se
, rhs
);
6053 gfc_free_expr (rhs
);
6055 /* Set the element size. */
6056 expr3_esize
= gfc_vptr_size_get (tmp
);
6059 /* Initialize the ref to the _len component. */
6060 if (expr3_len
== NULL_TREE
&& UNLIMITED_POLY (code
->expr3
))
6062 /* Same like for retrieving the _vptr. */
6063 if (expr3
!= NULL_TREE
&& !code
->expr3
->ref
)
6064 expr3_len
= gfc_class_len_get (expr3
);
6067 rhs
= gfc_find_and_cut_at_last_class_ref (code
->expr3
);
6068 gfc_add_len_component (rhs
);
6069 gfc_init_se (&se
, NULL
);
6070 gfc_conv_expr (&se
, rhs
);
6071 expr3_len
= se
.expr
;
6072 gfc_free_expr (rhs
);
6078 /* When the object to allocate is polymorphic type, then it
6079 needs its vtab set correctly, so deduce the required _vtab
6080 and _len from the source expression. */
6083 /* VPTR is fixed at compile time. */
6086 vtab
= gfc_find_vtab (&code
->expr3
->ts
);
6088 expr3_vptr
= gfc_get_symbol_decl (vtab
);
6089 expr3_vptr
= gfc_build_addr_expr (NULL_TREE
,
6092 /* _len component needs to be set, when ts is a character
6094 if (expr3_len
== NULL_TREE
6095 && code
->expr3
->ts
.type
== BT_CHARACTER
)
6097 if (code
->expr3
->ts
.u
.cl
6098 && code
->expr3
->ts
.u
.cl
->length
)
6100 gfc_init_se (&se
, NULL
);
6101 gfc_conv_expr (&se
, code
->expr3
->ts
.u
.cl
->length
);
6102 gfc_add_block_to_block (&block
, &se
.pre
);
6103 expr3_len
= gfc_evaluate_now (se
.expr
, &block
);
6105 gcc_assert (expr3_len
);
6107 /* For character arrays only the kind's size is needed, because
6108 the array mem_size is _len * (elem_size = kind_size).
6109 For all other get the element size in the normal way. */
6110 if (code
->expr3
->ts
.type
== BT_CHARACTER
)
6111 expr3_esize
= TYPE_SIZE_UNIT (
6112 gfc_get_char_type (code
->expr3
->ts
.kind
));
6114 expr3_esize
= TYPE_SIZE_UNIT (
6115 gfc_typenode_for_spec (&code
->expr3
->ts
));
6117 gcc_assert (expr3_esize
);
6118 expr3_esize
= fold_convert (sizetype
, expr3_esize
);
6119 if (e3_is
== E3_MOLD
)
6120 /* The expr3 is no longer valid after this point. */
6123 else if (code
->ext
.alloc
.ts
.type
!= BT_UNKNOWN
)
6125 /* Compute the explicit typespec given only once for all objects
6127 if (code
->ext
.alloc
.ts
.type
!= BT_CHARACTER
)
6128 expr3_esize
= TYPE_SIZE_UNIT (
6129 gfc_typenode_for_spec (&code
->ext
.alloc
.ts
));
6130 else if (code
->ext
.alloc
.ts
.u
.cl
->length
!= NULL
)
6133 sz
= gfc_copy_expr (code
->ext
.alloc
.ts
.u
.cl
->length
);
6134 gfc_init_se (&se_sz
, NULL
);
6135 gfc_conv_expr (&se_sz
, sz
);
6137 tmp
= gfc_get_char_type (code
->ext
.alloc
.ts
.kind
);
6138 tmp
= TYPE_SIZE_UNIT (tmp
);
6139 tmp
= fold_convert (TREE_TYPE (se_sz
.expr
), tmp
);
6140 gfc_add_block_to_block (&block
, &se_sz
.pre
);
6141 expr3_esize
= fold_build2_loc (input_location
, MULT_EXPR
,
6142 TREE_TYPE (se_sz
.expr
),
6144 expr3_esize
= gfc_evaluate_now (expr3_esize
, &block
);
6147 expr3_esize
= NULL_TREE
;
6150 /* The routine gfc_trans_assignment () already implements all
6151 techniques needed. Unfortunately we may have a temporary
6152 variable for the source= expression here. When that is the
6153 case convert this variable into a temporary gfc_expr of type
6154 EXPR_VARIABLE and used it as rhs for the assignment. The
6155 advantage is, that we get scalarizer support for free,
6156 don't have to take care about scalar to array treatment and
6157 will benefit of every enhancements gfc_trans_assignment ()
6159 No need to check whether e3_is is E3_UNSET, because that is
6160 done by expr3 != NULL_TREE.
6161 Exclude variables since the following block does not handle
6162 array sections. In any case, there is no harm in sending
6163 variables to gfc_trans_assignment because there is no
6164 evaluation of variables. */
6167 if (code
->expr3
->expr_type
!= EXPR_VARIABLE
6168 && e3_is
!= E3_MOLD
&& expr3
!= NULL_TREE
6169 && DECL_P (expr3
) && DECL_ARTIFICIAL (expr3
))
6171 /* Build a temporary symtree and symbol. Do not add it to the current
6172 namespace to prevent accidently modifying a colliding
6174 newsym
= XCNEW (gfc_symtree
);
6175 /* The name of the symtree should be unique, because gfc_create_var ()
6176 took care about generating the identifier. */
6178 = gfc_get_string ("%s", IDENTIFIER_POINTER (DECL_NAME (expr3
)));
6179 newsym
->n
.sym
= gfc_new_symbol (newsym
->name
, NULL
);
6180 /* The backend_decl is known. It is expr3, which is inserted
6182 newsym
->n
.sym
->backend_decl
= expr3
;
6183 e3rhs
= gfc_get_expr ();
6184 e3rhs
->rank
= code
->expr3
->rank
;
6185 e3rhs
->symtree
= newsym
;
6186 /* Mark the symbol referenced or gfc_trans_assignment will bug. */
6187 newsym
->n
.sym
->attr
.referenced
= 1;
6188 e3rhs
->expr_type
= EXPR_VARIABLE
;
6189 e3rhs
->where
= code
->expr3
->where
;
6190 /* Set the symbols type, upto it was BT_UNKNOWN. */
6191 if (IS_CLASS_ARRAY (code
->expr3
)
6192 && code
->expr3
->expr_type
== EXPR_FUNCTION
6193 && code
->expr3
->value
.function
.isym
6194 && code
->expr3
->value
.function
.isym
->transformational
)
6196 e3rhs
->ts
= CLASS_DATA (code
->expr3
)->ts
;
6198 else if (code
->expr3
->ts
.type
== BT_CLASS
6199 && !GFC_CLASS_TYPE_P (TREE_TYPE (expr3
)))
6200 e3rhs
->ts
= CLASS_DATA (code
->expr3
)->ts
;
6202 e3rhs
->ts
= code
->expr3
->ts
;
6203 newsym
->n
.sym
->ts
= e3rhs
->ts
;
6204 /* Check whether the expr3 is array valued. */
6207 gfc_array_spec
*arr
;
6208 arr
= gfc_get_array_spec ();
6209 arr
->rank
= e3rhs
->rank
;
6210 arr
->type
= AS_DEFERRED
;
6211 /* Set the dimension and pointer attribute for arrays
6212 to be on the safe side. */
6213 newsym
->n
.sym
->attr
.dimension
= 1;
6214 newsym
->n
.sym
->attr
.pointer
= 1;
6215 newsym
->n
.sym
->as
= arr
;
6216 if (IS_CLASS_ARRAY (code
->expr3
)
6217 && code
->expr3
->expr_type
== EXPR_FUNCTION
6218 && code
->expr3
->value
.function
.isym
6219 && code
->expr3
->value
.function
.isym
->transformational
)
6221 gfc_array_spec
*tarr
;
6222 tarr
= gfc_get_array_spec ();
6224 e3rhs
->ts
.u
.derived
->as
= tarr
;
6226 gfc_add_full_array_ref (e3rhs
, arr
);
6228 else if (POINTER_TYPE_P (TREE_TYPE (expr3
)))
6229 newsym
->n
.sym
->attr
.pointer
= 1;
6230 /* The string length is known, too. Set it for char arrays. */
6231 if (e3rhs
->ts
.type
== BT_CHARACTER
)
6232 newsym
->n
.sym
->ts
.u
.cl
->backend_decl
= expr3_len
;
6233 gfc_commit_symbol (newsym
->n
.sym
);
6236 e3rhs
= gfc_copy_expr (code
->expr3
);
6238 // We need to propagate the bounds of the expr3 for source=/mold=;
6239 // however, for nondescriptor arrays, we use internally a lower bound
6240 // of zero instead of one, which needs to be corrected for the allocate obj
6241 if (e3_is
== E3_DESC
)
6243 symbol_attribute attr
= gfc_expr_attr (code
->expr3
);
6244 if (code
->expr3
->expr_type
== EXPR_ARRAY
||
6245 (!attr
.allocatable
&& !attr
.pointer
))
6246 e3_has_nodescriptor
= true;
6250 /* Loop over all objects to allocate. */
6251 for (al
= code
->ext
.alloc
.list
; al
!= NULL
; al
= al
->next
)
6253 expr
= gfc_copy_expr (al
->expr
);
6254 /* UNLIMITED_POLY () needs the _data component to be set, when
6255 expr is a unlimited polymorphic object. But the _data component
6256 has not been set yet, so check the derived type's attr for the
6257 unlimited polymorphic flag to be safe. */
6258 upoly_expr
= UNLIMITED_POLY (expr
)
6259 || (expr
->ts
.type
== BT_DERIVED
6260 && expr
->ts
.u
.derived
->attr
.unlimited_polymorphic
);
6261 gfc_init_se (&se
, NULL
);
6263 /* For class types prepare the expressions to ref the _vptr
6264 and the _len component. The latter for unlimited polymorphic
6266 if (expr
->ts
.type
== BT_CLASS
)
6268 gfc_expr
*expr_ref_vptr
, *expr_ref_len
;
6269 gfc_add_data_component (expr
);
6270 /* Prep the vptr handle. */
6271 expr_ref_vptr
= gfc_copy_expr (al
->expr
);
6272 gfc_add_vptr_component (expr_ref_vptr
);
6273 se
.want_pointer
= 1;
6274 gfc_conv_expr (&se
, expr_ref_vptr
);
6276 se
.want_pointer
= 0;
6277 gfc_free_expr (expr_ref_vptr
);
6278 /* Allocated unlimited polymorphic objects always have a _len
6282 expr_ref_len
= gfc_copy_expr (al
->expr
);
6283 gfc_add_len_component (expr_ref_len
);
6284 gfc_conv_expr (&se
, expr_ref_len
);
6286 gfc_free_expr (expr_ref_len
);
6289 /* In a loop ensure that all loop variable dependent variables
6290 are initialized at the same spot in all execution paths. */
6294 al_vptr
= al_len
= NULL_TREE
;
6296 se
.want_pointer
= 1;
6297 se
.descriptor_only
= 1;
6299 gfc_conv_expr (&se
, expr
);
6300 if (expr
->ts
.type
== BT_CHARACTER
&& expr
->ts
.deferred
)
6301 /* se.string_length now stores the .string_length variable of expr
6302 needed to allocate character(len=:) arrays. */
6303 al_len
= se
.string_length
;
6305 al_len_needs_set
= al_len
!= NULL_TREE
;
6306 /* When allocating an array one cannot use much of the
6307 pre-evaluated expr3 expressions, because for most of them the
6308 scalarizer is needed which is not available in the pre-evaluation
6309 step. Therefore gfc_array_allocate () is responsible (and able)
6310 to handle the complete array allocation. Only the element size
6311 needs to be provided, which is done most of the time by the
6312 pre-evaluation step. */
6314 if (expr3_len
&& (code
->expr3
->ts
.type
== BT_CHARACTER
6315 || code
->expr3
->ts
.type
== BT_CLASS
))
6317 /* When al is an array, then the element size for each element
6318 in the array is needed, which is the product of the len and
6319 esize for char arrays. For unlimited polymorphics len can be
6320 zero, therefore take the maximum of len and one. */
6321 tmp
= fold_build2_loc (input_location
, MAX_EXPR
,
6322 TREE_TYPE (expr3_len
),
6323 expr3_len
, fold_convert (TREE_TYPE (expr3_len
),
6325 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
6326 TREE_TYPE (expr3_esize
), expr3_esize
,
6327 fold_convert (TREE_TYPE (expr3_esize
), tmp
));
6332 if (!gfc_array_allocate (&se
, expr
, stat
, errmsg
, errlen
,
6333 label_finish
, tmp
, &nelems
,
6334 e3rhs
? e3rhs
: code
->expr3
,
6335 e3_is
== E3_DESC
? expr3
: NULL_TREE
,
6336 e3_has_nodescriptor
))
6338 /* A scalar or derived type. First compute the size to
6341 expr3_len is set when expr3 is an unlimited polymorphic
6342 object or a deferred length string. */
6343 if (expr3_len
!= NULL_TREE
)
6345 tmp
= fold_convert (TREE_TYPE (expr3_esize
), expr3_len
);
6346 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
6347 TREE_TYPE (expr3_esize
),
6349 if (code
->expr3
->ts
.type
!= BT_CLASS
)
6350 /* expr3 is a deferred length string, i.e., we are
6355 /* For unlimited polymorphic enties build
6356 (len > 0) ? element_size * len : element_size
6357 to compute the number of bytes to allocate.
6358 This allows the allocation of unlimited polymorphic
6359 objects from an expr3 that is also unlimited
6360 polymorphic and stores a _len dependent object,
6362 memsz
= fold_build2_loc (input_location
, GT_EXPR
,
6363 logical_type_node
, expr3_len
,
6365 (TREE_TYPE (expr3_len
)));
6366 memsz
= fold_build3_loc (input_location
, COND_EXPR
,
6367 TREE_TYPE (expr3_esize
),
6368 memsz
, tmp
, expr3_esize
);
6371 else if (expr3_esize
!= NULL_TREE
)
6372 /* Any other object in expr3 just needs element size in
6374 memsz
= expr3_esize
;
6375 else if ((expr
->ts
.type
== BT_CHARACTER
&& expr
->ts
.deferred
)
6377 && code
->ext
.alloc
.ts
.type
== BT_CHARACTER
))
6379 /* Allocating deferred length char arrays need the length
6380 to allocate in the alloc_type_spec. But also unlimited
6381 polymorphic objects may be allocated as char arrays.
6382 Both are handled here. */
6383 gfc_init_se (&se_sz
, NULL
);
6384 gfc_conv_expr (&se_sz
, code
->ext
.alloc
.ts
.u
.cl
->length
);
6385 gfc_add_block_to_block (&se
.pre
, &se_sz
.pre
);
6386 se_sz
.expr
= gfc_evaluate_now (se_sz
.expr
, &se
.pre
);
6387 gfc_add_block_to_block (&se
.pre
, &se_sz
.post
);
6388 expr3_len
= se_sz
.expr
;
6389 tmp_expr3_len_flag
= true;
6390 tmp
= TYPE_SIZE_UNIT (
6391 gfc_get_char_type (code
->ext
.alloc
.ts
.kind
));
6392 memsz
= fold_build2_loc (input_location
, MULT_EXPR
,
6394 fold_convert (TREE_TYPE (tmp
),
6398 else if (expr
->ts
.type
== BT_CHARACTER
)
6400 /* Compute the number of bytes needed to allocate a fixed
6401 length char array. */
6402 gcc_assert (se
.string_length
!= NULL_TREE
);
6403 tmp
= TYPE_SIZE_UNIT (gfc_get_char_type (expr
->ts
.kind
));
6404 memsz
= fold_build2_loc (input_location
, MULT_EXPR
,
6405 TREE_TYPE (tmp
), tmp
,
6406 fold_convert (TREE_TYPE (tmp
),
6409 else if (code
->ext
.alloc
.ts
.type
!= BT_UNKNOWN
)
6410 /* Handle all types, where the alloc_type_spec is set. */
6411 memsz
= TYPE_SIZE_UNIT (gfc_typenode_for_spec (&code
->ext
.alloc
.ts
));
6413 /* Handle size computation of the type declared to alloc. */
6414 memsz
= TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (se
.expr
)));
6416 /* Store the caf-attributes for latter use. */
6417 if (flag_coarray
== GFC_FCOARRAY_LIB
6418 && (caf_attr
= gfc_caf_attr (expr
, true, &caf_refs_comp
))
6421 /* Scalar allocatable components in coarray'ed derived types make
6422 it here and are treated now. */
6423 tree caf_decl
, token
;
6427 /* Set flag, to add synchronize after the allocate. */
6428 needs_caf_sync
= needs_caf_sync
6429 || caf_attr
.coarray_comp
|| !caf_refs_comp
;
6431 gfc_init_se (&caf_se
, NULL
);
6433 caf_decl
= gfc_get_tree_for_caf_expr (expr
);
6434 gfc_get_caf_token_offset (&caf_se
, &token
, NULL
, caf_decl
,
6436 gfc_add_block_to_block (&se
.pre
, &caf_se
.pre
);
6437 gfc_allocate_allocatable (&se
.pre
, se
.expr
, memsz
,
6438 gfc_build_addr_expr (NULL_TREE
, token
),
6439 NULL_TREE
, NULL_TREE
, NULL_TREE
,
6440 label_finish
, expr
, 1);
6442 /* Allocate - for non-pointers with re-alloc checking. */
6443 else if (gfc_expr_attr (expr
).allocatable
)
6444 gfc_allocate_allocatable (&se
.pre
, se
.expr
, memsz
,
6445 NULL_TREE
, stat
, errmsg
, errlen
,
6446 label_finish
, expr
, 0);
6448 gfc_allocate_using_malloc (&se
.pre
, se
.expr
, memsz
, stat
);
6452 /* Allocating coarrays needs a sync after the allocate executed.
6453 Set the flag to add the sync after all objects are allocated. */
6454 if (flag_coarray
== GFC_FCOARRAY_LIB
6455 && (caf_attr
= gfc_caf_attr (expr
, true, &caf_refs_comp
))
6459 needs_caf_sync
= needs_caf_sync
6460 || caf_attr
.coarray_comp
|| !caf_refs_comp
;
6463 if (expr
->ts
.type
== BT_CHARACTER
&& al_len
!= NULL_TREE
6464 && expr3_len
!= NULL_TREE
)
6466 /* Arrays need to have a _len set before the array
6467 descriptor is filled. */
6468 gfc_add_modify (&block
, al_len
,
6469 fold_convert (TREE_TYPE (al_len
), expr3_len
));
6470 /* Prevent setting the length twice. */
6471 al_len_needs_set
= false;
6473 else if (expr
->ts
.type
== BT_CHARACTER
&& al_len
!= NULL_TREE
6474 && code
->ext
.alloc
.ts
.u
.cl
->length
)
6476 /* Cover the cases where a string length is explicitly
6477 specified by a type spec for deferred length character
6478 arrays or unlimited polymorphic objects without a
6479 source= or mold= expression. */
6480 gfc_init_se (&se_sz
, NULL
);
6481 gfc_conv_expr (&se_sz
, code
->ext
.alloc
.ts
.u
.cl
->length
);
6482 gfc_add_block_to_block (&block
, &se_sz
.pre
);
6483 gfc_add_modify (&block
, al_len
,
6484 fold_convert (TREE_TYPE (al_len
),
6486 al_len_needs_set
= false;
6490 gfc_add_block_to_block (&block
, &se
.pre
);
6492 /* Error checking -- Note: ERRMSG only makes sense with STAT. */
6495 tmp
= build1_v (GOTO_EXPR
, label_errmsg
);
6496 parm
= fold_build2_loc (input_location
, NE_EXPR
,
6497 logical_type_node
, stat
,
6498 build_int_cst (TREE_TYPE (stat
), 0));
6499 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
6500 gfc_unlikely (parm
, PRED_FORTRAN_FAIL_ALLOC
),
6501 tmp
, build_empty_stmt (input_location
));
6502 gfc_add_expr_to_block (&block
, tmp
);
6505 /* Set the vptr only when no source= is set. When source= is set, then
6506 the trans_assignment below will set the vptr. */
6507 if (al_vptr
!= NULL_TREE
&& (!code
->expr3
|| code
->expr3
->mold
))
6509 if (expr3_vptr
!= NULL_TREE
)
6510 /* The vtab is already known, so just assign it. */
6511 gfc_add_modify (&block
, al_vptr
,
6512 fold_convert (TREE_TYPE (al_vptr
), expr3_vptr
));
6515 /* VPTR is fixed at compile time. */
6520 /* Although expr3 is pre-evaluated above, it may happen,
6521 that for arrays or in mold= cases the pre-evaluation
6522 was not successful. In these rare cases take the vtab
6523 from the typespec of expr3 here. */
6524 ts
= &code
->expr3
->ts
;
6525 else if (code
->ext
.alloc
.ts
.type
== BT_DERIVED
|| upoly_expr
)
6526 /* The alloc_type_spec gives the type to allocate or the
6527 al is unlimited polymorphic, which enforces the use of
6528 an alloc_type_spec that is not necessarily a BT_DERIVED. */
6529 ts
= &code
->ext
.alloc
.ts
;
6531 /* Prepare for setting the vtab as declared. */
6534 vtab
= gfc_find_vtab (ts
);
6536 tmp
= gfc_build_addr_expr (NULL_TREE
,
6537 gfc_get_symbol_decl (vtab
));
6538 gfc_add_modify (&block
, al_vptr
,
6539 fold_convert (TREE_TYPE (al_vptr
), tmp
));
6543 /* Add assignment for string length. */
6544 if (al_len
!= NULL_TREE
&& al_len_needs_set
)
6546 if (expr3_len
!= NULL_TREE
)
6548 gfc_add_modify (&block
, al_len
,
6549 fold_convert (TREE_TYPE (al_len
),
6551 /* When tmp_expr3_len_flag is set, then expr3_len is
6552 abused to carry the length information from the
6553 alloc_type. Clear it to prevent setting incorrect len
6554 information in future loop iterations. */
6555 if (tmp_expr3_len_flag
)
6556 /* No need to reset tmp_expr3_len_flag, because the
6557 presence of an expr3 cannot change within in the
6559 expr3_len
= NULL_TREE
;
6561 else if (code
->ext
.alloc
.ts
.type
== BT_CHARACTER
6562 && code
->ext
.alloc
.ts
.u
.cl
->length
)
6564 /* Cover the cases where a string length is explicitly
6565 specified by a type spec for deferred length character
6566 arrays or unlimited polymorphic objects without a
6567 source= or mold= expression. */
6568 if (expr3_esize
== NULL_TREE
|| code
->ext
.alloc
.ts
.kind
!= 1)
6570 gfc_init_se (&se_sz
, NULL
);
6571 gfc_conv_expr (&se_sz
, code
->ext
.alloc
.ts
.u
.cl
->length
);
6572 gfc_add_block_to_block (&block
, &se_sz
.pre
);
6573 gfc_add_modify (&block
, al_len
,
6574 fold_convert (TREE_TYPE (al_len
),
6578 gfc_add_modify (&block
, al_len
,
6579 fold_convert (TREE_TYPE (al_len
),
6583 /* No length information needed, because type to allocate
6584 has no length. Set _len to 0. */
6585 gfc_add_modify (&block
, al_len
,
6586 fold_convert (TREE_TYPE (al_len
),
6587 integer_zero_node
));
6591 if (code
->expr3
&& !code
->expr3
->mold
&& e3_is
!= E3_MOLD
)
6593 /* Initialization via SOURCE block (or static default initializer).
6594 Switch off automatic reallocation since we have just done the
6596 int realloc_lhs
= flag_realloc_lhs
;
6597 gfc_expr
*init_expr
= gfc_expr_to_initialize (expr
);
6598 gfc_expr
*rhs
= e3rhs
? e3rhs
: gfc_copy_expr (code
->expr3
);
6599 flag_realloc_lhs
= 0;
6600 tmp
= gfc_trans_assignment (init_expr
, rhs
, false, false, true,
6602 flag_realloc_lhs
= realloc_lhs
;
6603 /* Free the expression allocated for init_expr. */
6604 gfc_free_expr (init_expr
);
6606 gfc_free_expr (rhs
);
6607 gfc_add_expr_to_block (&block
, tmp
);
6609 /* Set KIND and LEN PDT components and allocate those that are
6611 else if (expr
->ts
.type
== BT_DERIVED
6612 && expr
->ts
.u
.derived
->attr
.pdt_type
)
6614 if (code
->expr3
&& code
->expr3
->param_list
)
6615 param_list
= code
->expr3
->param_list
;
6616 else if (expr
->param_list
)
6617 param_list
= expr
->param_list
;
6619 param_list
= expr
->symtree
->n
.sym
->param_list
;
6620 tmp
= gfc_allocate_pdt_comp (expr
->ts
.u
.derived
, se
.expr
,
6621 expr
->rank
, param_list
);
6622 gfc_add_expr_to_block (&block
, tmp
);
6624 /* Ditto for CLASS expressions. */
6625 else if (expr
->ts
.type
== BT_CLASS
6626 && CLASS_DATA (expr
)->ts
.u
.derived
->attr
.pdt_type
)
6628 if (code
->expr3
&& code
->expr3
->param_list
)
6629 param_list
= code
->expr3
->param_list
;
6630 else if (expr
->param_list
)
6631 param_list
= expr
->param_list
;
6633 param_list
= expr
->symtree
->n
.sym
->param_list
;
6634 tmp
= gfc_allocate_pdt_comp (CLASS_DATA (expr
)->ts
.u
.derived
,
6635 se
.expr
, expr
->rank
, param_list
);
6636 gfc_add_expr_to_block (&block
, tmp
);
6638 else if (code
->expr3
&& code
->expr3
->mold
6639 && code
->expr3
->ts
.type
== BT_CLASS
)
6641 /* Use class_init_assign to initialize expr. */
6643 ini
= gfc_get_code (EXEC_INIT_ASSIGN
);
6644 ini
->expr1
= gfc_find_and_cut_at_last_class_ref (expr
, true);
6645 tmp
= gfc_trans_class_init_assign (ini
);
6646 gfc_free_statements (ini
);
6647 gfc_add_expr_to_block (&block
, tmp
);
6649 else if ((init_expr
= allocate_get_initializer (code
, expr
)))
6651 /* Use class_init_assign to initialize expr. */
6653 int realloc_lhs
= flag_realloc_lhs
;
6654 ini
= gfc_get_code (EXEC_INIT_ASSIGN
);
6655 ini
->expr1
= gfc_expr_to_initialize (expr
);
6656 ini
->expr2
= init_expr
;
6657 flag_realloc_lhs
= 0;
6658 tmp
= gfc_trans_init_assign (ini
);
6659 flag_realloc_lhs
= realloc_lhs
;
6660 gfc_free_statements (ini
);
6661 /* Init_expr is freeed by above free_statements, just need to null
6664 gfc_add_expr_to_block (&block
, tmp
);
6667 /* Nullify all pointers in derived type coarrays. This registers a
6668 token for them which allows their allocation. */
6671 gfc_symbol
*type
= NULL
;
6672 symbol_attribute caf_attr
;
6674 if (code
->ext
.alloc
.ts
.type
== BT_DERIVED
6675 && code
->ext
.alloc
.ts
.u
.derived
->attr
.pointer_comp
)
6677 type
= code
->ext
.alloc
.ts
.u
.derived
;
6678 rank
= type
->attr
.dimension
? type
->as
->rank
: 0;
6679 gfc_clear_attr (&caf_attr
);
6681 else if (expr
->ts
.type
== BT_DERIVED
6682 && expr
->ts
.u
.derived
->attr
.pointer_comp
)
6684 type
= expr
->ts
.u
.derived
;
6686 caf_attr
= gfc_caf_attr (expr
, true);
6689 /* Initialize the tokens of pointer components in derived type
6693 tmp
= (caf_attr
.codimension
&& !caf_attr
.dimension
)
6694 ? gfc_conv_descriptor_data_get (se
.expr
) : se
.expr
;
6695 tmp
= gfc_nullify_alloc_comp (type
, tmp
, rank
,
6696 GFC_STRUCTURE_CAF_MODE_IN_COARRAY
);
6697 gfc_add_expr_to_block (&block
, tmp
);
6701 gfc_free_expr (expr
);
6708 gfc_free_symbol (newsym
->n
.sym
);
6711 gfc_free_expr (e3rhs
);
6716 tmp
= build1_v (LABEL_EXPR
, label_errmsg
);
6717 gfc_add_expr_to_block (&block
, tmp
);
6720 /* ERRMSG - only useful if STAT is present. */
6721 if (code
->expr1
&& code
->expr2
)
6723 const char *msg
= "Attempt to allocate an allocated object";
6724 tree slen
, dlen
, errmsg_str
;
6725 stmtblock_t errmsg_block
;
6727 gfc_init_block (&errmsg_block
);
6729 errmsg_str
= gfc_create_var (pchar_type_node
, "ERRMSG");
6730 gfc_add_modify (&errmsg_block
, errmsg_str
,
6731 gfc_build_addr_expr (pchar_type_node
,
6732 gfc_build_localized_cstring_const (msg
)));
6734 slen
= build_int_cst (gfc_charlen_type_node
, strlen (msg
));
6735 dlen
= gfc_get_expr_charlen (code
->expr2
);
6736 slen
= fold_build2_loc (input_location
, MIN_EXPR
,
6737 TREE_TYPE (slen
), dlen
, slen
);
6739 gfc_trans_string_copy (&errmsg_block
, dlen
, errmsg
,
6740 code
->expr2
->ts
.kind
,
6742 gfc_default_character_kind
);
6743 dlen
= gfc_finish_block (&errmsg_block
);
6745 tmp
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
6746 stat
, build_int_cst (TREE_TYPE (stat
), 0));
6748 tmp
= build3_v (COND_EXPR
, tmp
,
6749 dlen
, build_empty_stmt (input_location
));
6751 gfc_add_expr_to_block (&block
, tmp
);
6757 if (TREE_USED (label_finish
))
6759 tmp
= build1_v (LABEL_EXPR
, label_finish
);
6760 gfc_add_expr_to_block (&block
, tmp
);
6763 gfc_init_se (&se
, NULL
);
6764 gfc_conv_expr_lhs (&se
, code
->expr1
);
6765 tmp
= convert (TREE_TYPE (se
.expr
), stat
);
6766 gfc_add_modify (&block
, se
.expr
, tmp
);
6771 /* Add a sync all after the allocation has been executed. */
6772 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_sync_all
,
6773 3, null_pointer_node
, null_pointer_node
,
6775 gfc_add_expr_to_block (&post
, tmp
);
6778 gfc_add_block_to_block (&block
, &se
.post
);
6779 gfc_add_block_to_block (&block
, &post
);
6780 if (code
->expr3
&& code
->expr3
->must_finalize
)
6781 gfc_add_block_to_block (&block
, &final_block
);
6783 return gfc_finish_block (&block
);
6787 /* Translate a DEALLOCATE statement. */
6790 gfc_trans_deallocate (gfc_code
*code
)
6794 tree apstat
, pstat
, stat
, errmsg
, errlen
, tmp
;
6795 tree label_finish
, label_errmsg
;
6798 pstat
= apstat
= stat
= errmsg
= errlen
= tmp
= NULL_TREE
;
6799 label_finish
= label_errmsg
= NULL_TREE
;
6801 gfc_start_block (&block
);
6803 /* Count the number of failed deallocations. If deallocate() was
6804 called with STAT= , then set STAT to the count. If deallocate
6805 was called with ERRMSG, then set ERRMG to a string. */
6808 tree gfc_int4_type_node
= gfc_get_int_type (4);
6810 stat
= gfc_create_var (gfc_int4_type_node
, "stat");
6811 pstat
= gfc_build_addr_expr (NULL_TREE
, stat
);
6813 /* GOTO destinations. */
6814 label_errmsg
= gfc_build_label_decl (NULL_TREE
);
6815 label_finish
= gfc_build_label_decl (NULL_TREE
);
6816 TREE_USED (label_finish
) = 0;
6819 /* Set ERRMSG - only needed if STAT is available. */
6820 if (code
->expr1
&& code
->expr2
)
6822 gfc_init_se (&se
, NULL
);
6823 se
.want_pointer
= 1;
6824 gfc_conv_expr_lhs (&se
, code
->expr2
);
6826 errlen
= se
.string_length
;
6829 for (al
= code
->ext
.alloc
.list
; al
!= NULL
; al
= al
->next
)
6831 gfc_expr
*expr
= gfc_copy_expr (al
->expr
);
6832 bool is_coarray
= false, is_coarray_array
= false;
6835 gcc_assert (expr
->expr_type
== EXPR_VARIABLE
);
6837 if (expr
->ts
.type
== BT_CLASS
)
6838 gfc_add_data_component (expr
);
6840 gfc_init_se (&se
, NULL
);
6841 gfc_start_block (&se
.pre
);
6843 se
.want_pointer
= 1;
6844 se
.descriptor_only
= 1;
6845 gfc_conv_expr (&se
, expr
);
6847 /* Deallocate PDT components that are parameterized. */
6849 if (expr
->ts
.type
== BT_DERIVED
6850 && expr
->ts
.u
.derived
->attr
.pdt_type
6851 && expr
->symtree
->n
.sym
->param_list
)
6852 tmp
= gfc_deallocate_pdt_comp (expr
->ts
.u
.derived
, se
.expr
, expr
->rank
);
6853 else if (expr
->ts
.type
== BT_CLASS
6854 && CLASS_DATA (expr
)->ts
.u
.derived
->attr
.pdt_type
6855 && expr
->symtree
->n
.sym
->param_list
)
6856 tmp
= gfc_deallocate_pdt_comp (CLASS_DATA (expr
)->ts
.u
.derived
,
6857 se
.expr
, expr
->rank
);
6860 gfc_add_expr_to_block (&block
, tmp
);
6862 if (flag_coarray
== GFC_FCOARRAY_LIB
6863 || flag_coarray
== GFC_FCOARRAY_SINGLE
)
6866 symbol_attribute caf_attr
= gfc_caf_attr (expr
, false, &comp_ref
);
6867 if (caf_attr
.codimension
)
6870 is_coarray_array
= caf_attr
.dimension
|| !comp_ref
6871 || caf_attr
.coarray_comp
;
6873 if (flag_coarray
== GFC_FCOARRAY_LIB
)
6874 /* When the expression to deallocate is referencing a
6875 component, then only deallocate it, but do not
6877 caf_mode
= GFC_STRUCTURE_CAF_MODE_IN_COARRAY
6878 | (comp_ref
&& !caf_attr
.coarray_comp
6879 ? GFC_STRUCTURE_CAF_MODE_DEALLOC_ONLY
: 0);
6883 if (expr
->rank
|| is_coarray_array
)
6887 if (gfc_bt_struct (expr
->ts
.type
)
6888 && expr
->ts
.u
.derived
->attr
.alloc_comp
6889 && !gfc_is_finalizable (expr
->ts
.u
.derived
, NULL
))
6891 gfc_ref
*last
= NULL
;
6893 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
6894 if (ref
->type
== REF_COMPONENT
)
6897 /* Do not deallocate the components of a derived type
6898 ultimate pointer component. */
6899 if (!(last
&& last
->u
.c
.component
->attr
.pointer
)
6900 && !(!last
&& expr
->symtree
->n
.sym
->attr
.pointer
))
6902 if (is_coarray
&& expr
->rank
== 0
6903 && (!last
|| !last
->u
.c
.component
->attr
.dimension
)
6904 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se
.expr
)))
6906 /* Add the ref to the data member only, when this is not
6907 a regular array or deallocate_alloc_comp will try to
6909 tmp
= gfc_conv_descriptor_data_get (se
.expr
);
6913 tmp
= gfc_deallocate_alloc_comp (expr
->ts
.u
.derived
, tmp
,
6914 expr
->rank
, caf_mode
);
6915 gfc_add_expr_to_block (&se
.pre
, tmp
);
6919 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se
.expr
)))
6921 gfc_coarray_deregtype caf_dtype
;
6924 caf_dtype
= gfc_caf_is_dealloc_only (caf_mode
)
6925 ? GFC_CAF_COARRAY_DEALLOCATE_ONLY
6926 : GFC_CAF_COARRAY_DEREGISTER
;
6928 caf_dtype
= GFC_CAF_COARRAY_NOCOARRAY
;
6929 tmp
= gfc_deallocate_with_status (se
.expr
, pstat
, errmsg
, errlen
,
6930 label_finish
, false, expr
,
6932 gfc_add_expr_to_block (&se
.pre
, tmp
);
6934 else if (TREE_CODE (se
.expr
) == COMPONENT_REF
6935 && TREE_CODE (TREE_TYPE (se
.expr
)) == ARRAY_TYPE
6936 && TREE_CODE (TREE_TYPE (TREE_TYPE (se
.expr
)))
6939 /* class.c(finalize_component) generates these, when a
6940 finalizable entity has a non-allocatable derived type array
6941 component, which has allocatable components. Obtain the
6942 derived type of the array and deallocate the allocatable
6944 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
6946 if (ref
->u
.c
.component
->attr
.dimension
6947 && ref
->u
.c
.component
->ts
.type
== BT_DERIVED
)
6951 if (ref
&& ref
->u
.c
.component
->ts
.u
.derived
->attr
.alloc_comp
6952 && !gfc_is_finalizable (ref
->u
.c
.component
->ts
.u
.derived
,
6955 tmp
= gfc_deallocate_alloc_comp
6956 (ref
->u
.c
.component
->ts
.u
.derived
,
6957 se
.expr
, expr
->rank
);
6958 gfc_add_expr_to_block (&se
.pre
, tmp
);
6962 if (al
->expr
->ts
.type
== BT_CLASS
)
6964 gfc_reset_vptr (&se
.pre
, al
->expr
);
6965 if (UNLIMITED_POLY (al
->expr
)
6966 || (al
->expr
->ts
.type
== BT_DERIVED
6967 && al
->expr
->ts
.u
.derived
->attr
.unlimited_polymorphic
))
6968 /* Clear _len, too. */
6969 gfc_reset_len (&se
.pre
, al
->expr
);
6974 tmp
= gfc_deallocate_scalar_with_status (se
.expr
, pstat
, label_finish
,
6976 al
->expr
->ts
, is_coarray
);
6977 gfc_add_expr_to_block (&se
.pre
, tmp
);
6979 /* Set to zero after deallocation. */
6980 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
, void_type_node
,
6982 build_int_cst (TREE_TYPE (se
.expr
), 0));
6983 gfc_add_expr_to_block (&se
.pre
, tmp
);
6985 if (al
->expr
->ts
.type
== BT_CLASS
)
6987 gfc_reset_vptr (&se
.pre
, al
->expr
);
6988 if (UNLIMITED_POLY (al
->expr
)
6989 || (al
->expr
->ts
.type
== BT_DERIVED
6990 && al
->expr
->ts
.u
.derived
->attr
.unlimited_polymorphic
))
6991 /* Clear _len, too. */
6992 gfc_reset_len (&se
.pre
, al
->expr
);
7000 cond
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
, stat
,
7001 build_int_cst (TREE_TYPE (stat
), 0));
7002 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
7003 gfc_unlikely (cond
, PRED_FORTRAN_FAIL_ALLOC
),
7004 build1_v (GOTO_EXPR
, label_errmsg
),
7005 build_empty_stmt (input_location
));
7006 gfc_add_expr_to_block (&se
.pre
, tmp
);
7009 tmp
= gfc_finish_block (&se
.pre
);
7010 gfc_add_expr_to_block (&block
, tmp
);
7011 gfc_free_expr (expr
);
7016 tmp
= build1_v (LABEL_EXPR
, label_errmsg
);
7017 gfc_add_expr_to_block (&block
, tmp
);
7020 /* Set ERRMSG - only needed if STAT is available. */
7021 if (code
->expr1
&& code
->expr2
)
7023 const char *msg
= "Attempt to deallocate an unallocated object";
7024 stmtblock_t errmsg_block
;
7025 tree errmsg_str
, slen
, dlen
, cond
;
7027 gfc_init_block (&errmsg_block
);
7029 errmsg_str
= gfc_create_var (pchar_type_node
, "ERRMSG");
7030 gfc_add_modify (&errmsg_block
, errmsg_str
,
7031 gfc_build_addr_expr (pchar_type_node
,
7032 gfc_build_localized_cstring_const (msg
)));
7033 slen
= build_int_cst (gfc_charlen_type_node
, strlen (msg
));
7034 dlen
= gfc_get_expr_charlen (code
->expr2
);
7036 gfc_trans_string_copy (&errmsg_block
, dlen
, errmsg
, code
->expr2
->ts
.kind
,
7037 slen
, errmsg_str
, gfc_default_character_kind
);
7038 tmp
= gfc_finish_block (&errmsg_block
);
7040 cond
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
, stat
,
7041 build_int_cst (TREE_TYPE (stat
), 0));
7042 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
7043 gfc_unlikely (cond
, PRED_FORTRAN_FAIL_ALLOC
), tmp
,
7044 build_empty_stmt (input_location
));
7046 gfc_add_expr_to_block (&block
, tmp
);
7049 if (code
->expr1
&& TREE_USED (label_finish
))
7051 tmp
= build1_v (LABEL_EXPR
, label_finish
);
7052 gfc_add_expr_to_block (&block
, tmp
);
7058 gfc_init_se (&se
, NULL
);
7059 gfc_conv_expr_lhs (&se
, code
->expr1
);
7060 tmp
= convert (TREE_TYPE (se
.expr
), stat
);
7061 gfc_add_modify (&block
, se
.expr
, tmp
);
7064 return gfc_finish_block (&block
);
7067 #include "gt-fortran-trans-stmt.h"