1 /* Statement translation -- generate GCC trees from gfc_code.
2 Copyright (C) 2002-2018 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 tree team_id
,team_type
;
712 gfc_init_se (&argse
, NULL
);
713 gfc_conv_expr_val (&argse
, code
->expr1
);
714 team_id
= fold_convert (integer_type_node
, argse
.expr
);
715 gfc_init_se (&argse
, NULL
);
716 gfc_conv_expr_val (&argse
, code
->expr2
);
717 team_type
= gfc_build_addr_expr (ppvoid_type_node
, argse
.expr
);
719 return build_call_expr_loc (input_location
,
720 gfor_fndecl_caf_form_team
, 3,
722 build_int_cst (integer_type_node
, 0));
726 const char *name
= gfc_get_string (PREFIX ("exit_i%d"), 4);
727 gfc_symbol
*exsym
= gfc_get_intrinsic_sub_symbol (name
);
728 tree tmp
= gfc_get_symbol_decl (exsym
);
729 return build_call_expr_loc (input_location
, tmp
, 1, integer_zero_node
);
733 /* Translate the CHANGE TEAM statement. */
736 gfc_trans_change_team (gfc_code
*code
)
738 if (flag_coarray
== GFC_FCOARRAY_LIB
)
743 gfc_init_se (&argse
, NULL
);
744 gfc_conv_expr_val (&argse
, code
->expr1
);
745 team_type
= gfc_build_addr_expr (ppvoid_type_node
, argse
.expr
);
747 return build_call_expr_loc (input_location
,
748 gfor_fndecl_caf_change_team
, 2, team_type
,
749 build_int_cst (integer_type_node
, 0));
753 const char *name
= gfc_get_string (PREFIX ("exit_i%d"), 4);
754 gfc_symbol
*exsym
= gfc_get_intrinsic_sub_symbol (name
);
755 tree tmp
= gfc_get_symbol_decl (exsym
);
756 return build_call_expr_loc (input_location
, tmp
, 1, integer_zero_node
);
760 /* Translate the END TEAM statement. */
763 gfc_trans_end_team (gfc_code
*code ATTRIBUTE_UNUSED
)
765 if (flag_coarray
== GFC_FCOARRAY_LIB
)
767 return build_call_expr_loc (input_location
,
768 gfor_fndecl_caf_end_team
, 1,
769 build_int_cst (pchar_type_node
, 0));
773 const char *name
= gfc_get_string (PREFIX ("exit_i%d"), 4);
774 gfc_symbol
*exsym
= gfc_get_intrinsic_sub_symbol (name
);
775 tree tmp
= gfc_get_symbol_decl (exsym
);
776 return build_call_expr_loc (input_location
, tmp
, 1, integer_zero_node
);
780 /* Translate the SYNC TEAM statement. */
783 gfc_trans_sync_team (gfc_code
*code
)
785 if (flag_coarray
== GFC_FCOARRAY_LIB
)
790 gfc_init_se (&argse
, NULL
);
791 gfc_conv_expr_val (&argse
, code
->expr1
);
792 team_type
= gfc_build_addr_expr (ppvoid_type_node
, argse
.expr
);
794 return build_call_expr_loc (input_location
,
795 gfor_fndecl_caf_sync_team
, 2,
797 build_int_cst (integer_type_node
, 0));
801 const char *name
= gfc_get_string (PREFIX ("exit_i%d"), 4);
802 gfc_symbol
*exsym
= gfc_get_intrinsic_sub_symbol (name
);
803 tree tmp
= gfc_get_symbol_decl (exsym
);
804 return build_call_expr_loc (input_location
, tmp
, 1, integer_zero_node
);
809 gfc_trans_lock_unlock (gfc_code
*code
, gfc_exec_op op
)
812 tree stat
= NULL_TREE
, stat2
= NULL_TREE
;
813 tree lock_acquired
= NULL_TREE
, lock_acquired2
= NULL_TREE
;
815 /* Short cut: For single images without STAT= or LOCK_ACQUIRED
816 return early. (ERRMSG= is always untouched for -fcoarray=single.) */
817 if (!code
->expr2
&& !code
->expr4
&& flag_coarray
!= GFC_FCOARRAY_LIB
)
822 gcc_assert (code
->expr2
->expr_type
== EXPR_VARIABLE
);
823 gfc_init_se (&argse
, NULL
);
824 gfc_conv_expr_val (&argse
, code
->expr2
);
827 else if (flag_coarray
== GFC_FCOARRAY_LIB
)
828 stat
= null_pointer_node
;
832 gcc_assert (code
->expr4
->expr_type
== EXPR_VARIABLE
);
833 gfc_init_se (&argse
, NULL
);
834 gfc_conv_expr_val (&argse
, code
->expr4
);
835 lock_acquired
= argse
.expr
;
837 else if (flag_coarray
== GFC_FCOARRAY_LIB
)
838 lock_acquired
= null_pointer_node
;
840 gfc_start_block (&se
.pre
);
841 if (flag_coarray
== GFC_FCOARRAY_LIB
)
843 tree tmp
, token
, image_index
, errmsg
, errmsg_len
;
844 tree index
= build_zero_cst (gfc_array_index_type
);
845 tree caf_decl
= gfc_get_tree_for_caf_expr (code
->expr1
);
847 if (code
->expr1
->symtree
->n
.sym
->ts
.type
!= BT_DERIVED
848 || code
->expr1
->symtree
->n
.sym
->ts
.u
.derived
->from_intmod
849 != INTMOD_ISO_FORTRAN_ENV
850 || code
->expr1
->symtree
->n
.sym
->ts
.u
.derived
->intmod_sym_id
851 != ISOFORTRAN_LOCK_TYPE
)
853 gfc_error ("Sorry, the lock component of derived type at %L is not "
854 "yet supported", &code
->expr1
->where
);
858 gfc_get_caf_token_offset (&se
, &token
, NULL
, caf_decl
, NULL_TREE
,
861 if (gfc_is_coindexed (code
->expr1
))
862 image_index
= gfc_caf_get_image_index (&se
.pre
, code
->expr1
, caf_decl
);
864 image_index
= integer_zero_node
;
866 /* For arrays, obtain the array index. */
867 if (gfc_expr_attr (code
->expr1
).dimension
)
869 tree desc
, tmp
, extent
, lbound
, ubound
;
870 gfc_array_ref
*ar
, ar2
;
873 /* TODO: Extend this, once DT components are supported. */
874 ar
= &code
->expr1
->ref
->u
.ar
;
876 memset (ar
, '\0', sizeof (*ar
));
880 gfc_init_se (&argse
, NULL
);
881 argse
.descriptor_only
= 1;
882 gfc_conv_expr_descriptor (&argse
, code
->expr1
);
883 gfc_add_block_to_block (&se
.pre
, &argse
.pre
);
887 extent
= build_one_cst (gfc_array_index_type
);
888 for (i
= 0; i
< ar
->dimen
; i
++)
890 gfc_init_se (&argse
, NULL
);
891 gfc_conv_expr_type (&argse
, ar
->start
[i
], gfc_array_index_type
);
892 gfc_add_block_to_block (&argse
.pre
, &argse
.pre
);
893 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[i
]);
894 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
895 TREE_TYPE (lbound
), argse
.expr
, lbound
);
896 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
897 TREE_TYPE (tmp
), extent
, tmp
);
898 index
= fold_build2_loc (input_location
, PLUS_EXPR
,
899 TREE_TYPE (tmp
), index
, tmp
);
900 if (i
< ar
->dimen
- 1)
902 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[i
]);
903 tmp
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
904 extent
= fold_build2_loc (input_location
, MULT_EXPR
,
905 TREE_TYPE (tmp
), extent
, tmp
);
913 gfc_init_se (&argse
, NULL
);
914 argse
.want_pointer
= 1;
915 gfc_conv_expr (&argse
, code
->expr3
);
916 gfc_add_block_to_block (&se
.pre
, &argse
.pre
);
918 errmsg_len
= fold_convert (size_type_node
, argse
.string_length
);
922 errmsg
= null_pointer_node
;
923 errmsg_len
= build_zero_cst (size_type_node
);
926 if (stat
!= null_pointer_node
&& TREE_TYPE (stat
) != integer_type_node
)
929 stat
= gfc_create_var (integer_type_node
, "stat");
932 if (lock_acquired
!= null_pointer_node
933 && TREE_TYPE (lock_acquired
) != integer_type_node
)
935 lock_acquired2
= lock_acquired
;
936 lock_acquired
= gfc_create_var (integer_type_node
, "acquired");
939 index
= fold_convert (size_type_node
, index
);
941 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_lock
, 7,
942 token
, index
, image_index
,
943 lock_acquired
!= null_pointer_node
944 ? gfc_build_addr_expr (NULL
, lock_acquired
)
946 stat
!= null_pointer_node
947 ? gfc_build_addr_expr (NULL
, stat
) : stat
,
950 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_unlock
, 6,
951 token
, index
, image_index
,
952 stat
!= null_pointer_node
953 ? gfc_build_addr_expr (NULL
, stat
) : stat
,
955 gfc_add_expr_to_block (&se
.pre
, tmp
);
957 /* It guarantees memory consistency within the same segment */
958 tmp
= gfc_build_string_const (strlen ("memory")+1, "memory"),
959 tmp
= build5_loc (input_location
, ASM_EXPR
, void_type_node
,
960 gfc_build_string_const (1, ""), NULL_TREE
, NULL_TREE
,
961 tree_cons (NULL_TREE
, tmp
, NULL_TREE
), NULL_TREE
);
962 ASM_VOLATILE_P (tmp
) = 1;
964 gfc_add_expr_to_block (&se
.pre
, tmp
);
966 if (stat2
!= NULL_TREE
)
967 gfc_add_modify (&se
.pre
, stat2
,
968 fold_convert (TREE_TYPE (stat2
), stat
));
970 if (lock_acquired2
!= NULL_TREE
)
971 gfc_add_modify (&se
.pre
, lock_acquired2
,
972 fold_convert (TREE_TYPE (lock_acquired2
),
975 return gfc_finish_block (&se
.pre
);
978 if (stat
!= NULL_TREE
)
979 gfc_add_modify (&se
.pre
, stat
, build_int_cst (TREE_TYPE (stat
), 0));
981 if (lock_acquired
!= NULL_TREE
)
982 gfc_add_modify (&se
.pre
, lock_acquired
,
983 fold_convert (TREE_TYPE (lock_acquired
),
986 return gfc_finish_block (&se
.pre
);
990 gfc_trans_event_post_wait (gfc_code
*code
, gfc_exec_op op
)
993 tree stat
= NULL_TREE
, stat2
= NULL_TREE
;
994 tree until_count
= NULL_TREE
;
998 gcc_assert (code
->expr2
->expr_type
== EXPR_VARIABLE
);
999 gfc_init_se (&argse
, NULL
);
1000 gfc_conv_expr_val (&argse
, code
->expr2
);
1003 else if (flag_coarray
== GFC_FCOARRAY_LIB
)
1004 stat
= null_pointer_node
;
1008 gfc_init_se (&argse
, NULL
);
1009 gfc_conv_expr_val (&argse
, code
->expr4
);
1010 until_count
= fold_convert (integer_type_node
, argse
.expr
);
1013 until_count
= integer_one_node
;
1015 if (flag_coarray
!= GFC_FCOARRAY_LIB
)
1017 gfc_start_block (&se
.pre
);
1018 gfc_init_se (&argse
, NULL
);
1019 gfc_conv_expr_val (&argse
, code
->expr1
);
1021 if (op
== EXEC_EVENT_POST
)
1022 gfc_add_modify (&se
.pre
, argse
.expr
,
1023 fold_build2_loc (input_location
, PLUS_EXPR
,
1024 TREE_TYPE (argse
.expr
), argse
.expr
,
1025 build_int_cst (TREE_TYPE (argse
.expr
), 1)));
1027 gfc_add_modify (&se
.pre
, argse
.expr
,
1028 fold_build2_loc (input_location
, MINUS_EXPR
,
1029 TREE_TYPE (argse
.expr
), argse
.expr
,
1030 fold_convert (TREE_TYPE (argse
.expr
),
1032 if (stat
!= NULL_TREE
)
1033 gfc_add_modify (&se
.pre
, stat
, build_int_cst (TREE_TYPE (stat
), 0));
1035 return gfc_finish_block (&se
.pre
);
1038 gfc_start_block (&se
.pre
);
1039 tree tmp
, token
, image_index
, errmsg
, errmsg_len
;
1040 tree index
= build_zero_cst (gfc_array_index_type
);
1041 tree caf_decl
= gfc_get_tree_for_caf_expr (code
->expr1
);
1043 if (code
->expr1
->symtree
->n
.sym
->ts
.type
!= BT_DERIVED
1044 || code
->expr1
->symtree
->n
.sym
->ts
.u
.derived
->from_intmod
1045 != INTMOD_ISO_FORTRAN_ENV
1046 || code
->expr1
->symtree
->n
.sym
->ts
.u
.derived
->intmod_sym_id
1047 != ISOFORTRAN_EVENT_TYPE
)
1049 gfc_error ("Sorry, the event component of derived type at %L is not "
1050 "yet supported", &code
->expr1
->where
);
1054 gfc_init_se (&argse
, NULL
);
1055 gfc_get_caf_token_offset (&argse
, &token
, NULL
, caf_decl
, NULL_TREE
,
1057 gfc_add_block_to_block (&se
.pre
, &argse
.pre
);
1059 if (gfc_is_coindexed (code
->expr1
))
1060 image_index
= gfc_caf_get_image_index (&se
.pre
, code
->expr1
, caf_decl
);
1062 image_index
= integer_zero_node
;
1064 /* For arrays, obtain the array index. */
1065 if (gfc_expr_attr (code
->expr1
).dimension
)
1067 tree desc
, tmp
, extent
, lbound
, ubound
;
1068 gfc_array_ref
*ar
, ar2
;
1071 /* TODO: Extend this, once DT components are supported. */
1072 ar
= &code
->expr1
->ref
->u
.ar
;
1074 memset (ar
, '\0', sizeof (*ar
));
1078 gfc_init_se (&argse
, NULL
);
1079 argse
.descriptor_only
= 1;
1080 gfc_conv_expr_descriptor (&argse
, code
->expr1
);
1081 gfc_add_block_to_block (&se
.pre
, &argse
.pre
);
1085 extent
= build_one_cst (gfc_array_index_type
);
1086 for (i
= 0; i
< ar
->dimen
; i
++)
1088 gfc_init_se (&argse
, NULL
);
1089 gfc_conv_expr_type (&argse
, ar
->start
[i
], gfc_array_index_type
);
1090 gfc_add_block_to_block (&argse
.pre
, &argse
.pre
);
1091 lbound
= gfc_conv_descriptor_lbound_get (desc
, gfc_rank_cst
[i
]);
1092 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
1093 TREE_TYPE (lbound
), argse
.expr
, lbound
);
1094 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
1095 TREE_TYPE (tmp
), extent
, tmp
);
1096 index
= fold_build2_loc (input_location
, PLUS_EXPR
,
1097 TREE_TYPE (tmp
), index
, tmp
);
1098 if (i
< ar
->dimen
- 1)
1100 ubound
= gfc_conv_descriptor_ubound_get (desc
, gfc_rank_cst
[i
]);
1101 tmp
= gfc_conv_array_extent_dim (lbound
, ubound
, NULL
);
1102 extent
= fold_build2_loc (input_location
, MULT_EXPR
,
1103 TREE_TYPE (tmp
), extent
, tmp
);
1111 gfc_init_se (&argse
, NULL
);
1112 argse
.want_pointer
= 1;
1113 gfc_conv_expr (&argse
, code
->expr3
);
1114 gfc_add_block_to_block (&se
.pre
, &argse
.pre
);
1115 errmsg
= argse
.expr
;
1116 errmsg_len
= fold_convert (size_type_node
, argse
.string_length
);
1120 errmsg
= null_pointer_node
;
1121 errmsg_len
= build_zero_cst (size_type_node
);
1124 if (stat
!= null_pointer_node
&& TREE_TYPE (stat
) != integer_type_node
)
1127 stat
= gfc_create_var (integer_type_node
, "stat");
1130 index
= fold_convert (size_type_node
, index
);
1131 if (op
== EXEC_EVENT_POST
)
1132 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_event_post
, 6,
1133 token
, index
, image_index
,
1134 stat
!= null_pointer_node
1135 ? gfc_build_addr_expr (NULL
, stat
) : stat
,
1136 errmsg
, errmsg_len
);
1138 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_event_wait
, 6,
1139 token
, index
, until_count
,
1140 stat
!= null_pointer_node
1141 ? gfc_build_addr_expr (NULL
, stat
) : stat
,
1142 errmsg
, errmsg_len
);
1143 gfc_add_expr_to_block (&se
.pre
, tmp
);
1145 /* It guarantees memory consistency within the same segment */
1146 tmp
= gfc_build_string_const (strlen ("memory")+1, "memory"),
1147 tmp
= build5_loc (input_location
, ASM_EXPR
, void_type_node
,
1148 gfc_build_string_const (1, ""), NULL_TREE
, NULL_TREE
,
1149 tree_cons (NULL_TREE
, tmp
, NULL_TREE
), NULL_TREE
);
1150 ASM_VOLATILE_P (tmp
) = 1;
1151 gfc_add_expr_to_block (&se
.pre
, tmp
);
1153 if (stat2
!= NULL_TREE
)
1154 gfc_add_modify (&se
.pre
, stat2
, fold_convert (TREE_TYPE (stat2
), stat
));
1156 return gfc_finish_block (&se
.pre
);
1160 gfc_trans_sync (gfc_code
*code
, gfc_exec_op type
)
1164 tree images
= NULL_TREE
, stat
= NULL_TREE
,
1165 errmsg
= NULL_TREE
, errmsglen
= NULL_TREE
;
1167 /* Short cut: For single images without bound checking or without STAT=,
1168 return early. (ERRMSG= is always untouched for -fcoarray=single.) */
1169 if (!code
->expr2
&& !(gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
1170 && flag_coarray
!= GFC_FCOARRAY_LIB
)
1173 gfc_init_se (&se
, NULL
);
1174 gfc_start_block (&se
.pre
);
1176 if (code
->expr1
&& code
->expr1
->rank
== 0)
1178 gfc_init_se (&argse
, NULL
);
1179 gfc_conv_expr_val (&argse
, code
->expr1
);
1180 images
= argse
.expr
;
1185 gcc_assert (code
->expr2
->expr_type
== EXPR_VARIABLE
);
1186 gfc_init_se (&argse
, NULL
);
1187 gfc_conv_expr_val (&argse
, code
->expr2
);
1191 stat
= null_pointer_node
;
1193 if (code
->expr3
&& flag_coarray
== GFC_FCOARRAY_LIB
)
1195 gcc_assert (code
->expr3
->expr_type
== EXPR_VARIABLE
);
1196 gfc_init_se (&argse
, NULL
);
1197 argse
.want_pointer
= 1;
1198 gfc_conv_expr (&argse
, code
->expr3
);
1199 gfc_conv_string_parameter (&argse
);
1200 errmsg
= gfc_build_addr_expr (NULL
, argse
.expr
);
1201 errmsglen
= fold_convert (size_type_node
, argse
.string_length
);
1203 else if (flag_coarray
== GFC_FCOARRAY_LIB
)
1205 errmsg
= null_pointer_node
;
1206 errmsglen
= build_int_cst (size_type_node
, 0);
1209 /* Check SYNC IMAGES(imageset) for valid image index.
1210 FIXME: Add a check for image-set arrays. */
1211 if (code
->expr1
&& (gfc_option
.rtcheck
& GFC_RTCHECK_BOUNDS
)
1212 && code
->expr1
->rank
== 0)
1215 if (flag_coarray
!= GFC_FCOARRAY_LIB
)
1216 cond
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
1217 images
, build_int_cst (TREE_TYPE (images
), 1));
1221 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_num_images
,
1222 2, integer_zero_node
,
1223 build_int_cst (integer_type_node
, -1));
1224 cond
= fold_build2_loc (input_location
, GT_EXPR
, logical_type_node
,
1226 cond2
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
1228 build_int_cst (TREE_TYPE (images
), 1));
1229 cond
= fold_build2_loc (input_location
, TRUTH_OR_EXPR
,
1230 logical_type_node
, cond
, cond2
);
1232 gfc_trans_runtime_check (true, false, cond
, &se
.pre
,
1233 &code
->expr1
->where
, "Invalid image number "
1234 "%d in SYNC IMAGES",
1235 fold_convert (integer_type_node
, images
));
1238 /* Per F2008, 8.5.1, a SYNC MEMORY is implied by calling the
1239 image control statements SYNC IMAGES and SYNC ALL. */
1240 if (flag_coarray
== GFC_FCOARRAY_LIB
)
1242 tmp
= gfc_build_string_const (strlen ("memory")+1, "memory"),
1243 tmp
= build5_loc (input_location
, ASM_EXPR
, void_type_node
,
1244 gfc_build_string_const (1, ""), NULL_TREE
, NULL_TREE
,
1245 tree_cons (NULL_TREE
, tmp
, NULL_TREE
), NULL_TREE
);
1246 ASM_VOLATILE_P (tmp
) = 1;
1247 gfc_add_expr_to_block (&se
.pre
, tmp
);
1250 if (flag_coarray
!= GFC_FCOARRAY_LIB
)
1252 /* Set STAT to zero. */
1254 gfc_add_modify (&se
.pre
, stat
, build_int_cst (TREE_TYPE (stat
), 0));
1256 else if (type
== EXEC_SYNC_ALL
|| type
== EXEC_SYNC_MEMORY
)
1258 /* SYNC ALL => stat == null_pointer_node
1259 SYNC ALL(stat=s) => stat has an integer type
1261 If "stat" has the wrong integer type, use a temp variable of
1262 the right type and later cast the result back into "stat". */
1263 if (stat
== null_pointer_node
|| TREE_TYPE (stat
) == integer_type_node
)
1265 if (TREE_TYPE (stat
) == integer_type_node
)
1266 stat
= gfc_build_addr_expr (NULL
, stat
);
1268 if(type
== EXEC_SYNC_MEMORY
)
1269 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_sync_memory
,
1270 3, stat
, errmsg
, errmsglen
);
1272 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_sync_all
,
1273 3, stat
, errmsg
, errmsglen
);
1275 gfc_add_expr_to_block (&se
.pre
, tmp
);
1279 tree tmp_stat
= gfc_create_var (integer_type_node
, "stat");
1281 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_sync_all
,
1282 3, gfc_build_addr_expr (NULL
, tmp_stat
),
1284 gfc_add_expr_to_block (&se
.pre
, tmp
);
1286 gfc_add_modify (&se
.pre
, stat
,
1287 fold_convert (TREE_TYPE (stat
), tmp_stat
));
1294 gcc_assert (type
== EXEC_SYNC_IMAGES
);
1298 len
= build_int_cst (integer_type_node
, -1);
1299 images
= null_pointer_node
;
1301 else if (code
->expr1
->rank
== 0)
1303 len
= build_int_cst (integer_type_node
, 1);
1304 images
= gfc_build_addr_expr (NULL_TREE
, images
);
1309 if (code
->expr1
->ts
.kind
!= gfc_c_int_kind
)
1310 gfc_fatal_error ("Sorry, only support for integer kind %d "
1311 "implemented for image-set at %L",
1312 gfc_c_int_kind
, &code
->expr1
->where
);
1314 gfc_conv_array_parameter (&se
, code
->expr1
, true, NULL
, NULL
, &len
);
1317 tmp
= gfc_typenode_for_spec (&code
->expr1
->ts
);
1318 if (GFC_ARRAY_TYPE_P (tmp
) || GFC_DESCRIPTOR_TYPE_P (tmp
))
1319 tmp
= gfc_get_element_type (tmp
);
1321 len
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
,
1322 TREE_TYPE (len
), len
,
1323 fold_convert (TREE_TYPE (len
),
1324 TYPE_SIZE_UNIT (tmp
)));
1325 len
= fold_convert (integer_type_node
, len
);
1328 /* SYNC IMAGES(imgs) => stat == null_pointer_node
1329 SYNC IMAGES(imgs,stat=s) => stat has an integer type
1331 If "stat" has the wrong integer type, use a temp variable of
1332 the right type and later cast the result back into "stat". */
1333 if (stat
== null_pointer_node
|| TREE_TYPE (stat
) == integer_type_node
)
1335 if (TREE_TYPE (stat
) == integer_type_node
)
1336 stat
= gfc_build_addr_expr (NULL
, stat
);
1338 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_sync_images
,
1339 5, fold_convert (integer_type_node
, len
),
1340 images
, stat
, errmsg
, errmsglen
);
1341 gfc_add_expr_to_block (&se
.pre
, tmp
);
1345 tree tmp_stat
= gfc_create_var (integer_type_node
, "stat");
1347 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_sync_images
,
1348 5, fold_convert (integer_type_node
, len
),
1349 images
, gfc_build_addr_expr (NULL
, tmp_stat
),
1351 gfc_add_expr_to_block (&se
.pre
, tmp
);
1353 gfc_add_modify (&se
.pre
, stat
,
1354 fold_convert (TREE_TYPE (stat
), tmp_stat
));
1358 return gfc_finish_block (&se
.pre
);
1362 /* Generate GENERIC for the IF construct. This function also deals with
1363 the simple IF statement, because the front end translates the IF
1364 statement into an IF construct.
1396 where COND_S is the simplified version of the predicate. PRE_COND_S
1397 are the pre side-effects produced by the translation of the
1399 We need to build the chain recursively otherwise we run into
1400 problems with folding incomplete statements. */
1403 gfc_trans_if_1 (gfc_code
* code
)
1406 tree stmt
, elsestmt
;
1410 /* Check for an unconditional ELSE clause. */
1412 return gfc_trans_code (code
->next
);
1414 /* Initialize a statement builder for each block. Puts in NULL_TREEs. */
1415 gfc_init_se (&if_se
, NULL
);
1416 gfc_start_block (&if_se
.pre
);
1418 /* Calculate the IF condition expression. */
1419 if (code
->expr1
->where
.lb
)
1421 gfc_save_backend_locus (&saved_loc
);
1422 gfc_set_backend_locus (&code
->expr1
->where
);
1425 gfc_conv_expr_val (&if_se
, code
->expr1
);
1427 if (code
->expr1
->where
.lb
)
1428 gfc_restore_backend_locus (&saved_loc
);
1430 /* Translate the THEN clause. */
1431 stmt
= gfc_trans_code (code
->next
);
1433 /* Translate the ELSE clause. */
1435 elsestmt
= gfc_trans_if_1 (code
->block
);
1437 elsestmt
= build_empty_stmt (input_location
);
1439 /* Build the condition expression and add it to the condition block. */
1440 loc
= code
->expr1
->where
.lb
? code
->expr1
->where
.lb
->location
: input_location
;
1441 stmt
= fold_build3_loc (loc
, COND_EXPR
, void_type_node
, if_se
.expr
, stmt
,
1444 gfc_add_expr_to_block (&if_se
.pre
, stmt
);
1446 /* Finish off this statement. */
1447 return gfc_finish_block (&if_se
.pre
);
1451 gfc_trans_if (gfc_code
* code
)
1456 /* Create exit label so it is available for trans'ing the body code. */
1457 exit_label
= gfc_build_label_decl (NULL_TREE
);
1458 code
->exit_label
= exit_label
;
1460 /* Translate the actual code in code->block. */
1461 gfc_init_block (&body
);
1462 gfc_add_expr_to_block (&body
, gfc_trans_if_1 (code
->block
));
1464 /* Add exit label. */
1465 gfc_add_expr_to_block (&body
, build1_v (LABEL_EXPR
, exit_label
));
1467 return gfc_finish_block (&body
);
1471 /* Translate an arithmetic IF expression.
1473 IF (cond) label1, label2, label3 translates to
1485 An optimized version can be generated in case of equal labels.
1486 E.g., if label1 is equal to label2, we can translate it to
1495 gfc_trans_arithmetic_if (gfc_code
* code
)
1503 /* Start a new block. */
1504 gfc_init_se (&se
, NULL
);
1505 gfc_start_block (&se
.pre
);
1507 /* Pre-evaluate COND. */
1508 gfc_conv_expr_val (&se
, code
->expr1
);
1509 se
.expr
= gfc_evaluate_now (se
.expr
, &se
.pre
);
1511 /* Build something to compare with. */
1512 zero
= gfc_build_const (TREE_TYPE (se
.expr
), integer_zero_node
);
1514 if (code
->label1
->value
!= code
->label2
->value
)
1516 /* If (cond < 0) take branch1 else take branch2.
1517 First build jumps to the COND .LT. 0 and the COND .EQ. 0 cases. */
1518 branch1
= build1_v (GOTO_EXPR
, gfc_get_label_decl (code
->label1
));
1519 branch2
= build1_v (GOTO_EXPR
, gfc_get_label_decl (code
->label2
));
1521 if (code
->label1
->value
!= code
->label3
->value
)
1522 tmp
= fold_build2_loc (input_location
, LT_EXPR
, logical_type_node
,
1525 tmp
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
1528 branch1
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
1529 tmp
, branch1
, branch2
);
1532 branch1
= build1_v (GOTO_EXPR
, gfc_get_label_decl (code
->label1
));
1534 if (code
->label1
->value
!= code
->label3
->value
1535 && code
->label2
->value
!= code
->label3
->value
)
1537 /* if (cond <= 0) take branch1 else take branch2. */
1538 branch2
= build1_v (GOTO_EXPR
, gfc_get_label_decl (code
->label3
));
1539 tmp
= fold_build2_loc (input_location
, LE_EXPR
, logical_type_node
,
1541 branch1
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
1542 tmp
, branch1
, branch2
);
1545 /* Append the COND_EXPR to the evaluation of COND, and return. */
1546 gfc_add_expr_to_block (&se
.pre
, branch1
);
1547 return gfc_finish_block (&se
.pre
);
1551 /* Translate a CRITICAL block. */
1553 gfc_trans_critical (gfc_code
*code
)
1556 tree tmp
, token
= NULL_TREE
;
1558 gfc_start_block (&block
);
1560 if (flag_coarray
== GFC_FCOARRAY_LIB
)
1562 token
= gfc_get_symbol_decl (code
->resolved_sym
);
1563 token
= GFC_TYPE_ARRAY_CAF_TOKEN (TREE_TYPE (token
));
1564 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_lock
, 7,
1565 token
, integer_zero_node
, integer_one_node
,
1566 null_pointer_node
, null_pointer_node
,
1567 null_pointer_node
, integer_zero_node
);
1568 gfc_add_expr_to_block (&block
, tmp
);
1570 /* It guarantees memory consistency within the same segment */
1571 tmp
= gfc_build_string_const (strlen ("memory")+1, "memory"),
1572 tmp
= build5_loc (input_location
, ASM_EXPR
, void_type_node
,
1573 gfc_build_string_const (1, ""),
1574 NULL_TREE
, NULL_TREE
,
1575 tree_cons (NULL_TREE
, tmp
, NULL_TREE
),
1577 ASM_VOLATILE_P (tmp
) = 1;
1579 gfc_add_expr_to_block (&block
, tmp
);
1582 tmp
= gfc_trans_code (code
->block
->next
);
1583 gfc_add_expr_to_block (&block
, tmp
);
1585 if (flag_coarray
== GFC_FCOARRAY_LIB
)
1587 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_unlock
, 6,
1588 token
, integer_zero_node
, integer_one_node
,
1589 null_pointer_node
, null_pointer_node
,
1591 gfc_add_expr_to_block (&block
, tmp
);
1593 /* It guarantees memory consistency within the same segment */
1594 tmp
= gfc_build_string_const (strlen ("memory")+1, "memory"),
1595 tmp
= build5_loc (input_location
, ASM_EXPR
, void_type_node
,
1596 gfc_build_string_const (1, ""),
1597 NULL_TREE
, NULL_TREE
,
1598 tree_cons (NULL_TREE
, tmp
, NULL_TREE
),
1600 ASM_VOLATILE_P (tmp
) = 1;
1602 gfc_add_expr_to_block (&block
, tmp
);
1605 return gfc_finish_block (&block
);
1609 /* Return true, when the class has a _len component. */
1612 class_has_len_component (gfc_symbol
*sym
)
1614 gfc_component
*comp
= sym
->ts
.u
.derived
->components
;
1617 if (strcmp (comp
->name
, "_len") == 0)
1625 /* Do proper initialization for ASSOCIATE names. */
1628 trans_associate_var (gfc_symbol
*sym
, gfc_wrapped_block
*block
)
1639 bool need_len_assign
;
1640 bool whole_array
= true;
1642 symbol_attribute attr
;
1644 gcc_assert (sym
->assoc
);
1645 e
= sym
->assoc
->target
;
1647 class_target
= (e
->expr_type
== EXPR_VARIABLE
)
1648 && (gfc_is_class_scalar_expr (e
)
1649 || gfc_is_class_array_ref (e
, NULL
));
1651 unlimited
= UNLIMITED_POLY (e
);
1653 for (ref
= e
->ref
; ref
; ref
= ref
->next
)
1654 if (ref
->type
== REF_ARRAY
1655 && ref
->u
.ar
.type
== AR_FULL
1658 whole_array
= false;
1662 /* Assignments to the string length need to be generated, when
1663 ( sym is a char array or
1664 sym has a _len component)
1665 and the associated expression is unlimited polymorphic, which is
1666 not (yet) correctly in 'unlimited', because for an already associated
1667 BT_DERIVED the u-poly flag is not set, i.e.,
1668 __tmp_CHARACTER_0_1 => w => arg
1669 ^ generated temp ^ from code, the w does not have the u-poly
1670 flag set, where UNLIMITED_POLY(e) expects it. */
1671 need_len_assign
= ((unlimited
|| (e
->ts
.type
== BT_DERIVED
1672 && e
->ts
.u
.derived
->attr
.unlimited_polymorphic
))
1673 && (sym
->ts
.type
== BT_CHARACTER
1674 || ((sym
->ts
.type
== BT_CLASS
|| sym
->ts
.type
== BT_DERIVED
)
1675 && class_has_len_component (sym
))));
1676 /* Do a `pointer assignment' with updated descriptor (or assign descriptor
1677 to array temporary) for arrays with either unknown shape or if associating
1679 if (sym
->attr
.dimension
&& !class_target
1680 && (sym
->as
->type
== AS_DEFERRED
|| sym
->assoc
->variable
))
1684 bool cst_array_ctor
;
1686 desc
= sym
->backend_decl
;
1687 cst_array_ctor
= e
->expr_type
== EXPR_ARRAY
1688 && gfc_constant_array_constructor_p (e
->value
.constructor
)
1689 && e
->ts
.type
!= BT_CHARACTER
;
1691 /* If association is to an expression, evaluate it and create temporary.
1692 Otherwise, get descriptor of target for pointer assignment. */
1693 gfc_init_se (&se
, NULL
);
1694 if (sym
->assoc
->variable
|| cst_array_ctor
)
1696 se
.direct_byref
= 1;
1701 gfc_conv_expr_descriptor (&se
, e
);
1703 if (sym
->ts
.type
== BT_CHARACTER
1705 && !sym
->attr
.select_type_temporary
1706 && VAR_P (sym
->ts
.u
.cl
->backend_decl
)
1707 && se
.string_length
!= sym
->ts
.u
.cl
->backend_decl
)
1709 gfc_add_modify (&se
.pre
, sym
->ts
.u
.cl
->backend_decl
,
1710 fold_convert (TREE_TYPE (sym
->ts
.u
.cl
->backend_decl
),
1714 /* If we didn't already do the pointer assignment, set associate-name
1715 descriptor to the one generated for the temporary. */
1716 if ((!sym
->assoc
->variable
&& !cst_array_ctor
)
1722 gfc_add_modify (&se
.pre
, desc
, se
.expr
);
1724 /* The generated descriptor has lower bound zero (as array
1725 temporary), shift bounds so we get lower bounds of 1. */
1726 for (dim
= 0; dim
< e
->rank
; ++dim
)
1727 gfc_conv_shift_descriptor_lbound (&se
.pre
, desc
,
1728 dim
, gfc_index_one_node
);
1731 /* If this is a subreference array pointer associate name use the
1732 associate variable element size for the value of 'span'. */
1733 if (sym
->attr
.subref_array_pointer
)
1735 gcc_assert (e
->expr_type
== EXPR_VARIABLE
);
1736 tmp
= gfc_get_array_span (se
.expr
, e
);
1738 gfc_conv_descriptor_span_set (&se
.pre
, desc
, tmp
);
1741 if (e
->expr_type
== EXPR_FUNCTION
1742 && sym
->ts
.type
== BT_DERIVED
1743 && sym
->ts
.u
.derived
1744 && sym
->ts
.u
.derived
->attr
.pdt_type
)
1746 tmp
= gfc_deallocate_pdt_comp (sym
->ts
.u
.derived
, se
.expr
,
1748 gfc_add_expr_to_block (&se
.post
, tmp
);
1751 /* Done, register stuff as init / cleanup code. */
1752 gfc_add_init_cleanup (block
, gfc_finish_block (&se
.pre
),
1753 gfc_finish_block (&se
.post
));
1756 /* Temporaries, arising from TYPE IS, just need the descriptor of class
1757 arrays to be assigned directly. */
1758 else if (class_target
&& sym
->attr
.dimension
1759 && (sym
->ts
.type
== BT_DERIVED
|| unlimited
))
1763 gfc_init_se (&se
, NULL
);
1764 se
.descriptor_only
= 1;
1765 /* In a select type the (temporary) associate variable shall point to
1766 a standard fortran array (lower bound == 1), but conv_expr ()
1767 just maps to the input array in the class object, whose lbound may
1768 be arbitrary. conv_expr_descriptor solves this by inserting a
1769 temporary array descriptor. */
1770 gfc_conv_expr_descriptor (&se
, e
);
1772 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se
.expr
))
1773 || GFC_ARRAY_TYPE_P (TREE_TYPE (se
.expr
)));
1774 gcc_assert (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (sym
->backend_decl
)));
1776 if (GFC_ARRAY_TYPE_P (TREE_TYPE (se
.expr
)))
1778 if (INDIRECT_REF_P (se
.expr
))
1779 tmp
= TREE_OPERAND (se
.expr
, 0);
1783 gfc_add_modify (&se
.pre
, sym
->backend_decl
,
1784 gfc_class_data_get (GFC_DECL_SAVED_DESCRIPTOR (tmp
)));
1787 gfc_add_modify (&se
.pre
, sym
->backend_decl
, se
.expr
);
1791 /* Recover the dtype, which has been overwritten by the
1792 assignment from an unlimited polymorphic object. */
1793 tmp
= gfc_conv_descriptor_dtype (sym
->backend_decl
);
1794 gfc_add_modify (&se
.pre
, tmp
,
1795 gfc_get_dtype (TREE_TYPE (sym
->backend_decl
)));
1798 gfc_add_init_cleanup (block
, gfc_finish_block (&se
.pre
),
1799 gfc_finish_block (&se
.post
));
1802 /* Do a scalar pointer assignment; this is for scalar variable targets. */
1803 else if (gfc_is_associate_pointer (sym
))
1807 gcc_assert (!sym
->attr
.dimension
);
1809 gfc_init_se (&se
, NULL
);
1811 /* Class associate-names come this way because they are
1812 unconditionally associate pointers and the symbol is scalar. */
1813 if (sym
->ts
.type
== BT_CLASS
&& CLASS_DATA (sym
)->attr
.dimension
)
1816 /* For a class array we need a descriptor for the selector. */
1817 gfc_conv_expr_descriptor (&se
, e
);
1818 /* Needed to get/set the _len component below. */
1819 target_expr
= se
.expr
;
1821 /* Obtain a temporary class container for the result. */
1822 gfc_conv_class_to_class (&se
, e
, sym
->ts
, false, true, false, false);
1823 se
.expr
= build_fold_indirect_ref_loc (input_location
, se
.expr
);
1825 /* Set the offset. */
1826 desc
= gfc_class_data_get (se
.expr
);
1827 offset
= gfc_index_zero_node
;
1828 for (n
= 0; n
< e
->rank
; n
++)
1830 dim
= gfc_rank_cst
[n
];
1831 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
1832 gfc_array_index_type
,
1833 gfc_conv_descriptor_stride_get (desc
, dim
),
1834 gfc_conv_descriptor_lbound_get (desc
, dim
));
1835 offset
= fold_build2_loc (input_location
, MINUS_EXPR
,
1836 gfc_array_index_type
,
1839 if (need_len_assign
)
1842 && DECL_LANG_SPECIFIC (e
->symtree
->n
.sym
->backend_decl
)
1843 && GFC_DECL_SAVED_DESCRIPTOR (e
->symtree
->n
.sym
->backend_decl
))
1844 /* Use the original class descriptor stored in the saved
1845 descriptor to get the target_expr. */
1847 GFC_DECL_SAVED_DESCRIPTOR (e
->symtree
->n
.sym
->backend_decl
);
1849 /* Strip the _data component from the target_expr. */
1850 target_expr
= TREE_OPERAND (target_expr
, 0);
1851 /* Add a reference to the _len comp to the target expr. */
1852 tmp
= gfc_class_len_get (target_expr
);
1853 /* Get the component-ref for the temp structure's _len comp. */
1854 charlen
= gfc_class_len_get (se
.expr
);
1855 /* Add the assign to the beginning of the block... */
1856 gfc_add_modify (&se
.pre
, charlen
,
1857 fold_convert (TREE_TYPE (charlen
), tmp
));
1858 /* and the oposite way at the end of the block, to hand changes
1859 on the string length back. */
1860 gfc_add_modify (&se
.post
, tmp
,
1861 fold_convert (TREE_TYPE (tmp
), charlen
));
1862 /* Length assignment done, prevent adding it again below. */
1863 need_len_assign
= false;
1865 gfc_conv_descriptor_offset_set (&se
.pre
, desc
, offset
);
1867 else if (sym
->ts
.type
== BT_CLASS
&& e
->ts
.type
== BT_CLASS
1868 && CLASS_DATA (e
)->attr
.dimension
)
1870 /* This is bound to be a class array element. */
1871 gfc_conv_expr_reference (&se
, e
);
1872 /* Get the _vptr component of the class object. */
1873 tmp
= gfc_get_vptr_from_expr (se
.expr
);
1874 /* Obtain a temporary class container for the result. */
1875 gfc_conv_derived_to_class (&se
, e
, sym
->ts
, tmp
, false, false);
1876 se
.expr
= build_fold_indirect_ref_loc (input_location
, se
.expr
);
1880 /* For BT_CLASS and BT_DERIVED, this boils down to a pointer assign,
1881 which has the string length included. For CHARACTERS it is still
1882 needed and will be done at the end of this routine. */
1883 gfc_conv_expr (&se
, e
);
1884 need_len_assign
= need_len_assign
&& sym
->ts
.type
== BT_CHARACTER
;
1887 if (sym
->ts
.type
== BT_CHARACTER
1888 && !sym
->attr
.select_type_temporary
1889 && VAR_P (sym
->ts
.u
.cl
->backend_decl
)
1890 && se
.string_length
!= sym
->ts
.u
.cl
->backend_decl
)
1892 gfc_add_modify (&se
.pre
, sym
->ts
.u
.cl
->backend_decl
,
1893 fold_convert (TREE_TYPE (sym
->ts
.u
.cl
->backend_decl
),
1895 if (e
->expr_type
== EXPR_FUNCTION
)
1897 tmp
= gfc_call_free (sym
->backend_decl
);
1898 gfc_add_expr_to_block (&se
.post
, tmp
);
1902 attr
= gfc_expr_attr (e
);
1903 if (sym
->ts
.type
== BT_CHARACTER
&& e
->ts
.type
== BT_CHARACTER
1904 && (attr
.allocatable
|| attr
.pointer
|| attr
.dummy
)
1905 && POINTER_TYPE_P (TREE_TYPE (se
.expr
)))
1907 /* These are pointer types already. */
1908 tmp
= fold_convert (TREE_TYPE (sym
->backend_decl
), se
.expr
);
1912 tmp
= TREE_TYPE (sym
->backend_decl
);
1913 tmp
= gfc_build_addr_expr (tmp
, se
.expr
);
1916 gfc_add_modify (&se
.pre
, sym
->backend_decl
, tmp
);
1918 gfc_add_init_cleanup (block
, gfc_finish_block( &se
.pre
),
1919 gfc_finish_block (&se
.post
));
1922 /* Do a simple assignment. This is for scalar expressions, where we
1923 can simply use expression assignment. */
1930 gfc_init_se (&se
, NULL
);
1932 /* resolve.c converts some associate names to allocatable so that
1933 allocation can take place automatically in gfc_trans_assignment.
1934 The frontend prevents them from being either allocated,
1935 deallocated or reallocated. */
1936 if (sym
->attr
.allocatable
)
1938 tmp
= sym
->backend_decl
;
1939 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp
)))
1940 tmp
= gfc_conv_descriptor_data_get (tmp
);
1941 gfc_add_modify (&se
.pre
, tmp
, fold_convert (TREE_TYPE (tmp
),
1942 null_pointer_node
));
1945 lhs
= gfc_lval_expr_from_sym (sym
);
1946 res
= gfc_trans_assignment (lhs
, e
, false, true);
1947 gfc_add_expr_to_block (&se
.pre
, res
);
1949 tmp
= sym
->backend_decl
;
1950 if (e
->expr_type
== EXPR_FUNCTION
1951 && sym
->ts
.type
== BT_DERIVED
1952 && sym
->ts
.u
.derived
1953 && sym
->ts
.u
.derived
->attr
.pdt_type
)
1955 tmp
= gfc_deallocate_pdt_comp (sym
->ts
.u
.derived
, tmp
,
1958 else if (e
->expr_type
== EXPR_FUNCTION
1959 && sym
->ts
.type
== BT_CLASS
1960 && CLASS_DATA (sym
)->ts
.u
.derived
1961 && CLASS_DATA (sym
)->ts
.u
.derived
->attr
.pdt_type
)
1963 tmp
= gfc_class_data_get (tmp
);
1964 tmp
= gfc_deallocate_pdt_comp (CLASS_DATA (sym
)->ts
.u
.derived
,
1967 else if (sym
->attr
.allocatable
)
1969 tmp
= sym
->backend_decl
;
1971 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp
)))
1972 tmp
= gfc_conv_descriptor_data_get (tmp
);
1974 /* A simple call to free suffices here. */
1975 tmp
= gfc_call_free (tmp
);
1977 /* Make sure that reallocation on assignment cannot occur. */
1978 sym
->attr
.allocatable
= 0;
1983 res
= gfc_finish_block (&se
.pre
);
1984 gfc_add_init_cleanup (block
, res
, tmp
);
1985 gfc_free_expr (lhs
);
1988 /* Set the stringlength, when needed. */
1989 if (need_len_assign
)
1992 gfc_init_se (&se
, NULL
);
1993 if (e
->symtree
->n
.sym
->ts
.type
== BT_CHARACTER
)
1995 /* Deferred strings are dealt with in the preceeding. */
1996 gcc_assert (!e
->symtree
->n
.sym
->ts
.deferred
);
1997 tmp
= e
->symtree
->n
.sym
->ts
.u
.cl
->backend_decl
;
1999 else if (e
->symtree
->n
.sym
->attr
.function
2000 && e
->symtree
->n
.sym
== e
->symtree
->n
.sym
->result
)
2002 tmp
= gfc_get_fake_result_decl (e
->symtree
->n
.sym
, 0);
2003 tmp
= gfc_class_len_get (tmp
);
2006 tmp
= gfc_class_len_get (gfc_get_symbol_decl (e
->symtree
->n
.sym
));
2007 gfc_get_symbol_decl (sym
);
2008 charlen
= sym
->ts
.type
== BT_CHARACTER
? sym
->ts
.u
.cl
->backend_decl
2009 : gfc_class_len_get (sym
->backend_decl
);
2010 /* Prevent adding a noop len= len. */
2013 gfc_add_modify (&se
.pre
, charlen
,
2014 fold_convert (TREE_TYPE (charlen
), tmp
));
2015 gfc_add_init_cleanup (block
, gfc_finish_block (&se
.pre
),
2016 gfc_finish_block (&se
.post
));
2022 /* Translate a BLOCK construct. This is basically what we would do for a
2026 gfc_trans_block_construct (gfc_code
* code
)
2030 gfc_wrapped_block block
;
2033 gfc_association_list
*ass
;
2035 ns
= code
->ext
.block
.ns
;
2037 sym
= ns
->proc_name
;
2040 /* Process local variables. */
2041 gcc_assert (!sym
->tlink
);
2043 gfc_process_block_locals (ns
);
2045 /* Generate code including exit-label. */
2046 gfc_init_block (&body
);
2047 exit_label
= gfc_build_label_decl (NULL_TREE
);
2048 code
->exit_label
= exit_label
;
2050 finish_oacc_declare (ns
, sym
, true);
2052 gfc_add_expr_to_block (&body
, gfc_trans_code (ns
->code
));
2053 gfc_add_expr_to_block (&body
, build1_v (LABEL_EXPR
, exit_label
));
2055 /* Finish everything. */
2056 gfc_start_wrapped_block (&block
, gfc_finish_block (&body
));
2057 gfc_trans_deferred_vars (sym
, &block
);
2058 for (ass
= code
->ext
.block
.assoc
; ass
; ass
= ass
->next
)
2059 trans_associate_var (ass
->st
->n
.sym
, &block
);
2061 return gfc_finish_wrapped_block (&block
);
2064 /* Translate the simple DO construct in a C-style manner.
2065 This is where the loop variable has integer type and step +-1.
2066 Following code will generate infinite loop in case where TO is INT_MAX
2067 (for +1 step) or INT_MIN (for -1 step)
2069 We translate a do loop from:
2071 DO dovar = from, to, step
2077 [Evaluate loop bounds and step]
2089 This helps the optimizers by avoiding the extra pre-header condition and
2090 we save a register as we just compare the updated IV (not a value in
2094 gfc_trans_simple_do (gfc_code
* code
, stmtblock_t
*pblock
, tree dovar
,
2095 tree from
, tree to
, tree step
, tree exit_cond
)
2101 tree saved_dovar
= NULL
;
2105 type
= TREE_TYPE (dovar
);
2106 bool is_step_positive
= tree_int_cst_sgn (step
) > 0;
2108 loc
= code
->ext
.iterator
->start
->where
.lb
->location
;
2110 /* Initialize the DO variable: dovar = from. */
2111 gfc_add_modify_loc (loc
, pblock
, dovar
,
2112 fold_convert (TREE_TYPE (dovar
), from
));
2114 /* Save value for do-tinkering checking. */
2115 if (gfc_option
.rtcheck
& GFC_RTCHECK_DO
)
2117 saved_dovar
= gfc_create_var (type
, ".saved_dovar");
2118 gfc_add_modify_loc (loc
, pblock
, saved_dovar
, dovar
);
2121 /* Cycle and exit statements are implemented with gotos. */
2122 cycle_label
= gfc_build_label_decl (NULL_TREE
);
2123 exit_label
= gfc_build_label_decl (NULL_TREE
);
2125 /* Put the labels where they can be found later. See gfc_trans_do(). */
2126 code
->cycle_label
= cycle_label
;
2127 code
->exit_label
= exit_label
;
2130 gfc_start_block (&body
);
2132 /* Exit the loop if there is an I/O result condition or error. */
2135 tmp
= build1_v (GOTO_EXPR
, exit_label
);
2136 tmp
= fold_build3_loc (loc
, COND_EXPR
, void_type_node
,
2138 build_empty_stmt (loc
));
2139 gfc_add_expr_to_block (&body
, tmp
);
2142 /* Evaluate the loop condition. */
2143 if (is_step_positive
)
2144 cond
= fold_build2_loc (loc
, GT_EXPR
, logical_type_node
, dovar
,
2145 fold_convert (type
, to
));
2147 cond
= fold_build2_loc (loc
, LT_EXPR
, logical_type_node
, dovar
,
2148 fold_convert (type
, to
));
2150 cond
= gfc_evaluate_now_loc (loc
, cond
, &body
);
2151 if (code
->ext
.iterator
->unroll
&& cond
!= error_mark_node
)
2153 = build3 (ANNOTATE_EXPR
, TREE_TYPE (cond
), cond
,
2154 build_int_cst (integer_type_node
, annot_expr_unroll_kind
),
2155 build_int_cst (integer_type_node
, code
->ext
.iterator
->unroll
));
2157 /* The loop exit. */
2158 tmp
= fold_build1_loc (loc
, GOTO_EXPR
, void_type_node
, exit_label
);
2159 TREE_USED (exit_label
) = 1;
2160 tmp
= fold_build3_loc (loc
, COND_EXPR
, void_type_node
,
2161 cond
, tmp
, build_empty_stmt (loc
));
2162 gfc_add_expr_to_block (&body
, tmp
);
2164 /* Check whether the induction variable is equal to INT_MAX
2165 (respectively to INT_MIN). */
2166 if (gfc_option
.rtcheck
& GFC_RTCHECK_DO
)
2168 tree boundary
= is_step_positive
? TYPE_MAX_VALUE (type
)
2169 : TYPE_MIN_VALUE (type
);
2171 tmp
= fold_build2_loc (loc
, EQ_EXPR
, logical_type_node
,
2173 gfc_trans_runtime_check (true, false, tmp
, &body
, &code
->loc
,
2174 "Loop iterates infinitely");
2177 /* Main loop body. */
2178 tmp
= gfc_trans_code_cond (code
->block
->next
, exit_cond
);
2179 gfc_add_expr_to_block (&body
, tmp
);
2181 /* Label for cycle statements (if needed). */
2182 if (TREE_USED (cycle_label
))
2184 tmp
= build1_v (LABEL_EXPR
, cycle_label
);
2185 gfc_add_expr_to_block (&body
, tmp
);
2188 /* Check whether someone has modified the loop variable. */
2189 if (gfc_option
.rtcheck
& GFC_RTCHECK_DO
)
2191 tmp
= fold_build2_loc (loc
, NE_EXPR
, logical_type_node
,
2192 dovar
, saved_dovar
);
2193 gfc_trans_runtime_check (true, false, tmp
, &body
, &code
->loc
,
2194 "Loop variable has been modified");
2197 /* Increment the loop variable. */
2198 tmp
= fold_build2_loc (loc
, PLUS_EXPR
, type
, dovar
, step
);
2199 gfc_add_modify_loc (loc
, &body
, dovar
, tmp
);
2201 if (gfc_option
.rtcheck
& GFC_RTCHECK_DO
)
2202 gfc_add_modify_loc (loc
, &body
, saved_dovar
, dovar
);
2204 /* Finish the loop body. */
2205 tmp
= gfc_finish_block (&body
);
2206 tmp
= fold_build1_loc (loc
, LOOP_EXPR
, void_type_node
, tmp
);
2208 gfc_add_expr_to_block (pblock
, tmp
);
2210 /* Add the exit label. */
2211 tmp
= build1_v (LABEL_EXPR
, exit_label
);
2212 gfc_add_expr_to_block (pblock
, tmp
);
2214 return gfc_finish_block (pblock
);
2217 /* Translate the DO construct. This obviously is one of the most
2218 important ones to get right with any compiler, but especially
2221 We special case some loop forms as described in gfc_trans_simple_do.
2222 For other cases we implement them with a separate loop count,
2223 as described in the standard.
2225 We translate a do loop from:
2227 DO dovar = from, to, step
2233 [evaluate loop bounds and step]
2234 empty = (step > 0 ? to < from : to > from);
2235 countm1 = (to - from) / step;
2237 if (empty) goto exit_label;
2245 if (countm1t == 0) goto exit_label;
2249 countm1 is an unsigned integer. It is equal to the loop count minus one,
2250 because the loop count itself can overflow. */
2253 gfc_trans_do (gfc_code
* code
, tree exit_cond
)
2257 tree saved_dovar
= NULL
;
2272 gfc_start_block (&block
);
2274 loc
= code
->ext
.iterator
->start
->where
.lb
->location
;
2276 /* Evaluate all the expressions in the iterator. */
2277 gfc_init_se (&se
, NULL
);
2278 gfc_conv_expr_lhs (&se
, code
->ext
.iterator
->var
);
2279 gfc_add_block_to_block (&block
, &se
.pre
);
2281 type
= TREE_TYPE (dovar
);
2283 gfc_init_se (&se
, NULL
);
2284 gfc_conv_expr_val (&se
, code
->ext
.iterator
->start
);
2285 gfc_add_block_to_block (&block
, &se
.pre
);
2286 from
= gfc_evaluate_now (se
.expr
, &block
);
2288 gfc_init_se (&se
, NULL
);
2289 gfc_conv_expr_val (&se
, code
->ext
.iterator
->end
);
2290 gfc_add_block_to_block (&block
, &se
.pre
);
2291 to
= gfc_evaluate_now (se
.expr
, &block
);
2293 gfc_init_se (&se
, NULL
);
2294 gfc_conv_expr_val (&se
, code
->ext
.iterator
->step
);
2295 gfc_add_block_to_block (&block
, &se
.pre
);
2296 step
= gfc_evaluate_now (se
.expr
, &block
);
2298 if (gfc_option
.rtcheck
& GFC_RTCHECK_DO
)
2300 tmp
= fold_build2_loc (input_location
, EQ_EXPR
, logical_type_node
, step
,
2301 build_zero_cst (type
));
2302 gfc_trans_runtime_check (true, false, tmp
, &block
, &code
->loc
,
2303 "DO step value is zero");
2306 /* Special case simple loops. */
2307 if (TREE_CODE (type
) == INTEGER_TYPE
2308 && (integer_onep (step
)
2309 || tree_int_cst_equal (step
, integer_minus_one_node
)))
2310 return gfc_trans_simple_do (code
, &block
, dovar
, from
, to
, step
,
2313 if (TREE_CODE (type
) == INTEGER_TYPE
)
2314 utype
= unsigned_type_for (type
);
2316 utype
= unsigned_type_for (gfc_array_index_type
);
2317 countm1
= gfc_create_var (utype
, "countm1");
2319 /* Cycle and exit statements are implemented with gotos. */
2320 cycle_label
= gfc_build_label_decl (NULL_TREE
);
2321 exit_label
= gfc_build_label_decl (NULL_TREE
);
2322 TREE_USED (exit_label
) = 1;
2324 /* Put these labels where they can be found later. */
2325 code
->cycle_label
= cycle_label
;
2326 code
->exit_label
= exit_label
;
2328 /* Initialize the DO variable: dovar = from. */
2329 gfc_add_modify (&block
, dovar
, from
);
2331 /* Save value for do-tinkering checking. */
2332 if (gfc_option
.rtcheck
& GFC_RTCHECK_DO
)
2334 saved_dovar
= gfc_create_var (type
, ".saved_dovar");
2335 gfc_add_modify_loc (loc
, &block
, saved_dovar
, dovar
);
2338 /* Initialize loop count and jump to exit label if the loop is empty.
2339 This code is executed before we enter the loop body. We generate:
2342 countm1 = (to - from) / step;
2348 countm1 = (from - to) / -step;
2354 if (TREE_CODE (type
) == INTEGER_TYPE
)
2356 tree pos
, neg
, tou
, fromu
, stepu
, tmp2
;
2358 /* The distance from FROM to TO cannot always be represented in a signed
2359 type, thus use unsigned arithmetic, also to avoid any undefined
2361 tou
= fold_convert (utype
, to
);
2362 fromu
= fold_convert (utype
, from
);
2363 stepu
= fold_convert (utype
, step
);
2365 /* For a positive step, when to < from, exit, otherwise compute
2366 countm1 = ((unsigned)to - (unsigned)from) / (unsigned)step */
2367 tmp
= fold_build2_loc (loc
, LT_EXPR
, logical_type_node
, to
, from
);
2368 tmp2
= fold_build2_loc (loc
, TRUNC_DIV_EXPR
, utype
,
2369 fold_build2_loc (loc
, MINUS_EXPR
, utype
,
2372 pos
= build2 (COMPOUND_EXPR
, void_type_node
,
2373 fold_build2 (MODIFY_EXPR
, void_type_node
,
2375 build3_loc (loc
, COND_EXPR
, void_type_node
,
2376 gfc_unlikely (tmp
, PRED_FORTRAN_LOOP_PREHEADER
),
2377 build1_loc (loc
, GOTO_EXPR
, void_type_node
,
2378 exit_label
), NULL_TREE
));
2380 /* For a negative step, when to > from, exit, otherwise compute
2381 countm1 = ((unsigned)from - (unsigned)to) / -(unsigned)step */
2382 tmp
= fold_build2_loc (loc
, GT_EXPR
, logical_type_node
, to
, from
);
2383 tmp2
= fold_build2_loc (loc
, TRUNC_DIV_EXPR
, utype
,
2384 fold_build2_loc (loc
, MINUS_EXPR
, utype
,
2386 fold_build1_loc (loc
, NEGATE_EXPR
, utype
, stepu
));
2387 neg
= build2 (COMPOUND_EXPR
, void_type_node
,
2388 fold_build2 (MODIFY_EXPR
, void_type_node
,
2390 build3_loc (loc
, COND_EXPR
, void_type_node
,
2391 gfc_unlikely (tmp
, PRED_FORTRAN_LOOP_PREHEADER
),
2392 build1_loc (loc
, GOTO_EXPR
, void_type_node
,
2393 exit_label
), NULL_TREE
));
2395 tmp
= fold_build2_loc (loc
, LT_EXPR
, logical_type_node
, step
,
2396 build_int_cst (TREE_TYPE (step
), 0));
2397 tmp
= fold_build3_loc (loc
, COND_EXPR
, void_type_node
, tmp
, neg
, pos
);
2399 gfc_add_expr_to_block (&block
, tmp
);
2405 /* TODO: We could use the same width as the real type.
2406 This would probably cause more problems that it solves
2407 when we implement "long double" types. */
2409 tmp
= fold_build2_loc (loc
, MINUS_EXPR
, type
, to
, from
);
2410 tmp
= fold_build2_loc (loc
, RDIV_EXPR
, type
, tmp
, step
);
2411 tmp
= fold_build1_loc (loc
, FIX_TRUNC_EXPR
, utype
, tmp
);
2412 gfc_add_modify (&block
, countm1
, tmp
);
2414 /* We need a special check for empty loops:
2415 empty = (step > 0 ? to < from : to > from); */
2416 pos_step
= fold_build2_loc (loc
, GT_EXPR
, logical_type_node
, step
,
2417 build_zero_cst (type
));
2418 tmp
= fold_build3_loc (loc
, COND_EXPR
, logical_type_node
, pos_step
,
2419 fold_build2_loc (loc
, LT_EXPR
,
2420 logical_type_node
, to
, from
),
2421 fold_build2_loc (loc
, GT_EXPR
,
2422 logical_type_node
, to
, from
));
2423 /* If the loop is empty, go directly to the exit label. */
2424 tmp
= fold_build3_loc (loc
, COND_EXPR
, void_type_node
, tmp
,
2425 build1_v (GOTO_EXPR
, exit_label
),
2426 build_empty_stmt (input_location
));
2427 gfc_add_expr_to_block (&block
, tmp
);
2431 gfc_start_block (&body
);
2433 /* Main loop body. */
2434 tmp
= gfc_trans_code_cond (code
->block
->next
, exit_cond
);
2435 gfc_add_expr_to_block (&body
, tmp
);
2437 /* Label for cycle statements (if needed). */
2438 if (TREE_USED (cycle_label
))
2440 tmp
= build1_v (LABEL_EXPR
, cycle_label
);
2441 gfc_add_expr_to_block (&body
, tmp
);
2444 /* Check whether someone has modified the loop variable. */
2445 if (gfc_option
.rtcheck
& GFC_RTCHECK_DO
)
2447 tmp
= fold_build2_loc (loc
, NE_EXPR
, logical_type_node
, dovar
,
2449 gfc_trans_runtime_check (true, false, tmp
, &body
, &code
->loc
,
2450 "Loop variable has been modified");
2453 /* Exit the loop if there is an I/O result condition or error. */
2456 tmp
= build1_v (GOTO_EXPR
, exit_label
);
2457 tmp
= fold_build3_loc (loc
, COND_EXPR
, void_type_node
,
2459 build_empty_stmt (input_location
));
2460 gfc_add_expr_to_block (&body
, tmp
);
2463 /* Increment the loop variable. */
2464 tmp
= fold_build2_loc (loc
, PLUS_EXPR
, type
, dovar
, step
);
2465 gfc_add_modify_loc (loc
, &body
, dovar
, tmp
);
2467 if (gfc_option
.rtcheck
& GFC_RTCHECK_DO
)
2468 gfc_add_modify_loc (loc
, &body
, saved_dovar
, dovar
);
2470 /* Initialize countm1t. */
2471 tree countm1t
= gfc_create_var (utype
, "countm1t");
2472 gfc_add_modify_loc (loc
, &body
, countm1t
, countm1
);
2474 /* Decrement the loop count. */
2475 tmp
= fold_build2_loc (loc
, MINUS_EXPR
, utype
, countm1
,
2476 build_int_cst (utype
, 1));
2477 gfc_add_modify_loc (loc
, &body
, countm1
, tmp
);
2479 /* End with the loop condition. Loop until countm1t == 0. */
2480 cond
= fold_build2_loc (loc
, EQ_EXPR
, logical_type_node
, countm1t
,
2481 build_int_cst (utype
, 0));
2482 if (code
->ext
.iterator
->unroll
&& cond
!= error_mark_node
)
2484 = build3 (ANNOTATE_EXPR
, TREE_TYPE (cond
), cond
,
2485 build_int_cst (integer_type_node
, annot_expr_unroll_kind
),
2486 build_int_cst (integer_type_node
, code
->ext
.iterator
->unroll
));
2487 tmp
= fold_build1_loc (loc
, GOTO_EXPR
, void_type_node
, exit_label
);
2488 tmp
= fold_build3_loc (loc
, COND_EXPR
, void_type_node
,
2489 cond
, tmp
, build_empty_stmt (loc
));
2490 gfc_add_expr_to_block (&body
, tmp
);
2492 /* End of loop body. */
2493 tmp
= gfc_finish_block (&body
);
2495 /* The for loop itself. */
2496 tmp
= fold_build1_loc (loc
, LOOP_EXPR
, void_type_node
, tmp
);
2497 gfc_add_expr_to_block (&block
, tmp
);
2499 /* Add the exit label. */
2500 tmp
= build1_v (LABEL_EXPR
, exit_label
);
2501 gfc_add_expr_to_block (&block
, tmp
);
2503 return gfc_finish_block (&block
);
2507 /* Translate the DO WHILE construct.
2520 if (! cond) goto exit_label;
2526 Because the evaluation of the exit condition `cond' may have side
2527 effects, we can't do much for empty loop bodies. The backend optimizers
2528 should be smart enough to eliminate any dead loops. */
2531 gfc_trans_do_while (gfc_code
* code
)
2539 /* Everything we build here is part of the loop body. */
2540 gfc_start_block (&block
);
2542 /* Cycle and exit statements are implemented with gotos. */
2543 cycle_label
= gfc_build_label_decl (NULL_TREE
);
2544 exit_label
= gfc_build_label_decl (NULL_TREE
);
2546 /* Put the labels where they can be found later. See gfc_trans_do(). */
2547 code
->cycle_label
= cycle_label
;
2548 code
->exit_label
= exit_label
;
2550 /* Create a GIMPLE version of the exit condition. */
2551 gfc_init_se (&cond
, NULL
);
2552 gfc_conv_expr_val (&cond
, code
->expr1
);
2553 gfc_add_block_to_block (&block
, &cond
.pre
);
2554 cond
.expr
= fold_build1_loc (code
->expr1
->where
.lb
->location
,
2555 TRUTH_NOT_EXPR
, TREE_TYPE (cond
.expr
), cond
.expr
);
2557 /* Build "IF (! cond) GOTO exit_label". */
2558 tmp
= build1_v (GOTO_EXPR
, exit_label
);
2559 TREE_USED (exit_label
) = 1;
2560 tmp
= fold_build3_loc (code
->expr1
->where
.lb
->location
, COND_EXPR
,
2561 void_type_node
, cond
.expr
, tmp
,
2562 build_empty_stmt (code
->expr1
->where
.lb
->location
));
2563 gfc_add_expr_to_block (&block
, tmp
);
2565 /* The main body of the loop. */
2566 tmp
= gfc_trans_code (code
->block
->next
);
2567 gfc_add_expr_to_block (&block
, tmp
);
2569 /* Label for cycle statements (if needed). */
2570 if (TREE_USED (cycle_label
))
2572 tmp
= build1_v (LABEL_EXPR
, cycle_label
);
2573 gfc_add_expr_to_block (&block
, tmp
);
2576 /* End of loop body. */
2577 tmp
= gfc_finish_block (&block
);
2579 gfc_init_block (&block
);
2580 /* Build the loop. */
2581 tmp
= fold_build1_loc (code
->expr1
->where
.lb
->location
, LOOP_EXPR
,
2582 void_type_node
, tmp
);
2583 gfc_add_expr_to_block (&block
, tmp
);
2585 /* Add the exit label. */
2586 tmp
= build1_v (LABEL_EXPR
, exit_label
);
2587 gfc_add_expr_to_block (&block
, tmp
);
2589 return gfc_finish_block (&block
);
2593 /* Deal with the particular case of SELECT_TYPE, where the vtable
2594 addresses are used for the selection. Since these are not sorted,
2595 the selection has to be made by a series of if statements. */
2598 gfc_trans_select_type_cases (gfc_code
* code
)
2612 gfc_start_block (&block
);
2614 /* Calculate the switch expression. */
2615 gfc_init_se (&se
, NULL
);
2616 gfc_conv_expr_val (&se
, code
->expr1
);
2617 gfc_add_block_to_block (&block
, &se
.pre
);
2619 /* Generate an expression for the selector hash value, for
2620 use to resolve character cases. */
2621 e
= gfc_copy_expr (code
->expr1
->value
.function
.actual
->expr
);
2622 gfc_add_hash_component (e
);
2624 TREE_USED (code
->exit_label
) = 0;
2627 for (c
= code
->block
; c
; c
= c
->block
)
2629 cp
= c
->ext
.block
.case_list
;
2631 /* Assume it's the default case. */
2636 /* Put the default case at the end. */
2637 if ((!def
&& !cp
->low
) || (def
&& cp
->low
))
2640 if (cp
->low
&& (cp
->ts
.type
== BT_CLASS
2641 || cp
->ts
.type
== BT_DERIVED
))
2643 gfc_init_se (&cse
, NULL
);
2644 gfc_conv_expr_val (&cse
, cp
->low
);
2645 gfc_add_block_to_block (&block
, &cse
.pre
);
2648 else if (cp
->ts
.type
!= BT_UNKNOWN
)
2650 gcc_assert (cp
->high
);
2651 gfc_init_se (&cse
, NULL
);
2652 gfc_conv_expr_val (&cse
, cp
->high
);
2653 gfc_add_block_to_block (&block
, &cse
.pre
);
2657 gfc_init_block (&body
);
2659 /* Add the statements for this case. */
2660 tmp
= gfc_trans_code (c
->next
);
2661 gfc_add_expr_to_block (&body
, tmp
);
2663 /* Break to the end of the SELECT TYPE construct. The default
2664 case just falls through. */
2667 TREE_USED (code
->exit_label
) = 1;
2668 tmp
= build1_v (GOTO_EXPR
, code
->exit_label
);
2669 gfc_add_expr_to_block (&body
, tmp
);
2672 tmp
= gfc_finish_block (&body
);
2674 if (low
!= NULL_TREE
)
2676 /* Compare vtable pointers. */
2677 cond
= fold_build2_loc (input_location
, EQ_EXPR
,
2678 TREE_TYPE (se
.expr
), se
.expr
, low
);
2679 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
2681 build_empty_stmt (input_location
));
2683 else if (high
!= NULL_TREE
)
2685 /* Compare hash values for character cases. */
2686 gfc_init_se (&cse
, NULL
);
2687 gfc_conv_expr_val (&cse
, e
);
2688 gfc_add_block_to_block (&block
, &cse
.pre
);
2690 cond
= fold_build2_loc (input_location
, EQ_EXPR
,
2691 TREE_TYPE (se
.expr
), high
, cse
.expr
);
2692 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
2694 build_empty_stmt (input_location
));
2697 gfc_add_expr_to_block (&block
, tmp
);
2708 return gfc_finish_block (&block
);
2712 /* Translate the SELECT CASE construct for INTEGER case expressions,
2713 without killing all potential optimizations. The problem is that
2714 Fortran allows unbounded cases, but the back-end does not, so we
2715 need to intercept those before we enter the equivalent SWITCH_EXPR
2718 For example, we translate this,
2721 CASE (:100,101,105:115)
2731 to the GENERIC equivalent,
2735 case (minimum value for typeof(expr) ... 100:
2741 case 200 ... (maximum value for typeof(expr):
2758 gfc_trans_integer_select (gfc_code
* code
)
2768 gfc_start_block (&block
);
2770 /* Calculate the switch expression. */
2771 gfc_init_se (&se
, NULL
);
2772 gfc_conv_expr_val (&se
, code
->expr1
);
2773 gfc_add_block_to_block (&block
, &se
.pre
);
2775 end_label
= gfc_build_label_decl (NULL_TREE
);
2777 gfc_init_block (&body
);
2779 for (c
= code
->block
; c
; c
= c
->block
)
2781 for (cp
= c
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
2786 /* Assume it's the default case. */
2787 low
= high
= NULL_TREE
;
2791 low
= gfc_conv_mpz_to_tree (cp
->low
->value
.integer
,
2794 /* If there's only a lower bound, set the high bound to the
2795 maximum value of the case expression. */
2797 high
= TYPE_MAX_VALUE (TREE_TYPE (se
.expr
));
2802 /* Three cases are possible here:
2804 1) There is no lower bound, e.g. CASE (:N).
2805 2) There is a lower bound .NE. high bound, that is
2806 a case range, e.g. CASE (N:M) where M>N (we make
2807 sure that M>N during type resolution).
2808 3) There is a lower bound, and it has the same value
2809 as the high bound, e.g. CASE (N:N). This is our
2810 internal representation of CASE(N).
2812 In the first and second case, we need to set a value for
2813 high. In the third case, we don't because the GCC middle
2814 end represents a single case value by just letting high be
2815 a NULL_TREE. We can't do that because we need to be able
2816 to represent unbounded cases. */
2819 || (mpz_cmp (cp
->low
->value
.integer
,
2820 cp
->high
->value
.integer
) != 0))
2821 high
= gfc_conv_mpz_to_tree (cp
->high
->value
.integer
,
2824 /* Unbounded case. */
2826 low
= TYPE_MIN_VALUE (TREE_TYPE (se
.expr
));
2829 /* Build a label. */
2830 label
= gfc_build_label_decl (NULL_TREE
);
2832 /* Add this case label.
2833 Add parameter 'label', make it match GCC backend. */
2834 tmp
= build_case_label (low
, high
, label
);
2835 gfc_add_expr_to_block (&body
, tmp
);
2838 /* Add the statements for this case. */
2839 tmp
= gfc_trans_code (c
->next
);
2840 gfc_add_expr_to_block (&body
, tmp
);
2842 /* Break to the end of the construct. */
2843 tmp
= build1_v (GOTO_EXPR
, end_label
);
2844 gfc_add_expr_to_block (&body
, tmp
);
2847 tmp
= gfc_finish_block (&body
);
2848 tmp
= fold_build2_loc (input_location
, SWITCH_EXPR
, NULL_TREE
, se
.expr
, tmp
);
2849 gfc_add_expr_to_block (&block
, tmp
);
2851 tmp
= build1_v (LABEL_EXPR
, end_label
);
2852 gfc_add_expr_to_block (&block
, tmp
);
2854 return gfc_finish_block (&block
);
2858 /* Translate the SELECT CASE construct for LOGICAL case expressions.
2860 There are only two cases possible here, even though the standard
2861 does allow three cases in a LOGICAL SELECT CASE construct: .TRUE.,
2862 .FALSE., and DEFAULT.
2864 We never generate more than two blocks here. Instead, we always
2865 try to eliminate the DEFAULT case. This way, we can translate this
2866 kind of SELECT construct to a simple
2870 expression in GENERIC. */
2873 gfc_trans_logical_select (gfc_code
* code
)
2876 gfc_code
*t
, *f
, *d
;
2881 /* Assume we don't have any cases at all. */
2884 /* Now see which ones we actually do have. We can have at most two
2885 cases in a single case list: one for .TRUE. and one for .FALSE.
2886 The default case is always separate. If the cases for .TRUE. and
2887 .FALSE. are in the same case list, the block for that case list
2888 always executed, and we don't generate code a COND_EXPR. */
2889 for (c
= code
->block
; c
; c
= c
->block
)
2891 for (cp
= c
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
2895 if (cp
->low
->value
.logical
== 0) /* .FALSE. */
2897 else /* if (cp->value.logical != 0), thus .TRUE. */
2905 /* Start a new block. */
2906 gfc_start_block (&block
);
2908 /* Calculate the switch expression. We always need to do this
2909 because it may have side effects. */
2910 gfc_init_se (&se
, NULL
);
2911 gfc_conv_expr_val (&se
, code
->expr1
);
2912 gfc_add_block_to_block (&block
, &se
.pre
);
2914 if (t
== f
&& t
!= NULL
)
2916 /* Cases for .TRUE. and .FALSE. are in the same block. Just
2917 translate the code for these cases, append it to the current
2919 gfc_add_expr_to_block (&block
, gfc_trans_code (t
->next
));
2923 tree true_tree
, false_tree
, stmt
;
2925 true_tree
= build_empty_stmt (input_location
);
2926 false_tree
= build_empty_stmt (input_location
);
2928 /* If we have a case for .TRUE. and for .FALSE., discard the default case.
2929 Otherwise, if .TRUE. or .FALSE. is missing and there is a default case,
2930 make the missing case the default case. */
2931 if (t
!= NULL
&& f
!= NULL
)
2941 /* Translate the code for each of these blocks, and append it to
2942 the current block. */
2944 true_tree
= gfc_trans_code (t
->next
);
2947 false_tree
= gfc_trans_code (f
->next
);
2949 stmt
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
2950 se
.expr
, true_tree
, false_tree
);
2951 gfc_add_expr_to_block (&block
, stmt
);
2954 return gfc_finish_block (&block
);
2958 /* The jump table types are stored in static variables to avoid
2959 constructing them from scratch every single time. */
2960 static GTY(()) tree select_struct
[2];
2962 /* Translate the SELECT CASE construct for CHARACTER case expressions.
2963 Instead of generating compares and jumps, it is far simpler to
2964 generate a data structure describing the cases in order and call a
2965 library subroutine that locates the right case.
2966 This is particularly true because this is the only case where we
2967 might have to dispose of a temporary.
2968 The library subroutine returns a pointer to jump to or NULL if no
2969 branches are to be taken. */
2972 gfc_trans_character_select (gfc_code
*code
)
2974 tree init
, end_label
, tmp
, type
, case_num
, label
, fndecl
;
2975 stmtblock_t block
, body
;
2980 vec
<constructor_elt
, va_gc
> *inits
= NULL
;
2982 tree pchartype
= gfc_get_pchar_type (code
->expr1
->ts
.kind
);
2984 /* The jump table types are stored in static variables to avoid
2985 constructing them from scratch every single time. */
2986 static tree ss_string1
[2], ss_string1_len
[2];
2987 static tree ss_string2
[2], ss_string2_len
[2];
2988 static tree ss_target
[2];
2990 cp
= code
->block
->ext
.block
.case_list
;
2991 while (cp
->left
!= NULL
)
2994 /* Generate the body */
2995 gfc_start_block (&block
);
2996 gfc_init_se (&expr1se
, NULL
);
2997 gfc_conv_expr_reference (&expr1se
, code
->expr1
);
2999 gfc_add_block_to_block (&block
, &expr1se
.pre
);
3001 end_label
= gfc_build_label_decl (NULL_TREE
);
3003 gfc_init_block (&body
);
3005 /* Attempt to optimize length 1 selects. */
3006 if (integer_onep (expr1se
.string_length
))
3008 for (d
= cp
; d
; d
= d
->right
)
3013 gcc_assert (d
->low
->expr_type
== EXPR_CONSTANT
3014 && d
->low
->ts
.type
== BT_CHARACTER
);
3015 if (d
->low
->value
.character
.length
> 1)
3017 for (i
= 1; i
< d
->low
->value
.character
.length
; i
++)
3018 if (d
->low
->value
.character
.string
[i
] != ' ')
3020 if (i
!= d
->low
->value
.character
.length
)
3022 if (optimize
&& d
->high
&& i
== 1)
3024 gcc_assert (d
->high
->expr_type
== EXPR_CONSTANT
3025 && d
->high
->ts
.type
== BT_CHARACTER
);
3026 if (d
->high
->value
.character
.length
> 1
3027 && (d
->low
->value
.character
.string
[0]
3028 == d
->high
->value
.character
.string
[0])
3029 && d
->high
->value
.character
.string
[1] != ' '
3030 && ((d
->low
->value
.character
.string
[1] < ' ')
3031 == (d
->high
->value
.character
.string
[1]
3041 gcc_assert (d
->high
->expr_type
== EXPR_CONSTANT
3042 && d
->high
->ts
.type
== BT_CHARACTER
);
3043 if (d
->high
->value
.character
.length
> 1)
3045 for (i
= 1; i
< d
->high
->value
.character
.length
; i
++)
3046 if (d
->high
->value
.character
.string
[i
] != ' ')
3048 if (i
!= d
->high
->value
.character
.length
)
3055 tree ctype
= gfc_get_char_type (code
->expr1
->ts
.kind
);
3057 for (c
= code
->block
; c
; c
= c
->block
)
3059 for (cp
= c
->ext
.block
.case_list
; cp
; cp
= cp
->next
)
3065 /* Assume it's the default case. */
3066 low
= high
= NULL_TREE
;
3070 /* CASE ('ab') or CASE ('ab':'az') will never match
3071 any length 1 character. */
3072 if (cp
->low
->value
.character
.length
> 1
3073 && cp
->low
->value
.character
.string
[1] != ' ')
3076 if (cp
->low
->value
.character
.length
> 0)
3077 r
= cp
->low
->value
.character
.string
[0];
3080 low
= build_int_cst (ctype
, r
);
3082 /* If there's only a lower bound, set the high bound
3083 to the maximum value of the case expression. */
3085 high
= TYPE_MAX_VALUE (ctype
);
3091 || (cp
->low
->value
.character
.string
[0]
3092 != cp
->high
->value
.character
.string
[0]))
3094 if (cp
->high
->value
.character
.length
> 0)
3095 r
= cp
->high
->value
.character
.string
[0];
3098 high
= build_int_cst (ctype
, r
);
3101 /* Unbounded case. */
3103 low
= TYPE_MIN_VALUE (ctype
);
3106 /* Build a label. */
3107 label
= gfc_build_label_decl (NULL_TREE
);
3109 /* Add this case label.
3110 Add parameter 'label', make it match GCC backend. */
3111 tmp
= build_case_label (low
, high
, label
);
3112 gfc_add_expr_to_block (&body
, tmp
);
3115 /* Add the statements for this case. */
3116 tmp
= gfc_trans_code (c
->next
);
3117 gfc_add_expr_to_block (&body
, tmp
);
3119 /* Break to the end of the construct. */
3120 tmp
= build1_v (GOTO_EXPR
, end_label
);
3121 gfc_add_expr_to_block (&body
, tmp
);
3124 tmp
= gfc_string_to_single_character (expr1se
.string_length
,
3126 code
->expr1
->ts
.kind
);
3127 case_num
= gfc_create_var (ctype
, "case_num");
3128 gfc_add_modify (&block
, case_num
, tmp
);
3130 gfc_add_block_to_block (&block
, &expr1se
.post
);
3132 tmp
= gfc_finish_block (&body
);
3133 tmp
= fold_build2_loc (input_location
, SWITCH_EXPR
, NULL_TREE
,
3135 gfc_add_expr_to_block (&block
, tmp
);
3137 tmp
= build1_v (LABEL_EXPR
, end_label
);
3138 gfc_add_expr_to_block (&block
, tmp
);
3140 return gfc_finish_block (&block
);
3144 if (code
->expr1
->ts
.kind
== 1)
3146 else if (code
->expr1
->ts
.kind
== 4)
3151 if (select_struct
[k
] == NULL
)
3154 select_struct
[k
] = make_node (RECORD_TYPE
);
3156 if (code
->expr1
->ts
.kind
== 1)
3157 TYPE_NAME (select_struct
[k
]) = get_identifier ("_jump_struct_char1");
3158 else if (code
->expr1
->ts
.kind
== 4)
3159 TYPE_NAME (select_struct
[k
]) = get_identifier ("_jump_struct_char4");
3164 #define ADD_FIELD(NAME, TYPE) \
3165 ss_##NAME[k] = gfc_add_field_to_struct (select_struct[k], \
3166 get_identifier (stringize(NAME)), \
3170 ADD_FIELD (string1
, pchartype
);
3171 ADD_FIELD (string1_len
, gfc_charlen_type_node
);
3173 ADD_FIELD (string2
, pchartype
);
3174 ADD_FIELD (string2_len
, gfc_charlen_type_node
);
3176 ADD_FIELD (target
, integer_type_node
);
3179 gfc_finish_type (select_struct
[k
]);
3183 for (d
= cp
; d
; d
= d
->right
)
3186 for (c
= code
->block
; c
; c
= c
->block
)
3188 for (d
= c
->ext
.block
.case_list
; d
; d
= d
->next
)
3190 label
= gfc_build_label_decl (NULL_TREE
);
3191 tmp
= build_case_label ((d
->low
== NULL
&& d
->high
== NULL
)
3193 : build_int_cst (integer_type_node
, d
->n
),
3195 gfc_add_expr_to_block (&body
, tmp
);
3198 tmp
= gfc_trans_code (c
->next
);
3199 gfc_add_expr_to_block (&body
, tmp
);
3201 tmp
= build1_v (GOTO_EXPR
, end_label
);
3202 gfc_add_expr_to_block (&body
, tmp
);
3205 /* Generate the structure describing the branches */
3206 for (d
= cp
; d
; d
= d
->right
)
3208 vec
<constructor_elt
, va_gc
> *node
= NULL
;
3210 gfc_init_se (&se
, NULL
);
3214 CONSTRUCTOR_APPEND_ELT (node
, ss_string1
[k
], null_pointer_node
);
3215 CONSTRUCTOR_APPEND_ELT (node
, ss_string1_len
[k
], build_zero_cst (gfc_charlen_type_node
));
3219 gfc_conv_expr_reference (&se
, d
->low
);
3221 CONSTRUCTOR_APPEND_ELT (node
, ss_string1
[k
], se
.expr
);
3222 CONSTRUCTOR_APPEND_ELT (node
, ss_string1_len
[k
], se
.string_length
);
3225 if (d
->high
== NULL
)
3227 CONSTRUCTOR_APPEND_ELT (node
, ss_string2
[k
], null_pointer_node
);
3228 CONSTRUCTOR_APPEND_ELT (node
, ss_string2_len
[k
], build_zero_cst (gfc_charlen_type_node
));
3232 gfc_init_se (&se
, NULL
);
3233 gfc_conv_expr_reference (&se
, d
->high
);
3235 CONSTRUCTOR_APPEND_ELT (node
, ss_string2
[k
], se
.expr
);
3236 CONSTRUCTOR_APPEND_ELT (node
, ss_string2_len
[k
], se
.string_length
);
3239 CONSTRUCTOR_APPEND_ELT (node
, ss_target
[k
],
3240 build_int_cst (integer_type_node
, d
->n
));
3242 tmp
= build_constructor (select_struct
[k
], node
);
3243 CONSTRUCTOR_APPEND_ELT (inits
, NULL_TREE
, tmp
);
3246 type
= build_array_type (select_struct
[k
],
3247 build_index_type (size_int (n
-1)));
3249 init
= build_constructor (type
, inits
);
3250 TREE_CONSTANT (init
) = 1;
3251 TREE_STATIC (init
) = 1;
3252 /* Create a static variable to hold the jump table. */
3253 tmp
= gfc_create_var (type
, "jumptable");
3254 TREE_CONSTANT (tmp
) = 1;
3255 TREE_STATIC (tmp
) = 1;
3256 TREE_READONLY (tmp
) = 1;
3257 DECL_INITIAL (tmp
) = init
;
3260 /* Build the library call */
3261 init
= gfc_build_addr_expr (pvoid_type_node
, init
);
3263 if (code
->expr1
->ts
.kind
== 1)
3264 fndecl
= gfor_fndecl_select_string
;
3265 else if (code
->expr1
->ts
.kind
== 4)
3266 fndecl
= gfor_fndecl_select_string_char4
;
3270 tmp
= build_call_expr_loc (input_location
,
3272 build_int_cst (gfc_charlen_type_node
, n
),
3273 expr1se
.expr
, expr1se
.string_length
);
3274 case_num
= gfc_create_var (integer_type_node
, "case_num");
3275 gfc_add_modify (&block
, case_num
, tmp
);
3277 gfc_add_block_to_block (&block
, &expr1se
.post
);
3279 tmp
= gfc_finish_block (&body
);
3280 tmp
= fold_build2_loc (input_location
, SWITCH_EXPR
, NULL_TREE
,
3282 gfc_add_expr_to_block (&block
, tmp
);
3284 tmp
= build1_v (LABEL_EXPR
, end_label
);
3285 gfc_add_expr_to_block (&block
, tmp
);
3287 return gfc_finish_block (&block
);
3291 /* Translate the three variants of the SELECT CASE construct.
3293 SELECT CASEs with INTEGER case expressions can be translated to an
3294 equivalent GENERIC switch statement, and for LOGICAL case
3295 expressions we build one or two if-else compares.
3297 SELECT CASEs with CHARACTER case expressions are a whole different
3298 story, because they don't exist in GENERIC. So we sort them and
3299 do a binary search at runtime.
3301 Fortran has no BREAK statement, and it does not allow jumps from
3302 one case block to another. That makes things a lot easier for
3306 gfc_trans_select (gfc_code
* code
)
3312 gcc_assert (code
&& code
->expr1
);
3313 gfc_init_block (&block
);
3315 /* Build the exit label and hang it in. */
3316 exit_label
= gfc_build_label_decl (NULL_TREE
);
3317 code
->exit_label
= exit_label
;
3319 /* Empty SELECT constructs are legal. */
3320 if (code
->block
== NULL
)
3321 body
= build_empty_stmt (input_location
);
3323 /* Select the correct translation function. */
3325 switch (code
->expr1
->ts
.type
)
3328 body
= gfc_trans_logical_select (code
);
3332 body
= gfc_trans_integer_select (code
);
3336 body
= gfc_trans_character_select (code
);
3340 gfc_internal_error ("gfc_trans_select(): Bad type for case expr.");
3344 /* Build everything together. */
3345 gfc_add_expr_to_block (&block
, body
);
3346 gfc_add_expr_to_block (&block
, build1_v (LABEL_EXPR
, exit_label
));
3348 return gfc_finish_block (&block
);
3352 gfc_trans_select_type (gfc_code
* code
)
3358 gcc_assert (code
&& code
->expr1
);
3359 gfc_init_block (&block
);
3361 /* Build the exit label and hang it in. */
3362 exit_label
= gfc_build_label_decl (NULL_TREE
);
3363 code
->exit_label
= exit_label
;
3365 /* Empty SELECT constructs are legal. */
3366 if (code
->block
== NULL
)
3367 body
= build_empty_stmt (input_location
);
3369 body
= gfc_trans_select_type_cases (code
);
3371 /* Build everything together. */
3372 gfc_add_expr_to_block (&block
, body
);
3374 if (TREE_USED (exit_label
))
3375 gfc_add_expr_to_block (&block
, build1_v (LABEL_EXPR
, exit_label
));
3377 return gfc_finish_block (&block
);
3381 /* Traversal function to substitute a replacement symtree if the symbol
3382 in the expression is the same as that passed. f == 2 signals that
3383 that variable itself is not to be checked - only the references.
3384 This group of functions is used when the variable expression in a
3385 FORALL assignment has internal references. For example:
3386 FORALL (i = 1:4) p(p(i)) = i
3387 The only recourse here is to store a copy of 'p' for the index
3390 static gfc_symtree
*new_symtree
;
3391 static gfc_symtree
*old_symtree
;
3394 forall_replace (gfc_expr
*expr
, gfc_symbol
*sym
, int *f
)
3396 if (expr
->expr_type
!= EXPR_VARIABLE
)
3401 else if (expr
->symtree
->n
.sym
== sym
)
3402 expr
->symtree
= new_symtree
;
3408 forall_replace_symtree (gfc_expr
*e
, gfc_symbol
*sym
, int f
)
3410 gfc_traverse_expr (e
, sym
, forall_replace
, f
);
3414 forall_restore (gfc_expr
*expr
,
3415 gfc_symbol
*sym ATTRIBUTE_UNUSED
,
3416 int *f ATTRIBUTE_UNUSED
)
3418 if (expr
->expr_type
!= EXPR_VARIABLE
)
3421 if (expr
->symtree
== new_symtree
)
3422 expr
->symtree
= old_symtree
;
3428 forall_restore_symtree (gfc_expr
*e
)
3430 gfc_traverse_expr (e
, NULL
, forall_restore
, 0);
3434 forall_make_variable_temp (gfc_code
*c
, stmtblock_t
*pre
, stmtblock_t
*post
)
3439 gfc_symbol
*new_sym
;
3440 gfc_symbol
*old_sym
;
3444 /* Build a copy of the lvalue. */
3445 old_symtree
= c
->expr1
->symtree
;
3446 old_sym
= old_symtree
->n
.sym
;
3447 e
= gfc_lval_expr_from_sym (old_sym
);
3448 if (old_sym
->attr
.dimension
)
3450 gfc_init_se (&tse
, NULL
);
3451 gfc_conv_subref_array_arg (&tse
, e
, 0, INTENT_IN
, false);
3452 gfc_add_block_to_block (pre
, &tse
.pre
);
3453 gfc_add_block_to_block (post
, &tse
.post
);
3454 tse
.expr
= build_fold_indirect_ref_loc (input_location
, tse
.expr
);
3456 if (c
->expr1
->ref
->u
.ar
.type
!= AR_SECTION
)
3458 /* Use the variable offset for the temporary. */
3459 tmp
= gfc_conv_array_offset (old_sym
->backend_decl
);
3460 gfc_conv_descriptor_offset_set (pre
, tse
.expr
, tmp
);
3465 gfc_init_se (&tse
, NULL
);
3466 gfc_init_se (&rse
, NULL
);
3467 gfc_conv_expr (&rse
, e
);
3468 if (e
->ts
.type
== BT_CHARACTER
)
3470 tse
.string_length
= rse
.string_length
;
3471 tmp
= gfc_get_character_type_len (gfc_default_character_kind
,
3473 tse
.expr
= gfc_conv_string_tmp (&tse
, build_pointer_type (tmp
),
3475 gfc_add_block_to_block (pre
, &tse
.pre
);
3476 gfc_add_block_to_block (post
, &tse
.post
);
3480 tmp
= gfc_typenode_for_spec (&e
->ts
);
3481 tse
.expr
= gfc_create_var (tmp
, "temp");
3484 tmp
= gfc_trans_scalar_assign (&tse
, &rse
, e
->ts
,
3485 e
->expr_type
== EXPR_VARIABLE
, false);
3486 gfc_add_expr_to_block (pre
, tmp
);
3490 /* Create a new symbol to represent the lvalue. */
3491 new_sym
= gfc_new_symbol (old_sym
->name
, NULL
);
3492 new_sym
->ts
= old_sym
->ts
;
3493 new_sym
->attr
.referenced
= 1;
3494 new_sym
->attr
.temporary
= 1;
3495 new_sym
->attr
.dimension
= old_sym
->attr
.dimension
;
3496 new_sym
->attr
.flavor
= old_sym
->attr
.flavor
;
3498 /* Use the temporary as the backend_decl. */
3499 new_sym
->backend_decl
= tse
.expr
;
3501 /* Create a fake symtree for it. */
3503 new_symtree
= gfc_new_symtree (&root
, old_sym
->name
);
3504 new_symtree
->n
.sym
= new_sym
;
3505 gcc_assert (new_symtree
== root
);
3507 /* Go through the expression reference replacing the old_symtree
3509 forall_replace_symtree (c
->expr1
, old_sym
, 2);
3511 /* Now we have made this temporary, we might as well use it for
3512 the right hand side. */
3513 forall_replace_symtree (c
->expr2
, old_sym
, 1);
3517 /* Handles dependencies in forall assignments. */
3519 check_forall_dependencies (gfc_code
*c
, stmtblock_t
*pre
, stmtblock_t
*post
)
3526 lsym
= c
->expr1
->symtree
->n
.sym
;
3527 need_temp
= gfc_check_dependency (c
->expr1
, c
->expr2
, 0);
3529 /* Now check for dependencies within the 'variable'
3530 expression itself. These are treated by making a complete
3531 copy of variable and changing all the references to it
3532 point to the copy instead. Note that the shallow copy of
3533 the variable will not suffice for derived types with
3534 pointer components. We therefore leave these to their
3536 if (lsym
->ts
.type
== BT_DERIVED
3537 && lsym
->ts
.u
.derived
->attr
.pointer_comp
)
3541 if (find_forall_index (c
->expr1
, lsym
, 2))
3543 forall_make_variable_temp (c
, pre
, post
);
3547 /* Substrings with dependencies are treated in the same
3549 if (c
->expr1
->ts
.type
== BT_CHARACTER
3551 && c
->expr2
->expr_type
== EXPR_VARIABLE
3552 && lsym
== c
->expr2
->symtree
->n
.sym
)
3554 for (lref
= c
->expr1
->ref
; lref
; lref
= lref
->next
)
3555 if (lref
->type
== REF_SUBSTRING
)
3557 for (rref
= c
->expr2
->ref
; rref
; rref
= rref
->next
)
3558 if (rref
->type
== REF_SUBSTRING
)
3562 && gfc_dep_compare_expr (rref
->u
.ss
.start
, lref
->u
.ss
.start
) < 0)
3564 forall_make_variable_temp (c
, pre
, post
);
3573 cleanup_forall_symtrees (gfc_code
*c
)
3575 forall_restore_symtree (c
->expr1
);
3576 forall_restore_symtree (c
->expr2
);
3577 free (new_symtree
->n
.sym
);
3582 /* Generate the loops for a FORALL block, specified by FORALL_TMP. BODY
3583 is the contents of the FORALL block/stmt to be iterated. MASK_FLAG
3584 indicates whether we should generate code to test the FORALLs mask
3585 array. OUTER is the loop header to be used for initializing mask
3588 The generated loop format is:
3589 count = (end - start + step) / step
3602 gfc_trans_forall_loop (forall_info
*forall_tmp
, tree body
,
3603 int mask_flag
, stmtblock_t
*outer
)
3611 tree var
, start
, end
, step
;
3614 /* Initialize the mask index outside the FORALL nest. */
3615 if (mask_flag
&& forall_tmp
->mask
)
3616 gfc_add_modify (outer
, forall_tmp
->maskindex
, gfc_index_zero_node
);
3618 iter
= forall_tmp
->this_loop
;
3619 nvar
= forall_tmp
->nvar
;
3620 for (n
= 0; n
< nvar
; n
++)
3623 start
= iter
->start
;
3627 exit_label
= gfc_build_label_decl (NULL_TREE
);
3628 TREE_USED (exit_label
) = 1;
3630 /* The loop counter. */
3631 count
= gfc_create_var (TREE_TYPE (var
), "count");
3633 /* The body of the loop. */
3634 gfc_init_block (&block
);
3636 /* The exit condition. */
3637 cond
= fold_build2_loc (input_location
, LE_EXPR
, logical_type_node
,
3638 count
, build_int_cst (TREE_TYPE (count
), 0));
3640 /* PR 83064 means that we cannot use annot_expr_parallel_kind until
3641 the autoparallelizer can hande this. */
3642 if (forall_tmp
->do_concurrent
)
3643 cond
= build3 (ANNOTATE_EXPR
, TREE_TYPE (cond
), cond
,
3644 build_int_cst (integer_type_node
,
3645 annot_expr_ivdep_kind
),
3648 tmp
= build1_v (GOTO_EXPR
, exit_label
);
3649 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
3650 cond
, tmp
, build_empty_stmt (input_location
));
3651 gfc_add_expr_to_block (&block
, tmp
);
3653 /* The main loop body. */
3654 gfc_add_expr_to_block (&block
, body
);
3656 /* Increment the loop variable. */
3657 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (var
), var
,
3659 gfc_add_modify (&block
, var
, tmp
);
3661 /* Advance to the next mask element. Only do this for the
3663 if (n
== 0 && mask_flag
&& forall_tmp
->mask
)
3665 tree maskindex
= forall_tmp
->maskindex
;
3666 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
3667 maskindex
, gfc_index_one_node
);
3668 gfc_add_modify (&block
, maskindex
, tmp
);
3671 /* Decrement the loop counter. */
3672 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (var
), count
,
3673 build_int_cst (TREE_TYPE (var
), 1));
3674 gfc_add_modify (&block
, count
, tmp
);
3676 body
= gfc_finish_block (&block
);
3678 /* Loop var initialization. */
3679 gfc_init_block (&block
);
3680 gfc_add_modify (&block
, var
, start
);
3683 /* Initialize the loop counter. */
3684 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (var
), step
,
3686 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (var
), end
,
3688 tmp
= fold_build2_loc (input_location
, TRUNC_DIV_EXPR
, TREE_TYPE (var
),
3690 gfc_add_modify (&block
, count
, tmp
);
3692 /* The loop expression. */
3693 tmp
= build1_v (LOOP_EXPR
, body
);
3694 gfc_add_expr_to_block (&block
, tmp
);
3696 /* The exit label. */
3697 tmp
= build1_v (LABEL_EXPR
, exit_label
);
3698 gfc_add_expr_to_block (&block
, tmp
);
3700 body
= gfc_finish_block (&block
);
3707 /* Generate the body and loops according to MASK_FLAG. If MASK_FLAG
3708 is nonzero, the body is controlled by all masks in the forall nest.
3709 Otherwise, the innermost loop is not controlled by it's mask. This
3710 is used for initializing that mask. */
3713 gfc_trans_nested_forall_loop (forall_info
* nested_forall_info
, tree body
,
3718 forall_info
*forall_tmp
;
3719 tree mask
, maskindex
;
3721 gfc_start_block (&header
);
3723 forall_tmp
= nested_forall_info
;
3724 while (forall_tmp
!= NULL
)
3726 /* Generate body with masks' control. */
3729 mask
= forall_tmp
->mask
;
3730 maskindex
= forall_tmp
->maskindex
;
3732 /* If a mask was specified make the assignment conditional. */
3735 tmp
= gfc_build_array_ref (mask
, maskindex
, NULL
);
3736 body
= build3_v (COND_EXPR
, tmp
, body
,
3737 build_empty_stmt (input_location
));
3740 body
= gfc_trans_forall_loop (forall_tmp
, body
, mask_flag
, &header
);
3741 forall_tmp
= forall_tmp
->prev_nest
;
3745 gfc_add_expr_to_block (&header
, body
);
3746 return gfc_finish_block (&header
);
3750 /* Allocate data for holding a temporary array. Returns either a local
3751 temporary array or a pointer variable. */
3754 gfc_do_allocate (tree bytesize
, tree size
, tree
* pdata
, stmtblock_t
* pblock
,
3761 if (INTEGER_CST_P (size
))
3762 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, gfc_array_index_type
,
3763 size
, gfc_index_one_node
);
3767 type
= build_range_type (gfc_array_index_type
, gfc_index_zero_node
, tmp
);
3768 type
= build_array_type (elem_type
, type
);
3769 if (gfc_can_put_var_on_stack (bytesize
) && INTEGER_CST_P (size
))
3771 tmpvar
= gfc_create_var (type
, "temp");
3776 tmpvar
= gfc_create_var (build_pointer_type (type
), "temp");
3777 *pdata
= convert (pvoid_type_node
, tmpvar
);
3779 tmp
= gfc_call_malloc (pblock
, TREE_TYPE (tmpvar
), bytesize
);
3780 gfc_add_modify (pblock
, tmpvar
, tmp
);
3786 /* Generate codes to copy the temporary to the actual lhs. */
3789 generate_loop_for_temp_to_lhs (gfc_expr
*expr
, tree tmp1
, tree count3
,
3791 gfc_ss
*lss
, gfc_ss
*rss
,
3792 tree wheremask
, bool invert
)
3794 stmtblock_t block
, body1
;
3801 (void) rss
; /* TODO: unused. */
3803 gfc_start_block (&block
);
3805 gfc_init_se (&rse
, NULL
);
3806 gfc_init_se (&lse
, NULL
);
3808 if (lss
== gfc_ss_terminator
)
3810 gfc_init_block (&body1
);
3811 gfc_conv_expr (&lse
, expr
);
3812 rse
.expr
= gfc_build_array_ref (tmp1
, count1
, NULL
);
3816 /* Initialize the loop. */
3817 gfc_init_loopinfo (&loop
);
3819 /* We may need LSS to determine the shape of the expression. */
3820 gfc_add_ss_to_loop (&loop
, lss
);
3822 gfc_conv_ss_startstride (&loop
);
3823 gfc_conv_loop_setup (&loop
, &expr
->where
);
3825 gfc_mark_ss_chain_used (lss
, 1);
3826 /* Start the loop body. */
3827 gfc_start_scalarized_body (&loop
, &body1
);
3829 /* Translate the expression. */
3830 gfc_copy_loopinfo_to_se (&lse
, &loop
);
3832 gfc_conv_expr (&lse
, expr
);
3834 /* Form the expression of the temporary. */
3835 rse
.expr
= gfc_build_array_ref (tmp1
, count1
, NULL
);
3838 /* Use the scalar assignment. */
3839 rse
.string_length
= lse
.string_length
;
3840 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr
->ts
,
3841 expr
->expr_type
== EXPR_VARIABLE
, false);
3843 /* Form the mask expression according to the mask tree list. */
3846 wheremaskexpr
= gfc_build_array_ref (wheremask
, count3
, NULL
);
3848 wheremaskexpr
= fold_build1_loc (input_location
, TRUTH_NOT_EXPR
,
3849 TREE_TYPE (wheremaskexpr
),
3851 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
3853 build_empty_stmt (input_location
));
3856 gfc_add_expr_to_block (&body1
, tmp
);
3858 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (count1
),
3859 count1
, gfc_index_one_node
);
3860 gfc_add_modify (&body1
, count1
, tmp
);
3862 if (lss
== gfc_ss_terminator
)
3863 gfc_add_block_to_block (&block
, &body1
);
3866 /* Increment count3. */
3869 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
3870 gfc_array_index_type
,
3871 count3
, gfc_index_one_node
);
3872 gfc_add_modify (&body1
, count3
, tmp
);
3875 /* Generate the copying loops. */
3876 gfc_trans_scalarizing_loops (&loop
, &body1
);
3878 gfc_add_block_to_block (&block
, &loop
.pre
);
3879 gfc_add_block_to_block (&block
, &loop
.post
);
3881 gfc_cleanup_loop (&loop
);
3882 /* TODO: Reuse lss and rss when copying temp->lhs. Need to be careful
3883 as tree nodes in SS may not be valid in different scope. */
3886 tmp
= gfc_finish_block (&block
);
3891 /* Generate codes to copy rhs to the temporary. TMP1 is the address of
3892 temporary, LSS and RSS are formed in function compute_inner_temp_size(),
3893 and should not be freed. WHEREMASK is the conditional execution mask
3894 whose sense may be inverted by INVERT. */
3897 generate_loop_for_rhs_to_temp (gfc_expr
*expr2
, tree tmp1
, tree count3
,
3898 tree count1
, gfc_ss
*lss
, gfc_ss
*rss
,
3899 tree wheremask
, bool invert
)
3901 stmtblock_t block
, body1
;
3908 gfc_start_block (&block
);
3910 gfc_init_se (&rse
, NULL
);
3911 gfc_init_se (&lse
, NULL
);
3913 if (lss
== gfc_ss_terminator
)
3915 gfc_init_block (&body1
);
3916 gfc_conv_expr (&rse
, expr2
);
3917 lse
.expr
= gfc_build_array_ref (tmp1
, count1
, NULL
);
3921 /* Initialize the loop. */
3922 gfc_init_loopinfo (&loop
);
3924 /* We may need LSS to determine the shape of the expression. */
3925 gfc_add_ss_to_loop (&loop
, lss
);
3926 gfc_add_ss_to_loop (&loop
, rss
);
3928 gfc_conv_ss_startstride (&loop
);
3929 gfc_conv_loop_setup (&loop
, &expr2
->where
);
3931 gfc_mark_ss_chain_used (rss
, 1);
3932 /* Start the loop body. */
3933 gfc_start_scalarized_body (&loop
, &body1
);
3935 /* Translate the expression. */
3936 gfc_copy_loopinfo_to_se (&rse
, &loop
);
3938 gfc_conv_expr (&rse
, expr2
);
3940 /* Form the expression of the temporary. */
3941 lse
.expr
= gfc_build_array_ref (tmp1
, count1
, NULL
);
3944 /* Use the scalar assignment. */
3945 lse
.string_length
= rse
.string_length
;
3946 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr2
->ts
,
3947 expr2
->expr_type
== EXPR_VARIABLE
, false);
3949 /* Form the mask expression according to the mask tree list. */
3952 wheremaskexpr
= gfc_build_array_ref (wheremask
, count3
, NULL
);
3954 wheremaskexpr
= fold_build1_loc (input_location
, TRUTH_NOT_EXPR
,
3955 TREE_TYPE (wheremaskexpr
),
3957 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
3959 build_empty_stmt (input_location
));
3962 gfc_add_expr_to_block (&body1
, tmp
);
3964 if (lss
== gfc_ss_terminator
)
3966 gfc_add_block_to_block (&block
, &body1
);
3968 /* Increment count1. */
3969 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (count1
),
3970 count1
, gfc_index_one_node
);
3971 gfc_add_modify (&block
, count1
, tmp
);
3975 /* Increment count1. */
3976 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
3977 count1
, gfc_index_one_node
);
3978 gfc_add_modify (&body1
, count1
, tmp
);
3980 /* Increment count3. */
3983 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
3984 gfc_array_index_type
,
3985 count3
, gfc_index_one_node
);
3986 gfc_add_modify (&body1
, count3
, tmp
);
3989 /* Generate the copying loops. */
3990 gfc_trans_scalarizing_loops (&loop
, &body1
);
3992 gfc_add_block_to_block (&block
, &loop
.pre
);
3993 gfc_add_block_to_block (&block
, &loop
.post
);
3995 gfc_cleanup_loop (&loop
);
3996 /* TODO: Reuse lss and rss when copying temp->lhs. Need to be careful
3997 as tree nodes in SS may not be valid in different scope. */
4000 tmp
= gfc_finish_block (&block
);
4005 /* Calculate the size of temporary needed in the assignment inside forall.
4006 LSS and RSS are filled in this function. */
4009 compute_inner_temp_size (gfc_expr
*expr1
, gfc_expr
*expr2
,
4010 stmtblock_t
* pblock
,
4011 gfc_ss
**lss
, gfc_ss
**rss
)
4019 *lss
= gfc_walk_expr (expr1
);
4022 size
= gfc_index_one_node
;
4023 if (*lss
!= gfc_ss_terminator
)
4025 gfc_init_loopinfo (&loop
);
4027 /* Walk the RHS of the expression. */
4028 *rss
= gfc_walk_expr (expr2
);
4029 if (*rss
== gfc_ss_terminator
)
4030 /* The rhs is scalar. Add a ss for the expression. */
4031 *rss
= gfc_get_scalar_ss (gfc_ss_terminator
, expr2
);
4033 /* Associate the SS with the loop. */
4034 gfc_add_ss_to_loop (&loop
, *lss
);
4035 /* We don't actually need to add the rhs at this point, but it might
4036 make guessing the loop bounds a bit easier. */
4037 gfc_add_ss_to_loop (&loop
, *rss
);
4039 /* We only want the shape of the expression, not rest of the junk
4040 generated by the scalarizer. */
4041 loop
.array_parameter
= 1;
4043 /* Calculate the bounds of the scalarization. */
4044 save_flag
= gfc_option
.rtcheck
;
4045 gfc_option
.rtcheck
&= ~GFC_RTCHECK_BOUNDS
;
4046 gfc_conv_ss_startstride (&loop
);
4047 gfc_option
.rtcheck
= save_flag
;
4048 gfc_conv_loop_setup (&loop
, &expr2
->where
);
4050 /* Figure out how many elements we need. */
4051 for (i
= 0; i
< loop
.dimen
; i
++)
4053 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
,
4054 gfc_array_index_type
,
4055 gfc_index_one_node
, loop
.from
[i
]);
4056 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
4057 gfc_array_index_type
, tmp
, loop
.to
[i
]);
4058 size
= fold_build2_loc (input_location
, MULT_EXPR
,
4059 gfc_array_index_type
, size
, tmp
);
4061 gfc_add_block_to_block (pblock
, &loop
.pre
);
4062 size
= gfc_evaluate_now (size
, pblock
);
4063 gfc_add_block_to_block (pblock
, &loop
.post
);
4065 /* TODO: write a function that cleans up a loopinfo without freeing
4066 the SS chains. Currently a NOP. */
4073 /* Calculate the overall iterator number of the nested forall construct.
4074 This routine actually calculates the number of times the body of the
4075 nested forall specified by NESTED_FORALL_INFO is executed and multiplies
4076 that by the expression INNER_SIZE. The BLOCK argument specifies the
4077 block in which to calculate the result, and the optional INNER_SIZE_BODY
4078 argument contains any statements that need to executed (inside the loop)
4079 to initialize or calculate INNER_SIZE. */
4082 compute_overall_iter_number (forall_info
*nested_forall_info
, tree inner_size
,
4083 stmtblock_t
*inner_size_body
, stmtblock_t
*block
)
4085 forall_info
*forall_tmp
= nested_forall_info
;
4089 /* We can eliminate the innermost unconditional loops with constant
4091 if (INTEGER_CST_P (inner_size
))
4094 && !forall_tmp
->mask
4095 && INTEGER_CST_P (forall_tmp
->size
))
4097 inner_size
= fold_build2_loc (input_location
, MULT_EXPR
,
4098 gfc_array_index_type
,
4099 inner_size
, forall_tmp
->size
);
4100 forall_tmp
= forall_tmp
->prev_nest
;
4103 /* If there are no loops left, we have our constant result. */
4108 /* Otherwise, create a temporary variable to compute the result. */
4109 number
= gfc_create_var (gfc_array_index_type
, "num");
4110 gfc_add_modify (block
, number
, gfc_index_zero_node
);
4112 gfc_start_block (&body
);
4113 if (inner_size_body
)
4114 gfc_add_block_to_block (&body
, inner_size_body
);
4116 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
4117 gfc_array_index_type
, number
, inner_size
);
4120 gfc_add_modify (&body
, number
, tmp
);
4121 tmp
= gfc_finish_block (&body
);
4123 /* Generate loops. */
4124 if (forall_tmp
!= NULL
)
4125 tmp
= gfc_trans_nested_forall_loop (forall_tmp
, tmp
, 1);
4127 gfc_add_expr_to_block (block
, tmp
);
4133 /* Allocate temporary for forall construct. SIZE is the size of temporary
4134 needed. PTEMP1 is returned for space free. */
4137 allocate_temp_for_forall_nest_1 (tree type
, tree size
, stmtblock_t
* block
,
4144 unit
= fold_convert (gfc_array_index_type
, TYPE_SIZE_UNIT (type
));
4145 if (!integer_onep (unit
))
4146 bytesize
= fold_build2_loc (input_location
, MULT_EXPR
,
4147 gfc_array_index_type
, size
, unit
);
4152 tmp
= gfc_do_allocate (bytesize
, size
, ptemp1
, block
, type
);
4155 tmp
= build_fold_indirect_ref_loc (input_location
, tmp
);
4160 /* Allocate temporary for forall construct according to the information in
4161 nested_forall_info. INNER_SIZE is the size of temporary needed in the
4162 assignment inside forall. PTEMP1 is returned for space free. */
4165 allocate_temp_for_forall_nest (forall_info
* nested_forall_info
, tree type
,
4166 tree inner_size
, stmtblock_t
* inner_size_body
,
4167 stmtblock_t
* block
, tree
* ptemp1
)
4171 /* Calculate the total size of temporary needed in forall construct. */
4172 size
= compute_overall_iter_number (nested_forall_info
, inner_size
,
4173 inner_size_body
, block
);
4175 return allocate_temp_for_forall_nest_1 (type
, size
, block
, ptemp1
);
4179 /* Handle assignments inside forall which need temporary.
4181 forall (i=start:end:stride; maskexpr)
4184 (where e,f<i> are arbitrary expressions possibly involving i
4185 and there is a dependency between e<i> and f<i>)
4187 masktmp(:) = maskexpr(:)
4192 for (i = start; i <= end; i += stride)
4196 for (i = start; i <= end; i += stride)
4198 if (masktmp[maskindex++])
4199 tmp[count1++] = f<i>
4203 for (i = start; i <= end; i += stride)
4205 if (masktmp[maskindex++])
4206 e<i> = tmp[count1++]
4211 gfc_trans_assign_need_temp (gfc_expr
* expr1
, gfc_expr
* expr2
,
4212 tree wheremask
, bool invert
,
4213 forall_info
* nested_forall_info
,
4214 stmtblock_t
* block
)
4222 stmtblock_t inner_size_body
;
4224 /* Create vars. count1 is the current iterator number of the nested
4226 count1
= gfc_create_var (gfc_array_index_type
, "count1");
4228 /* Count is the wheremask index. */
4231 count
= gfc_create_var (gfc_array_index_type
, "count");
4232 gfc_add_modify (block
, count
, gfc_index_zero_node
);
4237 /* Initialize count1. */
4238 gfc_add_modify (block
, count1
, gfc_index_zero_node
);
4240 /* Calculate the size of temporary needed in the assignment. Return loop, lss
4241 and rss which are used in function generate_loop_for_rhs_to_temp(). */
4242 /* The type of LHS. Used in function allocate_temp_for_forall_nest */
4243 if (expr1
->ts
.type
== BT_CHARACTER
)
4246 if (expr1
->ref
&& expr1
->ref
->type
== REF_SUBSTRING
)
4249 gfc_init_se (&ssse
, NULL
);
4250 gfc_conv_expr (&ssse
, expr1
);
4251 type
= gfc_get_character_type_len (gfc_default_character_kind
,
4252 ssse
.string_length
);
4256 if (!expr1
->ts
.u
.cl
->backend_decl
)
4259 gcc_assert (expr1
->ts
.u
.cl
->length
);
4260 gfc_init_se (&tse
, NULL
);
4261 gfc_conv_expr (&tse
, expr1
->ts
.u
.cl
->length
);
4262 expr1
->ts
.u
.cl
->backend_decl
= tse
.expr
;
4264 type
= gfc_get_character_type_len (gfc_default_character_kind
,
4265 expr1
->ts
.u
.cl
->backend_decl
);
4269 type
= gfc_typenode_for_spec (&expr1
->ts
);
4271 gfc_init_block (&inner_size_body
);
4272 inner_size
= compute_inner_temp_size (expr1
, expr2
, &inner_size_body
,
4275 /* Allocate temporary for nested forall construct according to the
4276 information in nested_forall_info and inner_size. */
4277 tmp1
= allocate_temp_for_forall_nest (nested_forall_info
, type
, inner_size
,
4278 &inner_size_body
, block
, &ptemp1
);
4280 /* Generate codes to copy rhs to the temporary . */
4281 tmp
= generate_loop_for_rhs_to_temp (expr2
, tmp1
, count
, count1
, lss
, rss
,
4284 /* Generate body and loops according to the information in
4285 nested_forall_info. */
4286 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, tmp
, 1);
4287 gfc_add_expr_to_block (block
, tmp
);
4290 gfc_add_modify (block
, count1
, gfc_index_zero_node
);
4294 gfc_add_modify (block
, count
, gfc_index_zero_node
);
4296 /* TODO: Second call to compute_inner_temp_size to initialize lss and
4297 rss; there must be a better way. */
4298 inner_size
= compute_inner_temp_size (expr1
, expr2
, &inner_size_body
,
4301 /* Generate codes to copy the temporary to lhs. */
4302 tmp
= generate_loop_for_temp_to_lhs (expr1
, tmp1
, count
, count1
,
4306 /* Generate body and loops according to the information in
4307 nested_forall_info. */
4308 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, tmp
, 1);
4309 gfc_add_expr_to_block (block
, tmp
);
4313 /* Free the temporary. */
4314 tmp
= gfc_call_free (ptemp1
);
4315 gfc_add_expr_to_block (block
, tmp
);
4320 /* Translate pointer assignment inside FORALL which need temporary. */
4323 gfc_trans_pointer_assign_need_temp (gfc_expr
* expr1
, gfc_expr
* expr2
,
4324 forall_info
* nested_forall_info
,
4325 stmtblock_t
* block
)
4332 gfc_array_info
*info
;
4339 tree tmp
, tmp1
, ptemp1
;
4341 count
= gfc_create_var (gfc_array_index_type
, "count");
4342 gfc_add_modify (block
, count
, gfc_index_zero_node
);
4344 inner_size
= gfc_index_one_node
;
4345 lss
= gfc_walk_expr (expr1
);
4346 rss
= gfc_walk_expr (expr2
);
4347 if (lss
== gfc_ss_terminator
)
4349 type
= gfc_typenode_for_spec (&expr1
->ts
);
4350 type
= build_pointer_type (type
);
4352 /* Allocate temporary for nested forall construct according to the
4353 information in nested_forall_info and inner_size. */
4354 tmp1
= allocate_temp_for_forall_nest (nested_forall_info
, type
,
4355 inner_size
, NULL
, block
, &ptemp1
);
4356 gfc_start_block (&body
);
4357 gfc_init_se (&lse
, NULL
);
4358 lse
.expr
= gfc_build_array_ref (tmp1
, count
, NULL
);
4359 gfc_init_se (&rse
, NULL
);
4360 rse
.want_pointer
= 1;
4361 gfc_conv_expr (&rse
, expr2
);
4362 gfc_add_block_to_block (&body
, &rse
.pre
);
4363 gfc_add_modify (&body
, lse
.expr
,
4364 fold_convert (TREE_TYPE (lse
.expr
), rse
.expr
));
4365 gfc_add_block_to_block (&body
, &rse
.post
);
4367 /* Increment count. */
4368 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
4369 count
, gfc_index_one_node
);
4370 gfc_add_modify (&body
, count
, tmp
);
4372 tmp
= gfc_finish_block (&body
);
4374 /* Generate body and loops according to the information in
4375 nested_forall_info. */
4376 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, tmp
, 1);
4377 gfc_add_expr_to_block (block
, tmp
);
4380 gfc_add_modify (block
, count
, gfc_index_zero_node
);
4382 gfc_start_block (&body
);
4383 gfc_init_se (&lse
, NULL
);
4384 gfc_init_se (&rse
, NULL
);
4385 rse
.expr
= gfc_build_array_ref (tmp1
, count
, NULL
);
4386 lse
.want_pointer
= 1;
4387 gfc_conv_expr (&lse
, expr1
);
4388 gfc_add_block_to_block (&body
, &lse
.pre
);
4389 gfc_add_modify (&body
, lse
.expr
, rse
.expr
);
4390 gfc_add_block_to_block (&body
, &lse
.post
);
4391 /* Increment count. */
4392 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
4393 count
, gfc_index_one_node
);
4394 gfc_add_modify (&body
, count
, tmp
);
4395 tmp
= gfc_finish_block (&body
);
4397 /* Generate body and loops according to the information in
4398 nested_forall_info. */
4399 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, tmp
, 1);
4400 gfc_add_expr_to_block (block
, tmp
);
4404 gfc_init_loopinfo (&loop
);
4406 /* Associate the SS with the loop. */
4407 gfc_add_ss_to_loop (&loop
, rss
);
4409 /* Setup the scalarizing loops and bounds. */
4410 gfc_conv_ss_startstride (&loop
);
4412 gfc_conv_loop_setup (&loop
, &expr2
->where
);
4414 info
= &rss
->info
->data
.array
;
4415 desc
= info
->descriptor
;
4417 /* Make a new descriptor. */
4418 parmtype
= gfc_get_element_type (TREE_TYPE (desc
));
4419 parmtype
= gfc_get_array_type_bounds (parmtype
, loop
.dimen
, 0,
4420 loop
.from
, loop
.to
, 1,
4421 GFC_ARRAY_UNKNOWN
, true);
4423 /* Allocate temporary for nested forall construct. */
4424 tmp1
= allocate_temp_for_forall_nest (nested_forall_info
, parmtype
,
4425 inner_size
, NULL
, block
, &ptemp1
);
4426 gfc_start_block (&body
);
4427 gfc_init_se (&lse
, NULL
);
4428 lse
.expr
= gfc_build_array_ref (tmp1
, count
, NULL
);
4429 lse
.direct_byref
= 1;
4430 gfc_conv_expr_descriptor (&lse
, expr2
);
4432 gfc_add_block_to_block (&body
, &lse
.pre
);
4433 gfc_add_block_to_block (&body
, &lse
.post
);
4435 /* Increment count. */
4436 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
4437 count
, gfc_index_one_node
);
4438 gfc_add_modify (&body
, count
, tmp
);
4440 tmp
= gfc_finish_block (&body
);
4442 /* Generate body and loops according to the information in
4443 nested_forall_info. */
4444 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, tmp
, 1);
4445 gfc_add_expr_to_block (block
, tmp
);
4448 gfc_add_modify (block
, count
, gfc_index_zero_node
);
4450 parm
= gfc_build_array_ref (tmp1
, count
, NULL
);
4451 gfc_init_se (&lse
, NULL
);
4452 gfc_conv_expr_descriptor (&lse
, expr1
);
4453 gfc_add_modify (&lse
.pre
, lse
.expr
, parm
);
4454 gfc_start_block (&body
);
4455 gfc_add_block_to_block (&body
, &lse
.pre
);
4456 gfc_add_block_to_block (&body
, &lse
.post
);
4458 /* Increment count. */
4459 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
4460 count
, gfc_index_one_node
);
4461 gfc_add_modify (&body
, count
, tmp
);
4463 tmp
= gfc_finish_block (&body
);
4465 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, tmp
, 1);
4466 gfc_add_expr_to_block (block
, tmp
);
4468 /* Free the temporary. */
4471 tmp
= gfc_call_free (ptemp1
);
4472 gfc_add_expr_to_block (block
, tmp
);
4477 /* FORALL and WHERE statements are really nasty, especially when you nest
4478 them. All the rhs of a forall assignment must be evaluated before the
4479 actual assignments are performed. Presumably this also applies to all the
4480 assignments in an inner where statement. */
4482 /* Generate code for a FORALL statement. Any temporaries are allocated as a
4483 linear array, relying on the fact that we process in the same order in all
4486 forall (i=start:end:stride; maskexpr)
4490 (where e,f,g,h<i> are arbitrary expressions possibly involving i)
4492 count = ((end + 1 - start) / stride)
4493 masktmp(:) = maskexpr(:)
4496 for (i = start; i <= end; i += stride)
4498 if (masktmp[maskindex++])
4502 for (i = start; i <= end; i += stride)
4504 if (masktmp[maskindex++])
4508 Note that this code only works when there are no dependencies.
4509 Forall loop with array assignments and data dependencies are a real pain,
4510 because the size of the temporary cannot always be determined before the
4511 loop is executed. This problem is compounded by the presence of nested
4516 gfc_trans_forall_1 (gfc_code
* code
, forall_info
* nested_forall_info
)
4533 tree cycle_label
= NULL_TREE
;
4537 gfc_forall_iterator
*fa
;
4540 gfc_saved_var
*saved_vars
;
4541 iter_info
*this_forall
;
4545 /* Do nothing if the mask is false. */
4547 && code
->expr1
->expr_type
== EXPR_CONSTANT
4548 && !code
->expr1
->value
.logical
)
4549 return build_empty_stmt (input_location
);
4552 /* Count the FORALL index number. */
4553 for (fa
= code
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
4557 /* Allocate the space for var, start, end, step, varexpr. */
4558 var
= XCNEWVEC (tree
, nvar
);
4559 start
= XCNEWVEC (tree
, nvar
);
4560 end
= XCNEWVEC (tree
, nvar
);
4561 step
= XCNEWVEC (tree
, nvar
);
4562 varexpr
= XCNEWVEC (gfc_expr
*, nvar
);
4563 saved_vars
= XCNEWVEC (gfc_saved_var
, nvar
);
4565 /* Allocate the space for info. */
4566 info
= XCNEW (forall_info
);
4568 gfc_start_block (&pre
);
4569 gfc_init_block (&post
);
4570 gfc_init_block (&block
);
4573 for (fa
= code
->ext
.forall_iterator
; fa
; fa
= fa
->next
)
4575 gfc_symbol
*sym
= fa
->var
->symtree
->n
.sym
;
4577 /* Allocate space for this_forall. */
4578 this_forall
= XCNEW (iter_info
);
4580 /* Create a temporary variable for the FORALL index. */
4581 tmp
= gfc_typenode_for_spec (&sym
->ts
);
4582 var
[n
] = gfc_create_var (tmp
, sym
->name
);
4583 gfc_shadow_sym (sym
, var
[n
], &saved_vars
[n
]);
4585 /* Record it in this_forall. */
4586 this_forall
->var
= var
[n
];
4588 /* Replace the index symbol's backend_decl with the temporary decl. */
4589 sym
->backend_decl
= var
[n
];
4591 /* Work out the start, end and stride for the loop. */
4592 gfc_init_se (&se
, NULL
);
4593 gfc_conv_expr_val (&se
, fa
->start
);
4594 /* Record it in this_forall. */
4595 this_forall
->start
= se
.expr
;
4596 gfc_add_block_to_block (&block
, &se
.pre
);
4599 gfc_init_se (&se
, NULL
);
4600 gfc_conv_expr_val (&se
, fa
->end
);
4601 /* Record it in this_forall. */
4602 this_forall
->end
= se
.expr
;
4603 gfc_make_safe_expr (&se
);
4604 gfc_add_block_to_block (&block
, &se
.pre
);
4607 gfc_init_se (&se
, NULL
);
4608 gfc_conv_expr_val (&se
, fa
->stride
);
4609 /* Record it in this_forall. */
4610 this_forall
->step
= se
.expr
;
4611 gfc_make_safe_expr (&se
);
4612 gfc_add_block_to_block (&block
, &se
.pre
);
4615 /* Set the NEXT field of this_forall to NULL. */
4616 this_forall
->next
= NULL
;
4617 /* Link this_forall to the info construct. */
4618 if (info
->this_loop
)
4620 iter_info
*iter_tmp
= info
->this_loop
;
4621 while (iter_tmp
->next
!= NULL
)
4622 iter_tmp
= iter_tmp
->next
;
4623 iter_tmp
->next
= this_forall
;
4626 info
->this_loop
= this_forall
;
4632 /* Calculate the size needed for the current forall level. */
4633 size
= gfc_index_one_node
;
4634 for (n
= 0; n
< nvar
; n
++)
4636 /* size = (end + step - start) / step. */
4637 tmp
= fold_build2_loc (input_location
, MINUS_EXPR
, TREE_TYPE (start
[n
]),
4639 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, TREE_TYPE (end
[n
]),
4641 tmp
= fold_build2_loc (input_location
, FLOOR_DIV_EXPR
, TREE_TYPE (tmp
),
4643 tmp
= convert (gfc_array_index_type
, tmp
);
4645 size
= fold_build2_loc (input_location
, MULT_EXPR
, gfc_array_index_type
,
4649 /* Record the nvar and size of current forall level. */
4655 /* If the mask is .true., consider the FORALL unconditional. */
4656 if (code
->expr1
->expr_type
== EXPR_CONSTANT
4657 && code
->expr1
->value
.logical
)
4665 /* First we need to allocate the mask. */
4668 /* As the mask array can be very big, prefer compact boolean types. */
4669 tree mask_type
= gfc_get_logical_type (gfc_logical_kinds
[0].kind
);
4670 mask
= allocate_temp_for_forall_nest (nested_forall_info
, mask_type
,
4671 size
, NULL
, &block
, &pmask
);
4672 maskindex
= gfc_create_var_np (gfc_array_index_type
, "mi");
4674 /* Record them in the info structure. */
4675 info
->maskindex
= maskindex
;
4680 /* No mask was specified. */
4681 maskindex
= NULL_TREE
;
4682 mask
= pmask
= NULL_TREE
;
4685 /* Link the current forall level to nested_forall_info. */
4686 info
->prev_nest
= nested_forall_info
;
4687 nested_forall_info
= info
;
4689 /* Copy the mask into a temporary variable if required.
4690 For now we assume a mask temporary is needed. */
4693 /* As the mask array can be very big, prefer compact boolean types. */
4694 tree mask_type
= gfc_get_logical_type (gfc_logical_kinds
[0].kind
);
4696 gfc_add_modify (&block
, maskindex
, gfc_index_zero_node
);
4698 /* Start of mask assignment loop body. */
4699 gfc_start_block (&body
);
4701 /* Evaluate the mask expression. */
4702 gfc_init_se (&se
, NULL
);
4703 gfc_conv_expr_val (&se
, code
->expr1
);
4704 gfc_add_block_to_block (&body
, &se
.pre
);
4706 /* Store the mask. */
4707 se
.expr
= convert (mask_type
, se
.expr
);
4709 tmp
= gfc_build_array_ref (mask
, maskindex
, NULL
);
4710 gfc_add_modify (&body
, tmp
, se
.expr
);
4712 /* Advance to the next mask element. */
4713 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
4714 maskindex
, gfc_index_one_node
);
4715 gfc_add_modify (&body
, maskindex
, tmp
);
4717 /* Generate the loops. */
4718 tmp
= gfc_finish_block (&body
);
4719 tmp
= gfc_trans_nested_forall_loop (info
, tmp
, 0);
4720 gfc_add_expr_to_block (&block
, tmp
);
4723 if (code
->op
== EXEC_DO_CONCURRENT
)
4725 gfc_init_block (&body
);
4726 cycle_label
= gfc_build_label_decl (NULL_TREE
);
4727 code
->cycle_label
= cycle_label
;
4728 tmp
= gfc_trans_code (code
->block
->next
);
4729 gfc_add_expr_to_block (&body
, tmp
);
4731 if (TREE_USED (cycle_label
))
4733 tmp
= build1_v (LABEL_EXPR
, cycle_label
);
4734 gfc_add_expr_to_block (&body
, tmp
);
4737 tmp
= gfc_finish_block (&body
);
4738 nested_forall_info
->do_concurrent
= true;
4739 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, tmp
, 1);
4740 gfc_add_expr_to_block (&block
, tmp
);
4744 c
= code
->block
->next
;
4746 /* TODO: loop merging in FORALL statements. */
4747 /* Now that we've got a copy of the mask, generate the assignment loops. */
4753 /* A scalar or array assignment. DO the simple check for
4754 lhs to rhs dependencies. These make a temporary for the
4755 rhs and form a second forall block to copy to variable. */
4756 need_temp
= check_forall_dependencies(c
, &pre
, &post
);
4758 /* Temporaries due to array assignment data dependencies introduce
4759 no end of problems. */
4760 if (need_temp
|| flag_test_forall_temp
)
4761 gfc_trans_assign_need_temp (c
->expr1
, c
->expr2
, NULL
, false,
4762 nested_forall_info
, &block
);
4765 /* Use the normal assignment copying routines. */
4766 assign
= gfc_trans_assignment (c
->expr1
, c
->expr2
, false, true);
4768 /* Generate body and loops. */
4769 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
,
4771 gfc_add_expr_to_block (&block
, tmp
);
4774 /* Cleanup any temporary symtrees that have been made to deal
4775 with dependencies. */
4777 cleanup_forall_symtrees (c
);
4782 /* Translate WHERE or WHERE construct nested in FORALL. */
4783 gfc_trans_where_2 (c
, NULL
, false, nested_forall_info
, &block
);
4786 /* Pointer assignment inside FORALL. */
4787 case EXEC_POINTER_ASSIGN
:
4788 need_temp
= gfc_check_dependency (c
->expr1
, c
->expr2
, 0);
4789 /* Avoid cases where a temporary would never be needed and where
4790 the temp code is guaranteed to fail. */
4792 || (flag_test_forall_temp
4793 && c
->expr2
->expr_type
!= EXPR_CONSTANT
4794 && c
->expr2
->expr_type
!= EXPR_NULL
))
4795 gfc_trans_pointer_assign_need_temp (c
->expr1
, c
->expr2
,
4796 nested_forall_info
, &block
);
4799 /* Use the normal assignment copying routines. */
4800 assign
= gfc_trans_pointer_assignment (c
->expr1
, c
->expr2
);
4802 /* Generate body and loops. */
4803 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
,
4805 gfc_add_expr_to_block (&block
, tmp
);
4810 tmp
= gfc_trans_forall_1 (c
, nested_forall_info
);
4811 gfc_add_expr_to_block (&block
, tmp
);
4814 /* Explicit subroutine calls are prevented by the frontend but interface
4815 assignments can legitimately produce them. */
4816 case EXEC_ASSIGN_CALL
:
4817 assign
= gfc_trans_call (c
, true, NULL_TREE
, NULL_TREE
, false);
4818 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
, assign
, 1);
4819 gfc_add_expr_to_block (&block
, tmp
);
4830 /* Restore the original index variables. */
4831 for (fa
= code
->ext
.forall_iterator
, n
= 0; fa
; fa
= fa
->next
, n
++)
4832 gfc_restore_sym (fa
->var
->symtree
->n
.sym
, &saved_vars
[n
]);
4834 /* Free the space for var, start, end, step, varexpr. */
4842 for (this_forall
= info
->this_loop
; this_forall
;)
4844 iter_info
*next
= this_forall
->next
;
4849 /* Free the space for this forall_info. */
4854 /* Free the temporary for the mask. */
4855 tmp
= gfc_call_free (pmask
);
4856 gfc_add_expr_to_block (&block
, tmp
);
4859 pushdecl (maskindex
);
4861 gfc_add_block_to_block (&pre
, &block
);
4862 gfc_add_block_to_block (&pre
, &post
);
4864 return gfc_finish_block (&pre
);
4868 /* Translate the FORALL statement or construct. */
4870 tree
gfc_trans_forall (gfc_code
* code
)
4872 return gfc_trans_forall_1 (code
, NULL
);
4876 /* Translate the DO CONCURRENT construct. */
4878 tree
gfc_trans_do_concurrent (gfc_code
* code
)
4880 return gfc_trans_forall_1 (code
, NULL
);
4884 /* Evaluate the WHERE mask expression, copy its value to a temporary.
4885 If the WHERE construct is nested in FORALL, compute the overall temporary
4886 needed by the WHERE mask expression multiplied by the iterator number of
4888 ME is the WHERE mask expression.
4889 MASK is the current execution mask upon input, whose sense may or may
4890 not be inverted as specified by the INVERT argument.
4891 CMASK is the updated execution mask on output, or NULL if not required.
4892 PMASK is the pending execution mask on output, or NULL if not required.
4893 BLOCK is the block in which to place the condition evaluation loops. */
4896 gfc_evaluate_where_mask (gfc_expr
* me
, forall_info
* nested_forall_info
,
4897 tree mask
, bool invert
, tree cmask
, tree pmask
,
4898 tree mask_type
, stmtblock_t
* block
)
4903 stmtblock_t body
, body1
;
4904 tree count
, cond
, mtmp
;
4907 gfc_init_loopinfo (&loop
);
4909 lss
= gfc_walk_expr (me
);
4910 rss
= gfc_walk_expr (me
);
4912 /* Variable to index the temporary. */
4913 count
= gfc_create_var (gfc_array_index_type
, "count");
4914 /* Initialize count. */
4915 gfc_add_modify (block
, count
, gfc_index_zero_node
);
4917 gfc_start_block (&body
);
4919 gfc_init_se (&rse
, NULL
);
4920 gfc_init_se (&lse
, NULL
);
4922 if (lss
== gfc_ss_terminator
)
4924 gfc_init_block (&body1
);
4928 /* Initialize the loop. */
4929 gfc_init_loopinfo (&loop
);
4931 /* We may need LSS to determine the shape of the expression. */
4932 gfc_add_ss_to_loop (&loop
, lss
);
4933 gfc_add_ss_to_loop (&loop
, rss
);
4935 gfc_conv_ss_startstride (&loop
);
4936 gfc_conv_loop_setup (&loop
, &me
->where
);
4938 gfc_mark_ss_chain_used (rss
, 1);
4939 /* Start the loop body. */
4940 gfc_start_scalarized_body (&loop
, &body1
);
4942 /* Translate the expression. */
4943 gfc_copy_loopinfo_to_se (&rse
, &loop
);
4945 gfc_conv_expr (&rse
, me
);
4948 /* Variable to evaluate mask condition. */
4949 cond
= gfc_create_var (mask_type
, "cond");
4950 if (mask
&& (cmask
|| pmask
))
4951 mtmp
= gfc_create_var (mask_type
, "mask");
4952 else mtmp
= NULL_TREE
;
4954 gfc_add_block_to_block (&body1
, &lse
.pre
);
4955 gfc_add_block_to_block (&body1
, &rse
.pre
);
4957 gfc_add_modify (&body1
, cond
, fold_convert (mask_type
, rse
.expr
));
4959 if (mask
&& (cmask
|| pmask
))
4961 tmp
= gfc_build_array_ref (mask
, count
, NULL
);
4963 tmp
= fold_build1_loc (input_location
, TRUTH_NOT_EXPR
, mask_type
, tmp
);
4964 gfc_add_modify (&body1
, mtmp
, tmp
);
4969 tmp1
= gfc_build_array_ref (cmask
, count
, NULL
);
4972 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
, mask_type
,
4974 gfc_add_modify (&body1
, tmp1
, tmp
);
4979 tmp1
= gfc_build_array_ref (pmask
, count
, NULL
);
4980 tmp
= fold_build1_loc (input_location
, TRUTH_NOT_EXPR
, mask_type
, cond
);
4982 tmp
= fold_build2_loc (input_location
, TRUTH_AND_EXPR
, mask_type
, mtmp
,
4984 gfc_add_modify (&body1
, tmp1
, tmp
);
4987 gfc_add_block_to_block (&body1
, &lse
.post
);
4988 gfc_add_block_to_block (&body1
, &rse
.post
);
4990 if (lss
== gfc_ss_terminator
)
4992 gfc_add_block_to_block (&body
, &body1
);
4996 /* Increment count. */
4997 tmp1
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
4998 count
, gfc_index_one_node
);
4999 gfc_add_modify (&body1
, count
, tmp1
);
5001 /* Generate the copying loops. */
5002 gfc_trans_scalarizing_loops (&loop
, &body1
);
5004 gfc_add_block_to_block (&body
, &loop
.pre
);
5005 gfc_add_block_to_block (&body
, &loop
.post
);
5007 gfc_cleanup_loop (&loop
);
5008 /* TODO: Reuse lss and rss when copying temp->lhs. Need to be careful
5009 as tree nodes in SS may not be valid in different scope. */
5012 tmp1
= gfc_finish_block (&body
);
5013 /* If the WHERE construct is inside FORALL, fill the full temporary. */
5014 if (nested_forall_info
!= NULL
)
5015 tmp1
= gfc_trans_nested_forall_loop (nested_forall_info
, tmp1
, 1);
5017 gfc_add_expr_to_block (block
, tmp1
);
5021 /* Translate an assignment statement in a WHERE statement or construct
5022 statement. The MASK expression is used to control which elements
5023 of EXPR1 shall be assigned. The sense of MASK is specified by
5027 gfc_trans_where_assign (gfc_expr
*expr1
, gfc_expr
*expr2
,
5028 tree mask
, bool invert
,
5029 tree count1
, tree count2
,
5035 gfc_ss
*lss_section
;
5042 tree index
, maskexpr
;
5044 /* A defined assignment. */
5045 if (cnext
&& cnext
->resolved_sym
)
5046 return gfc_trans_call (cnext
, true, mask
, count1
, invert
);
5049 /* TODO: handle this special case.
5050 Special case a single function returning an array. */
5051 if (expr2
->expr_type
== EXPR_FUNCTION
&& expr2
->rank
> 0)
5053 tmp
= gfc_trans_arrayfunc_assign (expr1
, expr2
);
5059 /* Assignment of the form lhs = rhs. */
5060 gfc_start_block (&block
);
5062 gfc_init_se (&lse
, NULL
);
5063 gfc_init_se (&rse
, NULL
);
5066 lss
= gfc_walk_expr (expr1
);
5069 /* In each where-assign-stmt, the mask-expr and the variable being
5070 defined shall be arrays of the same shape. */
5071 gcc_assert (lss
!= gfc_ss_terminator
);
5073 /* The assignment needs scalarization. */
5076 /* Find a non-scalar SS from the lhs. */
5077 while (lss_section
!= gfc_ss_terminator
5078 && lss_section
->info
->type
!= GFC_SS_SECTION
)
5079 lss_section
= lss_section
->next
;
5081 gcc_assert (lss_section
!= gfc_ss_terminator
);
5083 /* Initialize the scalarizer. */
5084 gfc_init_loopinfo (&loop
);
5087 rss
= gfc_walk_expr (expr2
);
5088 if (rss
== gfc_ss_terminator
)
5090 /* The rhs is scalar. Add a ss for the expression. */
5091 rss
= gfc_get_scalar_ss (gfc_ss_terminator
, expr2
);
5092 rss
->info
->where
= 1;
5095 /* Associate the SS with the loop. */
5096 gfc_add_ss_to_loop (&loop
, lss
);
5097 gfc_add_ss_to_loop (&loop
, rss
);
5099 /* Calculate the bounds of the scalarization. */
5100 gfc_conv_ss_startstride (&loop
);
5102 /* Resolve any data dependencies in the statement. */
5103 gfc_conv_resolve_dependencies (&loop
, lss_section
, rss
);
5105 /* Setup the scalarizing loops. */
5106 gfc_conv_loop_setup (&loop
, &expr2
->where
);
5108 /* Setup the gfc_se structures. */
5109 gfc_copy_loopinfo_to_se (&lse
, &loop
);
5110 gfc_copy_loopinfo_to_se (&rse
, &loop
);
5113 gfc_mark_ss_chain_used (rss
, 1);
5114 if (loop
.temp_ss
== NULL
)
5117 gfc_mark_ss_chain_used (lss
, 1);
5121 lse
.ss
= loop
.temp_ss
;
5122 gfc_mark_ss_chain_used (lss
, 3);
5123 gfc_mark_ss_chain_used (loop
.temp_ss
, 3);
5126 /* Start the scalarized loop body. */
5127 gfc_start_scalarized_body (&loop
, &body
);
5129 /* Translate the expression. */
5130 gfc_conv_expr (&rse
, expr2
);
5131 if (lss
!= gfc_ss_terminator
&& loop
.temp_ss
!= NULL
)
5132 gfc_conv_tmp_array_ref (&lse
);
5134 gfc_conv_expr (&lse
, expr1
);
5136 /* Form the mask expression according to the mask. */
5138 maskexpr
= gfc_build_array_ref (mask
, index
, NULL
);
5140 maskexpr
= fold_build1_loc (input_location
, TRUTH_NOT_EXPR
,
5141 TREE_TYPE (maskexpr
), maskexpr
);
5143 /* Use the scalar assignment as is. */
5144 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
,
5145 false, loop
.temp_ss
== NULL
);
5147 tmp
= build3_v (COND_EXPR
, maskexpr
, tmp
, build_empty_stmt (input_location
));
5149 gfc_add_expr_to_block (&body
, tmp
);
5151 if (lss
== gfc_ss_terminator
)
5153 /* Increment count1. */
5154 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
, gfc_array_index_type
,
5155 count1
, gfc_index_one_node
);
5156 gfc_add_modify (&body
, count1
, tmp
);
5158 /* Use the scalar assignment as is. */
5159 gfc_add_block_to_block (&block
, &body
);
5163 gcc_assert (lse
.ss
== gfc_ss_terminator
5164 && rse
.ss
== gfc_ss_terminator
);
5166 if (loop
.temp_ss
!= NULL
)
5168 /* Increment count1 before finish the main body of a scalarized
5170 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
5171 gfc_array_index_type
, count1
, gfc_index_one_node
);
5172 gfc_add_modify (&body
, count1
, tmp
);
5173 gfc_trans_scalarized_loop_boundary (&loop
, &body
);
5175 /* We need to copy the temporary to the actual lhs. */
5176 gfc_init_se (&lse
, NULL
);
5177 gfc_init_se (&rse
, NULL
);
5178 gfc_copy_loopinfo_to_se (&lse
, &loop
);
5179 gfc_copy_loopinfo_to_se (&rse
, &loop
);
5181 rse
.ss
= loop
.temp_ss
;
5184 gfc_conv_tmp_array_ref (&rse
);
5185 gfc_conv_expr (&lse
, expr1
);
5187 gcc_assert (lse
.ss
== gfc_ss_terminator
5188 && rse
.ss
== gfc_ss_terminator
);
5190 /* Form the mask expression according to the mask tree list. */
5192 maskexpr
= gfc_build_array_ref (mask
, index
, NULL
);
5194 maskexpr
= fold_build1_loc (input_location
, TRUTH_NOT_EXPR
,
5195 TREE_TYPE (maskexpr
), maskexpr
);
5197 /* Use the scalar assignment as is. */
5198 tmp
= gfc_trans_scalar_assign (&lse
, &rse
, expr1
->ts
, false, true);
5199 tmp
= build3_v (COND_EXPR
, maskexpr
, tmp
,
5200 build_empty_stmt (input_location
));
5201 gfc_add_expr_to_block (&body
, tmp
);
5203 /* Increment count2. */
5204 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
5205 gfc_array_index_type
, count2
,
5206 gfc_index_one_node
);
5207 gfc_add_modify (&body
, count2
, tmp
);
5211 /* Increment count1. */
5212 tmp
= fold_build2_loc (input_location
, PLUS_EXPR
,
5213 gfc_array_index_type
, count1
,
5214 gfc_index_one_node
);
5215 gfc_add_modify (&body
, count1
, tmp
);
5218 /* Generate the copying loops. */
5219 gfc_trans_scalarizing_loops (&loop
, &body
);
5221 /* Wrap the whole thing up. */
5222 gfc_add_block_to_block (&block
, &loop
.pre
);
5223 gfc_add_block_to_block (&block
, &loop
.post
);
5224 gfc_cleanup_loop (&loop
);
5227 return gfc_finish_block (&block
);
5231 /* Translate the WHERE construct or statement.
5232 This function can be called iteratively to translate the nested WHERE
5233 construct or statement.
5234 MASK is the control mask. */
5237 gfc_trans_where_2 (gfc_code
* code
, tree mask
, bool invert
,
5238 forall_info
* nested_forall_info
, stmtblock_t
* block
)
5240 stmtblock_t inner_size_body
;
5241 tree inner_size
, size
;
5250 tree count1
, count2
;
5254 tree pcmask
= NULL_TREE
;
5255 tree ppmask
= NULL_TREE
;
5256 tree cmask
= NULL_TREE
;
5257 tree pmask
= NULL_TREE
;
5258 gfc_actual_arglist
*arg
;
5260 /* the WHERE statement or the WHERE construct statement. */
5261 cblock
= code
->block
;
5263 /* As the mask array can be very big, prefer compact boolean types. */
5264 mask_type
= gfc_get_logical_type (gfc_logical_kinds
[0].kind
);
5266 /* Determine which temporary masks are needed. */
5269 /* One clause: No ELSEWHEREs. */
5270 need_cmask
= (cblock
->next
!= 0);
5273 else if (cblock
->block
->block
)
5275 /* Three or more clauses: Conditional ELSEWHEREs. */
5279 else if (cblock
->next
)
5281 /* Two clauses, the first non-empty. */
5283 need_pmask
= (mask
!= NULL_TREE
5284 && cblock
->block
->next
!= 0);
5286 else if (!cblock
->block
->next
)
5288 /* Two clauses, both empty. */
5292 /* Two clauses, the first empty, the second non-empty. */
5295 need_cmask
= (cblock
->block
->expr1
!= 0);
5304 if (need_cmask
|| need_pmask
)
5306 /* Calculate the size of temporary needed by the mask-expr. */
5307 gfc_init_block (&inner_size_body
);
5308 inner_size
= compute_inner_temp_size (cblock
->expr1
, cblock
->expr1
,
5309 &inner_size_body
, &lss
, &rss
);
5311 gfc_free_ss_chain (lss
);
5312 gfc_free_ss_chain (rss
);
5314 /* Calculate the total size of temporary needed. */
5315 size
= compute_overall_iter_number (nested_forall_info
, inner_size
,
5316 &inner_size_body
, block
);
5318 /* Check whether the size is negative. */
5319 cond
= fold_build2_loc (input_location
, LE_EXPR
, logical_type_node
, size
,
5320 gfc_index_zero_node
);
5321 size
= fold_build3_loc (input_location
, COND_EXPR
, gfc_array_index_type
,
5322 cond
, gfc_index_zero_node
, size
);
5323 size
= gfc_evaluate_now (size
, block
);
5325 /* Allocate temporary for WHERE mask if needed. */
5327 cmask
= allocate_temp_for_forall_nest_1 (mask_type
, size
, block
,
5330 /* Allocate temporary for !mask if needed. */
5332 pmask
= allocate_temp_for_forall_nest_1 (mask_type
, size
, block
,
5338 /* Each time around this loop, the where clause is conditional
5339 on the value of mask and invert, which are updated at the
5340 bottom of the loop. */
5342 /* Has mask-expr. */
5345 /* Ensure that the WHERE mask will be evaluated exactly once.
5346 If there are no statements in this WHERE/ELSEWHERE clause,
5347 then we don't need to update the control mask (cmask).
5348 If this is the last clause of the WHERE construct, then
5349 we don't need to update the pending control mask (pmask). */
5351 gfc_evaluate_where_mask (cblock
->expr1
, nested_forall_info
,
5353 cblock
->next
? cmask
: NULL_TREE
,
5354 cblock
->block
? pmask
: NULL_TREE
,
5357 gfc_evaluate_where_mask (cblock
->expr1
, nested_forall_info
,
5359 (cblock
->next
|| cblock
->block
)
5360 ? cmask
: NULL_TREE
,
5361 NULL_TREE
, mask_type
, block
);
5365 /* It's a final elsewhere-stmt. No mask-expr is present. */
5369 /* The body of this where clause are controlled by cmask with
5370 sense specified by invert. */
5372 /* Get the assignment statement of a WHERE statement, or the first
5373 statement in where-body-construct of a WHERE construct. */
5374 cnext
= cblock
->next
;
5379 /* WHERE assignment statement. */
5380 case EXEC_ASSIGN_CALL
:
5382 arg
= cnext
->ext
.actual
;
5383 expr1
= expr2
= NULL
;
5384 for (; arg
; arg
= arg
->next
)
5396 expr1
= cnext
->expr1
;
5397 expr2
= cnext
->expr2
;
5399 if (nested_forall_info
!= NULL
)
5401 need_temp
= gfc_check_dependency (expr1
, expr2
, 0);
5402 if ((need_temp
|| flag_test_forall_temp
)
5403 && cnext
->op
!= EXEC_ASSIGN_CALL
)
5404 gfc_trans_assign_need_temp (expr1
, expr2
,
5406 nested_forall_info
, block
);
5409 /* Variables to control maskexpr. */
5410 count1
= gfc_create_var (gfc_array_index_type
, "count1");
5411 count2
= gfc_create_var (gfc_array_index_type
, "count2");
5412 gfc_add_modify (block
, count1
, gfc_index_zero_node
);
5413 gfc_add_modify (block
, count2
, gfc_index_zero_node
);
5415 tmp
= gfc_trans_where_assign (expr1
, expr2
,
5420 tmp
= gfc_trans_nested_forall_loop (nested_forall_info
,
5422 gfc_add_expr_to_block (block
, tmp
);
5427 /* Variables to control maskexpr. */
5428 count1
= gfc_create_var (gfc_array_index_type
, "count1");
5429 count2
= gfc_create_var (gfc_array_index_type
, "count2");
5430 gfc_add_modify (block
, count1
, gfc_index_zero_node
);
5431 gfc_add_modify (block
, count2
, gfc_index_zero_node
);
5433 tmp
= gfc_trans_where_assign (expr1
, expr2
,
5437 gfc_add_expr_to_block (block
, tmp
);
5442 /* WHERE or WHERE construct is part of a where-body-construct. */
5444 gfc_trans_where_2 (cnext
, cmask
, invert
,
5445 nested_forall_info
, block
);
5452 /* The next statement within the same where-body-construct. */
5453 cnext
= cnext
->next
;
5455 /* The next masked-elsewhere-stmt, elsewhere-stmt, or end-where-stmt. */
5456 cblock
= cblock
->block
;
5457 if (mask
== NULL_TREE
)
5459 /* If we're the initial WHERE, we can simply invert the sense
5460 of the current mask to obtain the "mask" for the remaining
5467 /* Otherwise, for nested WHERE's we need to use the pending mask. */
5473 /* If we allocated a pending mask array, deallocate it now. */
5476 tmp
= gfc_call_free (ppmask
);
5477 gfc_add_expr_to_block (block
, tmp
);
5480 /* If we allocated a current mask array, deallocate it now. */
5483 tmp
= gfc_call_free (pcmask
);
5484 gfc_add_expr_to_block (block
, tmp
);
5488 /* Translate a simple WHERE construct or statement without dependencies.
5489 CBLOCK is the "then" clause of the WHERE statement, where CBLOCK->EXPR
5490 is the mask condition, and EBLOCK if non-NULL is the "else" clause.
5491 Currently both CBLOCK and EBLOCK are restricted to single assignments. */
5494 gfc_trans_where_3 (gfc_code
* cblock
, gfc_code
* eblock
)
5496 stmtblock_t block
, body
;
5497 gfc_expr
*cond
, *tdst
, *tsrc
, *edst
, *esrc
;
5498 tree tmp
, cexpr
, tstmt
, estmt
;
5499 gfc_ss
*css
, *tdss
, *tsss
;
5500 gfc_se cse
, tdse
, tsse
, edse
, esse
;
5504 bool maybe_workshare
= false;
5506 /* Allow the scalarizer to workshare simple where loops. */
5507 if ((ompws_flags
& (OMPWS_WORKSHARE_FLAG
| OMPWS_SCALARIZER_BODY
))
5508 == OMPWS_WORKSHARE_FLAG
)
5510 maybe_workshare
= true;
5511 ompws_flags
|= OMPWS_SCALARIZER_WS
| OMPWS_SCALARIZER_BODY
;
5514 cond
= cblock
->expr1
;
5515 tdst
= cblock
->next
->expr1
;
5516 tsrc
= cblock
->next
->expr2
;
5517 edst
= eblock
? eblock
->next
->expr1
: NULL
;
5518 esrc
= eblock
? eblock
->next
->expr2
: NULL
;
5520 gfc_start_block (&block
);
5521 gfc_init_loopinfo (&loop
);
5523 /* Handle the condition. */
5524 gfc_init_se (&cse
, NULL
);
5525 css
= gfc_walk_expr (cond
);
5526 gfc_add_ss_to_loop (&loop
, css
);
5528 /* Handle the then-clause. */
5529 gfc_init_se (&tdse
, NULL
);
5530 gfc_init_se (&tsse
, NULL
);
5531 tdss
= gfc_walk_expr (tdst
);
5532 tsss
= gfc_walk_expr (tsrc
);
5533 if (tsss
== gfc_ss_terminator
)
5535 tsss
= gfc_get_scalar_ss (gfc_ss_terminator
, tsrc
);
5536 tsss
->info
->where
= 1;
5538 gfc_add_ss_to_loop (&loop
, tdss
);
5539 gfc_add_ss_to_loop (&loop
, tsss
);
5543 /* Handle the else clause. */
5544 gfc_init_se (&edse
, NULL
);
5545 gfc_init_se (&esse
, NULL
);
5546 edss
= gfc_walk_expr (edst
);
5547 esss
= gfc_walk_expr (esrc
);
5548 if (esss
== gfc_ss_terminator
)
5550 esss
= gfc_get_scalar_ss (gfc_ss_terminator
, esrc
);
5551 esss
->info
->where
= 1;
5553 gfc_add_ss_to_loop (&loop
, edss
);
5554 gfc_add_ss_to_loop (&loop
, esss
);
5557 gfc_conv_ss_startstride (&loop
);
5558 gfc_conv_loop_setup (&loop
, &tdst
->where
);
5560 gfc_mark_ss_chain_used (css
, 1);
5561 gfc_mark_ss_chain_used (tdss
, 1);
5562 gfc_mark_ss_chain_used (tsss
, 1);
5565 gfc_mark_ss_chain_used (edss
, 1);
5566 gfc_mark_ss_chain_used (esss
, 1);
5569 gfc_start_scalarized_body (&loop
, &body
);
5571 gfc_copy_loopinfo_to_se (&cse
, &loop
);
5572 gfc_copy_loopinfo_to_se (&tdse
, &loop
);
5573 gfc_copy_loopinfo_to_se (&tsse
, &loop
);
5579 gfc_copy_loopinfo_to_se (&edse
, &loop
);
5580 gfc_copy_loopinfo_to_se (&esse
, &loop
);
5585 gfc_conv_expr (&cse
, cond
);
5586 gfc_add_block_to_block (&body
, &cse
.pre
);
5589 gfc_conv_expr (&tsse
, tsrc
);
5590 if (tdss
!= gfc_ss_terminator
&& loop
.temp_ss
!= NULL
)
5591 gfc_conv_tmp_array_ref (&tdse
);
5593 gfc_conv_expr (&tdse
, tdst
);
5597 gfc_conv_expr (&esse
, esrc
);
5598 if (edss
!= gfc_ss_terminator
&& loop
.temp_ss
!= NULL
)
5599 gfc_conv_tmp_array_ref (&edse
);
5601 gfc_conv_expr (&edse
, edst
);
5604 tstmt
= gfc_trans_scalar_assign (&tdse
, &tsse
, tdst
->ts
, false, true);
5605 estmt
= eblock
? gfc_trans_scalar_assign (&edse
, &esse
, edst
->ts
,
5607 : build_empty_stmt (input_location
);
5608 tmp
= build3_v (COND_EXPR
, cexpr
, tstmt
, estmt
);
5609 gfc_add_expr_to_block (&body
, tmp
);
5610 gfc_add_block_to_block (&body
, &cse
.post
);
5612 if (maybe_workshare
)
5613 ompws_flags
&= ~OMPWS_SCALARIZER_BODY
;
5614 gfc_trans_scalarizing_loops (&loop
, &body
);
5615 gfc_add_block_to_block (&block
, &loop
.pre
);
5616 gfc_add_block_to_block (&block
, &loop
.post
);
5617 gfc_cleanup_loop (&loop
);
5619 return gfc_finish_block (&block
);
5622 /* As the WHERE or WHERE construct statement can be nested, we call
5623 gfc_trans_where_2 to do the translation, and pass the initial
5624 NULL values for both the control mask and the pending control mask. */
5627 gfc_trans_where (gfc_code
* code
)
5633 cblock
= code
->block
;
5635 && cblock
->next
->op
== EXEC_ASSIGN
5636 && !cblock
->next
->next
)
5638 eblock
= cblock
->block
;
5641 /* A simple "WHERE (cond) x = y" statement or block is
5642 dependence free if cond is not dependent upon writing x,
5643 and the source y is unaffected by the destination x. */
5644 if (!gfc_check_dependency (cblock
->next
->expr1
,
5646 && !gfc_check_dependency (cblock
->next
->expr1
,
5647 cblock
->next
->expr2
, 0))
5648 return gfc_trans_where_3 (cblock
, NULL
);
5650 else if (!eblock
->expr1
5653 && eblock
->next
->op
== EXEC_ASSIGN
5654 && !eblock
->next
->next
)
5656 /* A simple "WHERE (cond) x1 = y1 ELSEWHERE x2 = y2 ENDWHERE"
5657 block is dependence free if cond is not dependent on writes
5658 to x1 and x2, y1 is not dependent on writes to x2, and y2
5659 is not dependent on writes to x1, and both y's are not
5660 dependent upon their own x's. In addition to this, the
5661 final two dependency checks below exclude all but the same
5662 array reference if the where and elswhere destinations
5663 are the same. In short, this is VERY conservative and this
5664 is needed because the two loops, required by the standard
5665 are coalesced in gfc_trans_where_3. */
5666 if (!gfc_check_dependency (cblock
->next
->expr1
,
5668 && !gfc_check_dependency (eblock
->next
->expr1
,
5670 && !gfc_check_dependency (cblock
->next
->expr1
,
5671 eblock
->next
->expr2
, 1)
5672 && !gfc_check_dependency (eblock
->next
->expr1
,
5673 cblock
->next
->expr2
, 1)
5674 && !gfc_check_dependency (cblock
->next
->expr1
,
5675 cblock
->next
->expr2
, 1)
5676 && !gfc_check_dependency (eblock
->next
->expr1
,
5677 eblock
->next
->expr2
, 1)
5678 && !gfc_check_dependency (cblock
->next
->expr1
,
5679 eblock
->next
->expr1
, 0)
5680 && !gfc_check_dependency (eblock
->next
->expr1
,
5681 cblock
->next
->expr1
, 0))
5682 return gfc_trans_where_3 (cblock
, eblock
);
5686 gfc_start_block (&block
);
5688 gfc_trans_where_2 (code
, NULL
, false, NULL
, &block
);
5690 return gfc_finish_block (&block
);
5694 /* CYCLE a DO loop. The label decl has already been created by
5695 gfc_trans_do(), it's in TREE_PURPOSE (backend_decl) of the gfc_code
5696 node at the head of the loop. We must mark the label as used. */
5699 gfc_trans_cycle (gfc_code
* code
)
5703 cycle_label
= code
->ext
.which_construct
->cycle_label
;
5704 gcc_assert (cycle_label
);
5706 TREE_USED (cycle_label
) = 1;
5707 return build1_v (GOTO_EXPR
, cycle_label
);
5711 /* EXIT a DO loop. Similar to CYCLE, but now the label is in
5712 TREE_VALUE (backend_decl) of the gfc_code node at the head of the
5716 gfc_trans_exit (gfc_code
* code
)
5720 exit_label
= code
->ext
.which_construct
->exit_label
;
5721 gcc_assert (exit_label
);
5723 TREE_USED (exit_label
) = 1;
5724 return build1_v (GOTO_EXPR
, exit_label
);
5728 /* Get the initializer expression for the code and expr of an allocate.
5729 When no initializer is needed return NULL. */
5732 allocate_get_initializer (gfc_code
* code
, gfc_expr
* expr
)
5734 if (!gfc_bt_struct (expr
->ts
.type
) && expr
->ts
.type
!= BT_CLASS
)
5737 /* An explicit type was given in allocate ( T:: object). */
5738 if (code
->ext
.alloc
.ts
.type
== BT_DERIVED
5739 && (code
->ext
.alloc
.ts
.u
.derived
->attr
.alloc_comp
5740 || gfc_has_default_initializer (code
->ext
.alloc
.ts
.u
.derived
)))
5741 return gfc_default_initializer (&code
->ext
.alloc
.ts
);
5743 if (gfc_bt_struct (expr
->ts
.type
)
5744 && (expr
->ts
.u
.derived
->attr
.alloc_comp
5745 || gfc_has_default_initializer (expr
->ts
.u
.derived
)))
5746 return gfc_default_initializer (&expr
->ts
);
5748 if (expr
->ts
.type
== BT_CLASS
5749 && (CLASS_DATA (expr
)->ts
.u
.derived
->attr
.alloc_comp
5750 || gfc_has_default_initializer (CLASS_DATA (expr
)->ts
.u
.derived
)))
5751 return gfc_default_initializer (&CLASS_DATA (expr
)->ts
);
5756 /* Translate the ALLOCATE statement. */
5759 gfc_trans_allocate (gfc_code
* code
)
5762 gfc_expr
*expr
, *e3rhs
= NULL
, *init_expr
;
5772 tree al_vptr
, al_len
;
5773 /* If an expr3 is present, then store the tree for accessing its
5774 _vptr, and _len components in the variables, respectively. The
5775 element size, i.e. _vptr%size, is stored in expr3_esize. Any of
5776 the trees may be the NULL_TREE indicating that this is not
5777 available for expr3's type. */
5778 tree expr3
, expr3_vptr
, expr3_len
, expr3_esize
;
5779 /* Classify what expr3 stores. */
5780 enum { E3_UNSET
= 0, E3_SOURCE
, E3_MOLD
, E3_DESC
} e3_is
;
5783 stmtblock_t final_block
;
5785 bool upoly_expr
, tmp_expr3_len_flag
= false, al_len_needs_set
, is_coarray
;
5786 bool needs_caf_sync
, caf_refs_comp
;
5787 gfc_symtree
*newsym
= NULL
;
5788 symbol_attribute caf_attr
;
5789 gfc_actual_arglist
*param_list
;
5791 if (!code
->ext
.alloc
.list
)
5794 stat
= tmp
= memsz
= al_vptr
= al_len
= NULL_TREE
;
5795 expr3
= expr3_vptr
= expr3_len
= expr3_esize
= NULL_TREE
;
5796 label_errmsg
= label_finish
= errmsg
= errlen
= NULL_TREE
;
5798 is_coarray
= needs_caf_sync
= false;
5800 gfc_init_block (&block
);
5801 gfc_init_block (&post
);
5802 gfc_init_block (&final_block
);
5804 /* STAT= (and maybe ERRMSG=) is present. */
5808 tree gfc_int4_type_node
= gfc_get_int_type (4);
5809 stat
= gfc_create_var (gfc_int4_type_node
, "stat");
5811 /* ERRMSG= only makes sense with STAT=. */
5814 gfc_init_se (&se
, NULL
);
5815 se
.want_pointer
= 1;
5816 gfc_conv_expr_lhs (&se
, code
->expr2
);
5818 errlen
= se
.string_length
;
5822 errmsg
= null_pointer_node
;
5823 errlen
= build_int_cst (gfc_charlen_type_node
, 0);
5826 /* GOTO destinations. */
5827 label_errmsg
= gfc_build_label_decl (NULL_TREE
);
5828 label_finish
= gfc_build_label_decl (NULL_TREE
);
5829 TREE_USED (label_finish
) = 0;
5832 /* When an expr3 is present evaluate it only once. The standards prevent a
5833 dependency of expr3 on the objects in the allocate list. An expr3 can
5834 be pre-evaluated in all cases. One just has to make sure, to use the
5835 correct way, i.e., to get the descriptor or to get a reference
5839 bool vtab_needed
= false, temp_var_needed
= false,
5840 temp_obj_created
= false;
5842 is_coarray
= gfc_is_coarray (code
->expr3
);
5844 if (code
->expr3
->expr_type
== EXPR_FUNCTION
&& !code
->expr3
->mold
5845 && (gfc_is_class_array_function (code
->expr3
)
5846 || gfc_is_alloc_class_scalar_function (code
->expr3
)))
5847 code
->expr3
->must_finalize
= 1;
5849 /* Figure whether we need the vtab from expr3. */
5850 for (al
= code
->ext
.alloc
.list
; !vtab_needed
&& al
!= NULL
;
5852 vtab_needed
= (al
->expr
->ts
.type
== BT_CLASS
);
5854 gfc_init_se (&se
, NULL
);
5855 /* When expr3 is a variable, i.e., a very simple expression,
5856 then convert it once here. */
5857 if (code
->expr3
->expr_type
== EXPR_VARIABLE
5858 || code
->expr3
->expr_type
== EXPR_ARRAY
5859 || code
->expr3
->expr_type
== EXPR_CONSTANT
)
5861 if (!code
->expr3
->mold
5862 || code
->expr3
->ts
.type
== BT_CHARACTER
5864 || code
->ext
.alloc
.arr_spec_from_expr3
)
5866 /* Convert expr3 to a tree. For all "simple" expression just
5867 get the descriptor or the reference, respectively, depending
5868 on the rank of the expr. */
5869 if (code
->ext
.alloc
.arr_spec_from_expr3
|| code
->expr3
->rank
!= 0)
5870 gfc_conv_expr_descriptor (&se
, code
->expr3
);
5873 gfc_conv_expr_reference (&se
, code
->expr3
);
5875 /* gfc_conv_expr_reference wraps POINTER_PLUS_EXPR in a
5876 NOP_EXPR, which prevents gfortran from getting the vptr
5877 from the source=-expression. Remove the NOP_EXPR and go
5878 with the POINTER_PLUS_EXPR in this case. */
5879 if (code
->expr3
->ts
.type
== BT_CLASS
5880 && TREE_CODE (se
.expr
) == NOP_EXPR
5881 && (TREE_CODE (TREE_OPERAND (se
.expr
, 0))
5882 == POINTER_PLUS_EXPR
5884 se
.expr
= TREE_OPERAND (se
.expr
, 0);
5886 /* Create a temp variable only for component refs to prevent
5887 having to go through the full deref-chain each time and to
5888 simplfy computation of array properties. */
5889 temp_var_needed
= TREE_CODE (se
.expr
) == COMPONENT_REF
;
5894 /* In all other cases evaluate the expr3. */
5895 symbol_attribute attr
;
5896 /* Get the descriptor for all arrays, that are not allocatable or
5897 pointer, because the latter are descriptors already.
5898 The exception are function calls returning a class object:
5899 The descriptor is stored in their results _data component, which
5900 is easier to access, when first a temporary variable for the
5901 result is created and the descriptor retrieved from there. */
5902 attr
= gfc_expr_attr (code
->expr3
);
5903 if (code
->expr3
->rank
!= 0
5904 && ((!attr
.allocatable
&& !attr
.pointer
)
5905 || (code
->expr3
->expr_type
== EXPR_FUNCTION
5906 && (code
->expr3
->ts
.type
!= BT_CLASS
5907 || (code
->expr3
->value
.function
.isym
5908 && code
->expr3
->value
.function
.isym
5909 ->transformational
)))))
5910 gfc_conv_expr_descriptor (&se
, code
->expr3
);
5912 gfc_conv_expr_reference (&se
, code
->expr3
);
5913 if (code
->expr3
->ts
.type
== BT_CLASS
)
5914 gfc_conv_class_to_class (&se
, code
->expr3
,
5918 temp_obj_created
= temp_var_needed
= !VAR_P (se
.expr
);
5920 gfc_add_block_to_block (&block
, &se
.pre
);
5921 if (code
->expr3
->must_finalize
)
5922 gfc_add_block_to_block (&final_block
, &se
.post
);
5924 gfc_add_block_to_block (&post
, &se
.post
);
5926 /* Special case when string in expr3 is zero. */
5927 if (code
->expr3
->ts
.type
== BT_CHARACTER
5928 && integer_zerop (se
.string_length
))
5930 gfc_init_se (&se
, NULL
);
5931 temp_var_needed
= false;
5932 expr3_len
= build_zero_cst (gfc_charlen_type_node
);
5935 /* Prevent aliasing, i.e., se.expr may be already a
5936 variable declaration. */
5937 else if (se
.expr
!= NULL_TREE
&& temp_var_needed
)
5940 tmp
= GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se
.expr
)) || is_coarray
?
5942 : build_fold_indirect_ref_loc (input_location
, se
.expr
);
5944 /* Get the array descriptor and prepare it to be assigned to the
5945 temporary variable var. For classes the array descriptor is
5946 in the _data component and the object goes into the
5947 GFC_DECL_SAVED_DESCRIPTOR. */
5948 if (code
->expr3
->ts
.type
== BT_CLASS
5949 && code
->expr3
->rank
!= 0)
5951 /* When an array_ref was in expr3, then the descriptor is the
5953 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp
)) || is_coarray
)
5955 desc
= TREE_OPERAND (tmp
, 0);
5960 tmp
= gfc_class_data_get (tmp
);
5962 if (code
->ext
.alloc
.arr_spec_from_expr3
)
5966 desc
= !is_coarray
? se
.expr
5967 : TREE_OPERAND (TREE_OPERAND (se
.expr
, 0), 0);
5968 /* We need a regular (non-UID) symbol here, therefore give a
5970 var
= gfc_create_var (TREE_TYPE (tmp
), "source");
5971 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (tmp
)) || is_coarray
)
5973 gfc_allocate_lang_decl (var
);
5974 GFC_DECL_SAVED_DESCRIPTOR (var
) = desc
;
5976 gfc_add_modify_loc (input_location
, &block
, var
, tmp
);
5979 if (se
.string_length
)
5980 /* Evaluate it assuming that it also is complicated like expr3. */
5981 expr3_len
= gfc_evaluate_now (se
.string_length
, &block
);
5986 expr3_len
= se
.string_length
;
5989 /* Deallocate any allocatable components in expressions that use a
5990 temporary object, i.e. are not a simple alias of to an EXPR_VARIABLE.
5991 E.g. temporaries of a function call need freeing of their components
5993 if ((code
->expr3
->ts
.type
== BT_DERIVED
5994 || code
->expr3
->ts
.type
== BT_CLASS
)
5995 && (code
->expr3
->expr_type
!= EXPR_VARIABLE
|| temp_obj_created
)
5996 && code
->expr3
->ts
.u
.derived
->attr
.alloc_comp
5997 && !code
->expr3
->must_finalize
)
5999 tmp
= gfc_deallocate_alloc_comp (code
->expr3
->ts
.u
.derived
,
6000 expr3
, code
->expr3
->rank
);
6001 gfc_prepend_expr_to_block (&post
, tmp
);
6004 /* Store what the expr3 is to be used for. */
6005 if (e3_is
== E3_UNSET
)
6006 e3_is
= expr3
!= NULL_TREE
?
6007 (code
->ext
.alloc
.arr_spec_from_expr3
?
6009 : (code
->expr3
->mold
? E3_MOLD
: E3_SOURCE
))
6012 /* Figure how to get the _vtab entry. This also obtains the tree
6013 expression for accessing the _len component, because only
6014 unlimited polymorphic objects, which are a subcategory of class
6015 types, have a _len component. */
6016 if (code
->expr3
->ts
.type
== BT_CLASS
)
6019 tmp
= expr3
!= NULL_TREE
&& POINTER_TYPE_P (TREE_TYPE (expr3
)) ?
6020 build_fold_indirect_ref (expr3
): expr3
;
6021 /* Polymorphic SOURCE: VPTR must be determined at run time.
6022 expr3 may be a temporary array declaration, therefore check for
6023 GFC_CLASS_TYPE_P before trying to get the _vptr component. */
6024 if (tmp
!= NULL_TREE
6025 && (e3_is
== E3_DESC
6026 || (GFC_CLASS_TYPE_P (TREE_TYPE (tmp
))
6027 && (VAR_P (tmp
) || !code
->expr3
->ref
))
6028 || (VAR_P (tmp
) && DECL_LANG_SPECIFIC (tmp
))))
6029 tmp
= gfc_class_vptr_get (expr3
);
6032 rhs
= gfc_find_and_cut_at_last_class_ref (code
->expr3
);
6033 gfc_add_vptr_component (rhs
);
6034 gfc_init_se (&se
, NULL
);
6035 se
.want_pointer
= 1;
6036 gfc_conv_expr (&se
, rhs
);
6038 gfc_free_expr (rhs
);
6040 /* Set the element size. */
6041 expr3_esize
= gfc_vptr_size_get (tmp
);
6044 /* Initialize the ref to the _len component. */
6045 if (expr3_len
== NULL_TREE
&& UNLIMITED_POLY (code
->expr3
))
6047 /* Same like for retrieving the _vptr. */
6048 if (expr3
!= NULL_TREE
&& !code
->expr3
->ref
)
6049 expr3_len
= gfc_class_len_get (expr3
);
6052 rhs
= gfc_find_and_cut_at_last_class_ref (code
->expr3
);
6053 gfc_add_len_component (rhs
);
6054 gfc_init_se (&se
, NULL
);
6055 gfc_conv_expr (&se
, rhs
);
6056 expr3_len
= se
.expr
;
6057 gfc_free_expr (rhs
);
6063 /* When the object to allocate is polymorphic type, then it
6064 needs its vtab set correctly, so deduce the required _vtab
6065 and _len from the source expression. */
6068 /* VPTR is fixed at compile time. */
6071 vtab
= gfc_find_vtab (&code
->expr3
->ts
);
6073 expr3_vptr
= gfc_get_symbol_decl (vtab
);
6074 expr3_vptr
= gfc_build_addr_expr (NULL_TREE
,
6077 /* _len component needs to be set, when ts is a character
6079 if (expr3_len
== NULL_TREE
6080 && code
->expr3
->ts
.type
== BT_CHARACTER
)
6082 if (code
->expr3
->ts
.u
.cl
6083 && code
->expr3
->ts
.u
.cl
->length
)
6085 gfc_init_se (&se
, NULL
);
6086 gfc_conv_expr (&se
, code
->expr3
->ts
.u
.cl
->length
);
6087 gfc_add_block_to_block (&block
, &se
.pre
);
6088 expr3_len
= gfc_evaluate_now (se
.expr
, &block
);
6090 gcc_assert (expr3_len
);
6092 /* For character arrays only the kind's size is needed, because
6093 the array mem_size is _len * (elem_size = kind_size).
6094 For all other get the element size in the normal way. */
6095 if (code
->expr3
->ts
.type
== BT_CHARACTER
)
6096 expr3_esize
= TYPE_SIZE_UNIT (
6097 gfc_get_char_type (code
->expr3
->ts
.kind
));
6099 expr3_esize
= TYPE_SIZE_UNIT (
6100 gfc_typenode_for_spec (&code
->expr3
->ts
));
6102 gcc_assert (expr3_esize
);
6103 expr3_esize
= fold_convert (sizetype
, expr3_esize
);
6104 if (e3_is
== E3_MOLD
)
6105 /* The expr3 is no longer valid after this point. */
6108 else if (code
->ext
.alloc
.ts
.type
!= BT_UNKNOWN
)
6110 /* Compute the explicit typespec given only once for all objects
6112 if (code
->ext
.alloc
.ts
.type
!= BT_CHARACTER
)
6113 expr3_esize
= TYPE_SIZE_UNIT (
6114 gfc_typenode_for_spec (&code
->ext
.alloc
.ts
));
6115 else if (code
->ext
.alloc
.ts
.u
.cl
->length
!= NULL
)
6118 sz
= gfc_copy_expr (code
->ext
.alloc
.ts
.u
.cl
->length
);
6119 gfc_init_se (&se_sz
, NULL
);
6120 gfc_conv_expr (&se_sz
, sz
);
6122 tmp
= gfc_get_char_type (code
->ext
.alloc
.ts
.kind
);
6123 tmp
= TYPE_SIZE_UNIT (tmp
);
6124 tmp
= fold_convert (TREE_TYPE (se_sz
.expr
), tmp
);
6125 gfc_add_block_to_block (&block
, &se_sz
.pre
);
6126 expr3_esize
= fold_build2_loc (input_location
, MULT_EXPR
,
6127 TREE_TYPE (se_sz
.expr
),
6129 expr3_esize
= gfc_evaluate_now (expr3_esize
, &block
);
6132 expr3_esize
= NULL_TREE
;
6135 /* The routine gfc_trans_assignment () already implements all
6136 techniques needed. Unfortunately we may have a temporary
6137 variable for the source= expression here. When that is the
6138 case convert this variable into a temporary gfc_expr of type
6139 EXPR_VARIABLE and used it as rhs for the assignment. The
6140 advantage is, that we get scalarizer support for free,
6141 don't have to take care about scalar to array treatment and
6142 will benefit of every enhancements gfc_trans_assignment ()
6144 No need to check whether e3_is is E3_UNSET, because that is
6145 done by expr3 != NULL_TREE.
6146 Exclude variables since the following block does not handle
6147 array sections. In any case, there is no harm in sending
6148 variables to gfc_trans_assignment because there is no
6149 evaluation of variables. */
6152 if (code
->expr3
->expr_type
!= EXPR_VARIABLE
6153 && e3_is
!= E3_MOLD
&& expr3
!= NULL_TREE
6154 && DECL_P (expr3
) && DECL_ARTIFICIAL (expr3
))
6156 /* Build a temporary symtree and symbol. Do not add it to the current
6157 namespace to prevent accidently modifying a colliding
6159 newsym
= XCNEW (gfc_symtree
);
6160 /* The name of the symtree should be unique, because gfc_create_var ()
6161 took care about generating the identifier. */
6163 = gfc_get_string ("%s", IDENTIFIER_POINTER (DECL_NAME (expr3
)));
6164 newsym
->n
.sym
= gfc_new_symbol (newsym
->name
, NULL
);
6165 /* The backend_decl is known. It is expr3, which is inserted
6167 newsym
->n
.sym
->backend_decl
= expr3
;
6168 e3rhs
= gfc_get_expr ();
6169 e3rhs
->rank
= code
->expr3
->rank
;
6170 e3rhs
->symtree
= newsym
;
6171 /* Mark the symbol referenced or gfc_trans_assignment will bug. */
6172 newsym
->n
.sym
->attr
.referenced
= 1;
6173 e3rhs
->expr_type
= EXPR_VARIABLE
;
6174 e3rhs
->where
= code
->expr3
->where
;
6175 /* Set the symbols type, upto it was BT_UNKNOWN. */
6176 if (IS_CLASS_ARRAY (code
->expr3
)
6177 && code
->expr3
->expr_type
== EXPR_FUNCTION
6178 && code
->expr3
->value
.function
.isym
6179 && code
->expr3
->value
.function
.isym
->transformational
)
6181 e3rhs
->ts
= CLASS_DATA (code
->expr3
)->ts
;
6183 else if (code
->expr3
->ts
.type
== BT_CLASS
6184 && !GFC_CLASS_TYPE_P (TREE_TYPE (expr3
)))
6185 e3rhs
->ts
= CLASS_DATA (code
->expr3
)->ts
;
6187 e3rhs
->ts
= code
->expr3
->ts
;
6188 newsym
->n
.sym
->ts
= e3rhs
->ts
;
6189 /* Check whether the expr3 is array valued. */
6192 gfc_array_spec
*arr
;
6193 arr
= gfc_get_array_spec ();
6194 arr
->rank
= e3rhs
->rank
;
6195 arr
->type
= AS_DEFERRED
;
6196 /* Set the dimension and pointer attribute for arrays
6197 to be on the safe side. */
6198 newsym
->n
.sym
->attr
.dimension
= 1;
6199 newsym
->n
.sym
->attr
.pointer
= 1;
6200 newsym
->n
.sym
->as
= arr
;
6201 if (IS_CLASS_ARRAY (code
->expr3
)
6202 && code
->expr3
->expr_type
== EXPR_FUNCTION
6203 && code
->expr3
->value
.function
.isym
6204 && code
->expr3
->value
.function
.isym
->transformational
)
6206 gfc_array_spec
*tarr
;
6207 tarr
= gfc_get_array_spec ();
6209 e3rhs
->ts
.u
.derived
->as
= tarr
;
6211 gfc_add_full_array_ref (e3rhs
, arr
);
6213 else if (POINTER_TYPE_P (TREE_TYPE (expr3
)))
6214 newsym
->n
.sym
->attr
.pointer
= 1;
6215 /* The string length is known, too. Set it for char arrays. */
6216 if (e3rhs
->ts
.type
== BT_CHARACTER
)
6217 newsym
->n
.sym
->ts
.u
.cl
->backend_decl
= expr3_len
;
6218 gfc_commit_symbol (newsym
->n
.sym
);
6221 e3rhs
= gfc_copy_expr (code
->expr3
);
6224 /* Loop over all objects to allocate. */
6225 for (al
= code
->ext
.alloc
.list
; al
!= NULL
; al
= al
->next
)
6227 expr
= gfc_copy_expr (al
->expr
);
6228 /* UNLIMITED_POLY () needs the _data component to be set, when
6229 expr is a unlimited polymorphic object. But the _data component
6230 has not been set yet, so check the derived type's attr for the
6231 unlimited polymorphic flag to be safe. */
6232 upoly_expr
= UNLIMITED_POLY (expr
)
6233 || (expr
->ts
.type
== BT_DERIVED
6234 && expr
->ts
.u
.derived
->attr
.unlimited_polymorphic
);
6235 gfc_init_se (&se
, NULL
);
6237 /* For class types prepare the expressions to ref the _vptr
6238 and the _len component. The latter for unlimited polymorphic
6240 if (expr
->ts
.type
== BT_CLASS
)
6242 gfc_expr
*expr_ref_vptr
, *expr_ref_len
;
6243 gfc_add_data_component (expr
);
6244 /* Prep the vptr handle. */
6245 expr_ref_vptr
= gfc_copy_expr (al
->expr
);
6246 gfc_add_vptr_component (expr_ref_vptr
);
6247 se
.want_pointer
= 1;
6248 gfc_conv_expr (&se
, expr_ref_vptr
);
6250 se
.want_pointer
= 0;
6251 gfc_free_expr (expr_ref_vptr
);
6252 /* Allocated unlimited polymorphic objects always have a _len
6256 expr_ref_len
= gfc_copy_expr (al
->expr
);
6257 gfc_add_len_component (expr_ref_len
);
6258 gfc_conv_expr (&se
, expr_ref_len
);
6260 gfc_free_expr (expr_ref_len
);
6263 /* In a loop ensure that all loop variable dependent variables
6264 are initialized at the same spot in all execution paths. */
6268 al_vptr
= al_len
= NULL_TREE
;
6270 se
.want_pointer
= 1;
6271 se
.descriptor_only
= 1;
6273 gfc_conv_expr (&se
, expr
);
6274 if (expr
->ts
.type
== BT_CHARACTER
&& expr
->ts
.deferred
)
6275 /* se.string_length now stores the .string_length variable of expr
6276 needed to allocate character(len=:) arrays. */
6277 al_len
= se
.string_length
;
6279 al_len_needs_set
= al_len
!= NULL_TREE
;
6280 /* When allocating an array one can not use much of the
6281 pre-evaluated expr3 expressions, because for most of them the
6282 scalarizer is needed which is not available in the pre-evaluation
6283 step. Therefore gfc_array_allocate () is responsible (and able)
6284 to handle the complete array allocation. Only the element size
6285 needs to be provided, which is done most of the time by the
6286 pre-evaluation step. */
6288 if (expr3_len
&& (code
->expr3
->ts
.type
== BT_CHARACTER
6289 || code
->expr3
->ts
.type
== BT_CLASS
))
6291 /* When al is an array, then the element size for each element
6292 in the array is needed, which is the product of the len and
6293 esize for char arrays. For unlimited polymorphics len can be
6294 zero, therefore take the maximum of len and one. */
6295 tmp
= fold_build2_loc (input_location
, MAX_EXPR
,
6296 TREE_TYPE (expr3_len
),
6297 expr3_len
, fold_convert (TREE_TYPE (expr3_len
),
6299 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
6300 TREE_TYPE (expr3_esize
), expr3_esize
,
6301 fold_convert (TREE_TYPE (expr3_esize
), tmp
));
6305 if (!gfc_array_allocate (&se
, expr
, stat
, errmsg
, errlen
,
6306 label_finish
, tmp
, &nelems
,
6307 e3rhs
? e3rhs
: code
->expr3
,
6308 e3_is
== E3_DESC
? expr3
: NULL_TREE
,
6309 code
->expr3
!= NULL
&& e3_is
== E3_DESC
6310 && code
->expr3
->expr_type
== EXPR_ARRAY
))
6312 /* A scalar or derived type. First compute the size to
6315 expr3_len is set when expr3 is an unlimited polymorphic
6316 object or a deferred length string. */
6317 if (expr3_len
!= NULL_TREE
)
6319 tmp
= fold_convert (TREE_TYPE (expr3_esize
), expr3_len
);
6320 tmp
= fold_build2_loc (input_location
, MULT_EXPR
,
6321 TREE_TYPE (expr3_esize
),
6323 if (code
->expr3
->ts
.type
!= BT_CLASS
)
6324 /* expr3 is a deferred length string, i.e., we are
6329 /* For unlimited polymorphic enties build
6330 (len > 0) ? element_size * len : element_size
6331 to compute the number of bytes to allocate.
6332 This allows the allocation of unlimited polymorphic
6333 objects from an expr3 that is also unlimited
6334 polymorphic and stores a _len dependent object,
6336 memsz
= fold_build2_loc (input_location
, GT_EXPR
,
6337 logical_type_node
, expr3_len
,
6339 (TREE_TYPE (expr3_len
)));
6340 memsz
= fold_build3_loc (input_location
, COND_EXPR
,
6341 TREE_TYPE (expr3_esize
),
6342 memsz
, tmp
, expr3_esize
);
6345 else if (expr3_esize
!= NULL_TREE
)
6346 /* Any other object in expr3 just needs element size in
6348 memsz
= expr3_esize
;
6349 else if ((expr
->ts
.type
== BT_CHARACTER
&& expr
->ts
.deferred
)
6351 && code
->ext
.alloc
.ts
.type
== BT_CHARACTER
))
6353 /* Allocating deferred length char arrays need the length
6354 to allocate in the alloc_type_spec. But also unlimited
6355 polymorphic objects may be allocated as char arrays.
6356 Both are handled here. */
6357 gfc_init_se (&se_sz
, NULL
);
6358 gfc_conv_expr (&se_sz
, code
->ext
.alloc
.ts
.u
.cl
->length
);
6359 gfc_add_block_to_block (&se
.pre
, &se_sz
.pre
);
6360 se_sz
.expr
= gfc_evaluate_now (se_sz
.expr
, &se
.pre
);
6361 gfc_add_block_to_block (&se
.pre
, &se_sz
.post
);
6362 expr3_len
= se_sz
.expr
;
6363 tmp_expr3_len_flag
= true;
6364 tmp
= TYPE_SIZE_UNIT (
6365 gfc_get_char_type (code
->ext
.alloc
.ts
.kind
));
6366 memsz
= fold_build2_loc (input_location
, MULT_EXPR
,
6368 fold_convert (TREE_TYPE (tmp
),
6372 else if (expr
->ts
.type
== BT_CHARACTER
)
6374 /* Compute the number of bytes needed to allocate a fixed
6375 length char array. */
6376 gcc_assert (se
.string_length
!= NULL_TREE
);
6377 tmp
= TYPE_SIZE_UNIT (gfc_get_char_type (expr
->ts
.kind
));
6378 memsz
= fold_build2_loc (input_location
, MULT_EXPR
,
6379 TREE_TYPE (tmp
), tmp
,
6380 fold_convert (TREE_TYPE (tmp
),
6383 else if (code
->ext
.alloc
.ts
.type
!= BT_UNKNOWN
)
6384 /* Handle all types, where the alloc_type_spec is set. */
6385 memsz
= TYPE_SIZE_UNIT (gfc_typenode_for_spec (&code
->ext
.alloc
.ts
));
6387 /* Handle size computation of the type declared to alloc. */
6388 memsz
= TYPE_SIZE_UNIT (TREE_TYPE (TREE_TYPE (se
.expr
)));
6390 /* Store the caf-attributes for latter use. */
6391 if (flag_coarray
== GFC_FCOARRAY_LIB
6392 && (caf_attr
= gfc_caf_attr (expr
, true, &caf_refs_comp
))
6395 /* Scalar allocatable components in coarray'ed derived types make
6396 it here and are treated now. */
6397 tree caf_decl
, token
;
6401 /* Set flag, to add synchronize after the allocate. */
6402 needs_caf_sync
= needs_caf_sync
6403 || caf_attr
.coarray_comp
|| !caf_refs_comp
;
6405 gfc_init_se (&caf_se
, NULL
);
6407 caf_decl
= gfc_get_tree_for_caf_expr (expr
);
6408 gfc_get_caf_token_offset (&caf_se
, &token
, NULL
, caf_decl
,
6410 gfc_add_block_to_block (&se
.pre
, &caf_se
.pre
);
6411 gfc_allocate_allocatable (&se
.pre
, se
.expr
, memsz
,
6412 gfc_build_addr_expr (NULL_TREE
, token
),
6413 NULL_TREE
, NULL_TREE
, NULL_TREE
,
6414 label_finish
, expr
, 1);
6416 /* Allocate - for non-pointers with re-alloc checking. */
6417 else if (gfc_expr_attr (expr
).allocatable
)
6418 gfc_allocate_allocatable (&se
.pre
, se
.expr
, memsz
,
6419 NULL_TREE
, stat
, errmsg
, errlen
,
6420 label_finish
, expr
, 0);
6422 gfc_allocate_using_malloc (&se
.pre
, se
.expr
, memsz
, stat
);
6426 /* Allocating coarrays needs a sync after the allocate executed.
6427 Set the flag to add the sync after all objects are allocated. */
6428 if (flag_coarray
== GFC_FCOARRAY_LIB
6429 && (caf_attr
= gfc_caf_attr (expr
, true, &caf_refs_comp
))
6433 needs_caf_sync
= needs_caf_sync
6434 || caf_attr
.coarray_comp
|| !caf_refs_comp
;
6437 if (expr
->ts
.type
== BT_CHARACTER
&& al_len
!= NULL_TREE
6438 && expr3_len
!= NULL_TREE
)
6440 /* Arrays need to have a _len set before the array
6441 descriptor is filled. */
6442 gfc_add_modify (&block
, al_len
,
6443 fold_convert (TREE_TYPE (al_len
), expr3_len
));
6444 /* Prevent setting the length twice. */
6445 al_len_needs_set
= false;
6447 else if (expr
->ts
.type
== BT_CHARACTER
&& al_len
!= NULL_TREE
6448 && code
->ext
.alloc
.ts
.u
.cl
->length
)
6450 /* Cover the cases where a string length is explicitly
6451 specified by a type spec for deferred length character
6452 arrays or unlimited polymorphic objects without a
6453 source= or mold= expression. */
6454 gfc_init_se (&se_sz
, NULL
);
6455 gfc_conv_expr (&se_sz
, code
->ext
.alloc
.ts
.u
.cl
->length
);
6456 gfc_add_block_to_block (&block
, &se_sz
.pre
);
6457 gfc_add_modify (&block
, al_len
,
6458 fold_convert (TREE_TYPE (al_len
),
6460 al_len_needs_set
= false;
6464 gfc_add_block_to_block (&block
, &se
.pre
);
6466 /* Error checking -- Note: ERRMSG only makes sense with STAT. */
6469 tmp
= build1_v (GOTO_EXPR
, label_errmsg
);
6470 parm
= fold_build2_loc (input_location
, NE_EXPR
,
6471 logical_type_node
, stat
,
6472 build_int_cst (TREE_TYPE (stat
), 0));
6473 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
6474 gfc_unlikely (parm
, PRED_FORTRAN_FAIL_ALLOC
),
6475 tmp
, build_empty_stmt (input_location
));
6476 gfc_add_expr_to_block (&block
, tmp
);
6479 /* Set the vptr only when no source= is set. When source= is set, then
6480 the trans_assignment below will set the vptr. */
6481 if (al_vptr
!= NULL_TREE
&& (!code
->expr3
|| code
->expr3
->mold
))
6483 if (expr3_vptr
!= NULL_TREE
)
6484 /* The vtab is already known, so just assign it. */
6485 gfc_add_modify (&block
, al_vptr
,
6486 fold_convert (TREE_TYPE (al_vptr
), expr3_vptr
));
6489 /* VPTR is fixed at compile time. */
6494 /* Although expr3 is pre-evaluated above, it may happen,
6495 that for arrays or in mold= cases the pre-evaluation
6496 was not successful. In these rare cases take the vtab
6497 from the typespec of expr3 here. */
6498 ts
= &code
->expr3
->ts
;
6499 else if (code
->ext
.alloc
.ts
.type
== BT_DERIVED
|| upoly_expr
)
6500 /* The alloc_type_spec gives the type to allocate or the
6501 al is unlimited polymorphic, which enforces the use of
6502 an alloc_type_spec that is not necessarily a BT_DERIVED. */
6503 ts
= &code
->ext
.alloc
.ts
;
6505 /* Prepare for setting the vtab as declared. */
6508 vtab
= gfc_find_vtab (ts
);
6510 tmp
= gfc_build_addr_expr (NULL_TREE
,
6511 gfc_get_symbol_decl (vtab
));
6512 gfc_add_modify (&block
, al_vptr
,
6513 fold_convert (TREE_TYPE (al_vptr
), tmp
));
6517 /* Add assignment for string length. */
6518 if (al_len
!= NULL_TREE
&& al_len_needs_set
)
6520 if (expr3_len
!= NULL_TREE
)
6522 gfc_add_modify (&block
, al_len
,
6523 fold_convert (TREE_TYPE (al_len
),
6525 /* When tmp_expr3_len_flag is set, then expr3_len is
6526 abused to carry the length information from the
6527 alloc_type. Clear it to prevent setting incorrect len
6528 information in future loop iterations. */
6529 if (tmp_expr3_len_flag
)
6530 /* No need to reset tmp_expr3_len_flag, because the
6531 presence of an expr3 can not change within in the
6533 expr3_len
= NULL_TREE
;
6535 else if (code
->ext
.alloc
.ts
.type
== BT_CHARACTER
6536 && code
->ext
.alloc
.ts
.u
.cl
->length
)
6538 /* Cover the cases where a string length is explicitly
6539 specified by a type spec for deferred length character
6540 arrays or unlimited polymorphic objects without a
6541 source= or mold= expression. */
6542 if (expr3_esize
== NULL_TREE
|| code
->ext
.alloc
.ts
.kind
!= 1)
6544 gfc_init_se (&se_sz
, NULL
);
6545 gfc_conv_expr (&se_sz
, code
->ext
.alloc
.ts
.u
.cl
->length
);
6546 gfc_add_block_to_block (&block
, &se_sz
.pre
);
6547 gfc_add_modify (&block
, al_len
,
6548 fold_convert (TREE_TYPE (al_len
),
6552 gfc_add_modify (&block
, al_len
,
6553 fold_convert (TREE_TYPE (al_len
),
6557 /* No length information needed, because type to allocate
6558 has no length. Set _len to 0. */
6559 gfc_add_modify (&block
, al_len
,
6560 fold_convert (TREE_TYPE (al_len
),
6561 integer_zero_node
));
6565 if (code
->expr3
&& !code
->expr3
->mold
&& e3_is
!= E3_MOLD
)
6567 /* Initialization via SOURCE block (or static default initializer).
6568 Switch off automatic reallocation since we have just done the
6570 int realloc_lhs
= flag_realloc_lhs
;
6571 gfc_expr
*init_expr
= gfc_expr_to_initialize (expr
);
6572 gfc_expr
*rhs
= e3rhs
? e3rhs
: gfc_copy_expr (code
->expr3
);
6573 flag_realloc_lhs
= 0;
6574 tmp
= gfc_trans_assignment (init_expr
, rhs
, false, false, true,
6576 flag_realloc_lhs
= realloc_lhs
;
6577 /* Free the expression allocated for init_expr. */
6578 gfc_free_expr (init_expr
);
6580 gfc_free_expr (rhs
);
6581 gfc_add_expr_to_block (&block
, tmp
);
6583 /* Set KIND and LEN PDT components and allocate those that are
6585 else if (expr
->ts
.type
== BT_DERIVED
6586 && expr
->ts
.u
.derived
->attr
.pdt_type
)
6588 if (code
->expr3
&& code
->expr3
->param_list
)
6589 param_list
= code
->expr3
->param_list
;
6590 else if (expr
->param_list
)
6591 param_list
= expr
->param_list
;
6593 param_list
= expr
->symtree
->n
.sym
->param_list
;
6594 tmp
= gfc_allocate_pdt_comp (expr
->ts
.u
.derived
, se
.expr
,
6595 expr
->rank
, param_list
);
6596 gfc_add_expr_to_block (&block
, tmp
);
6598 /* Ditto for CLASS expressions. */
6599 else if (expr
->ts
.type
== BT_CLASS
6600 && CLASS_DATA (expr
)->ts
.u
.derived
->attr
.pdt_type
)
6602 if (code
->expr3
&& code
->expr3
->param_list
)
6603 param_list
= code
->expr3
->param_list
;
6604 else if (expr
->param_list
)
6605 param_list
= expr
->param_list
;
6607 param_list
= expr
->symtree
->n
.sym
->param_list
;
6608 tmp
= gfc_allocate_pdt_comp (CLASS_DATA (expr
)->ts
.u
.derived
,
6609 se
.expr
, expr
->rank
, param_list
);
6610 gfc_add_expr_to_block (&block
, tmp
);
6612 else if (code
->expr3
&& code
->expr3
->mold
6613 && code
->expr3
->ts
.type
== BT_CLASS
)
6615 /* Use class_init_assign to initialize expr. */
6617 ini
= gfc_get_code (EXEC_INIT_ASSIGN
);
6618 ini
->expr1
= gfc_find_and_cut_at_last_class_ref (expr
);
6619 tmp
= gfc_trans_class_init_assign (ini
);
6620 gfc_free_statements (ini
);
6621 gfc_add_expr_to_block (&block
, tmp
);
6623 else if ((init_expr
= allocate_get_initializer (code
, expr
)))
6625 /* Use class_init_assign to initialize expr. */
6627 int realloc_lhs
= flag_realloc_lhs
;
6628 ini
= gfc_get_code (EXEC_INIT_ASSIGN
);
6629 ini
->expr1
= gfc_expr_to_initialize (expr
);
6630 ini
->expr2
= init_expr
;
6631 flag_realloc_lhs
= 0;
6632 tmp
= gfc_trans_init_assign (ini
);
6633 flag_realloc_lhs
= realloc_lhs
;
6634 gfc_free_statements (ini
);
6635 /* Init_expr is freeed by above free_statements, just need to null
6638 gfc_add_expr_to_block (&block
, tmp
);
6641 /* Nullify all pointers in derived type coarrays. This registers a
6642 token for them which allows their allocation. */
6645 gfc_symbol
*type
= NULL
;
6646 symbol_attribute caf_attr
;
6648 if (code
->ext
.alloc
.ts
.type
== BT_DERIVED
6649 && code
->ext
.alloc
.ts
.u
.derived
->attr
.pointer_comp
)
6651 type
= code
->ext
.alloc
.ts
.u
.derived
;
6652 rank
= type
->attr
.dimension
? type
->as
->rank
: 0;
6653 gfc_clear_attr (&caf_attr
);
6655 else if (expr
->ts
.type
== BT_DERIVED
6656 && expr
->ts
.u
.derived
->attr
.pointer_comp
)
6658 type
= expr
->ts
.u
.derived
;
6660 caf_attr
= gfc_caf_attr (expr
, true);
6663 /* Initialize the tokens of pointer components in derived type
6667 tmp
= (caf_attr
.codimension
&& !caf_attr
.dimension
)
6668 ? gfc_conv_descriptor_data_get (se
.expr
) : se
.expr
;
6669 tmp
= gfc_nullify_alloc_comp (type
, tmp
, rank
,
6670 GFC_STRUCTURE_CAF_MODE_IN_COARRAY
);
6671 gfc_add_expr_to_block (&block
, tmp
);
6675 gfc_free_expr (expr
);
6682 gfc_free_symbol (newsym
->n
.sym
);
6685 gfc_free_expr (e3rhs
);
6690 tmp
= build1_v (LABEL_EXPR
, label_errmsg
);
6691 gfc_add_expr_to_block (&block
, tmp
);
6694 /* ERRMSG - only useful if STAT is present. */
6695 if (code
->expr1
&& code
->expr2
)
6697 const char *msg
= "Attempt to allocate an allocated object";
6698 tree slen
, dlen
, errmsg_str
;
6699 stmtblock_t errmsg_block
;
6701 gfc_init_block (&errmsg_block
);
6703 errmsg_str
= gfc_create_var (pchar_type_node
, "ERRMSG");
6704 gfc_add_modify (&errmsg_block
, errmsg_str
,
6705 gfc_build_addr_expr (pchar_type_node
,
6706 gfc_build_localized_cstring_const (msg
)));
6708 slen
= build_int_cst (gfc_charlen_type_node
, strlen (msg
));
6709 dlen
= gfc_get_expr_charlen (code
->expr2
);
6710 slen
= fold_build2_loc (input_location
, MIN_EXPR
,
6711 TREE_TYPE (slen
), dlen
, slen
);
6713 gfc_trans_string_copy (&errmsg_block
, dlen
, errmsg
,
6714 code
->expr2
->ts
.kind
,
6716 gfc_default_character_kind
);
6717 dlen
= gfc_finish_block (&errmsg_block
);
6719 tmp
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
,
6720 stat
, build_int_cst (TREE_TYPE (stat
), 0));
6722 tmp
= build3_v (COND_EXPR
, tmp
,
6723 dlen
, build_empty_stmt (input_location
));
6725 gfc_add_expr_to_block (&block
, tmp
);
6731 if (TREE_USED (label_finish
))
6733 tmp
= build1_v (LABEL_EXPR
, label_finish
);
6734 gfc_add_expr_to_block (&block
, tmp
);
6737 gfc_init_se (&se
, NULL
);
6738 gfc_conv_expr_lhs (&se
, code
->expr1
);
6739 tmp
= convert (TREE_TYPE (se
.expr
), stat
);
6740 gfc_add_modify (&block
, se
.expr
, tmp
);
6745 /* Add a sync all after the allocation has been executed. */
6746 tmp
= build_call_expr_loc (input_location
, gfor_fndecl_caf_sync_all
,
6747 3, null_pointer_node
, null_pointer_node
,
6749 gfc_add_expr_to_block (&post
, tmp
);
6752 gfc_add_block_to_block (&block
, &se
.post
);
6753 gfc_add_block_to_block (&block
, &post
);
6754 if (code
->expr3
&& code
->expr3
->must_finalize
)
6755 gfc_add_block_to_block (&block
, &final_block
);
6757 return gfc_finish_block (&block
);
6761 /* Translate a DEALLOCATE statement. */
6764 gfc_trans_deallocate (gfc_code
*code
)
6768 tree apstat
, pstat
, stat
, errmsg
, errlen
, tmp
;
6769 tree label_finish
, label_errmsg
;
6772 pstat
= apstat
= stat
= errmsg
= errlen
= tmp
= NULL_TREE
;
6773 label_finish
= label_errmsg
= NULL_TREE
;
6775 gfc_start_block (&block
);
6777 /* Count the number of failed deallocations. If deallocate() was
6778 called with STAT= , then set STAT to the count. If deallocate
6779 was called with ERRMSG, then set ERRMG to a string. */
6782 tree gfc_int4_type_node
= gfc_get_int_type (4);
6784 stat
= gfc_create_var (gfc_int4_type_node
, "stat");
6785 pstat
= gfc_build_addr_expr (NULL_TREE
, stat
);
6787 /* GOTO destinations. */
6788 label_errmsg
= gfc_build_label_decl (NULL_TREE
);
6789 label_finish
= gfc_build_label_decl (NULL_TREE
);
6790 TREE_USED (label_finish
) = 0;
6793 /* Set ERRMSG - only needed if STAT is available. */
6794 if (code
->expr1
&& code
->expr2
)
6796 gfc_init_se (&se
, NULL
);
6797 se
.want_pointer
= 1;
6798 gfc_conv_expr_lhs (&se
, code
->expr2
);
6800 errlen
= se
.string_length
;
6803 for (al
= code
->ext
.alloc
.list
; al
!= NULL
; al
= al
->next
)
6805 gfc_expr
*expr
= gfc_copy_expr (al
->expr
);
6806 bool is_coarray
= false, is_coarray_array
= false;
6809 gcc_assert (expr
->expr_type
== EXPR_VARIABLE
);
6811 if (expr
->ts
.type
== BT_CLASS
)
6812 gfc_add_data_component (expr
);
6814 gfc_init_se (&se
, NULL
);
6815 gfc_start_block (&se
.pre
);
6817 se
.want_pointer
= 1;
6818 se
.descriptor_only
= 1;
6819 gfc_conv_expr (&se
, expr
);
6821 /* Deallocate PDT components that are parameterized. */
6823 if (expr
->ts
.type
== BT_DERIVED
6824 && expr
->ts
.u
.derived
->attr
.pdt_type
6825 && expr
->symtree
->n
.sym
->param_list
)
6826 tmp
= gfc_deallocate_pdt_comp (expr
->ts
.u
.derived
, se
.expr
, expr
->rank
);
6827 else if (expr
->ts
.type
== BT_CLASS
6828 && CLASS_DATA (expr
)->ts
.u
.derived
->attr
.pdt_type
6829 && expr
->symtree
->n
.sym
->param_list
)
6830 tmp
= gfc_deallocate_pdt_comp (CLASS_DATA (expr
)->ts
.u
.derived
,
6831 se
.expr
, expr
->rank
);
6834 gfc_add_expr_to_block (&block
, tmp
);
6836 if (flag_coarray
== GFC_FCOARRAY_LIB
6837 || flag_coarray
== GFC_FCOARRAY_SINGLE
)
6840 symbol_attribute caf_attr
= gfc_caf_attr (expr
, false, &comp_ref
);
6841 if (caf_attr
.codimension
)
6844 is_coarray_array
= caf_attr
.dimension
|| !comp_ref
6845 || caf_attr
.coarray_comp
;
6847 if (flag_coarray
== GFC_FCOARRAY_LIB
)
6848 /* When the expression to deallocate is referencing a
6849 component, then only deallocate it, but do not
6851 caf_mode
= GFC_STRUCTURE_CAF_MODE_IN_COARRAY
6852 | (comp_ref
&& !caf_attr
.coarray_comp
6853 ? GFC_STRUCTURE_CAF_MODE_DEALLOC_ONLY
: 0);
6857 if (expr
->rank
|| is_coarray_array
)
6861 if (gfc_bt_struct (expr
->ts
.type
)
6862 && expr
->ts
.u
.derived
->attr
.alloc_comp
6863 && !gfc_is_finalizable (expr
->ts
.u
.derived
, NULL
))
6865 gfc_ref
*last
= NULL
;
6867 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
6868 if (ref
->type
== REF_COMPONENT
)
6871 /* Do not deallocate the components of a derived type
6872 ultimate pointer component. */
6873 if (!(last
&& last
->u
.c
.component
->attr
.pointer
)
6874 && !(!last
&& expr
->symtree
->n
.sym
->attr
.pointer
))
6876 if (is_coarray
&& expr
->rank
== 0
6877 && (!last
|| !last
->u
.c
.component
->attr
.dimension
)
6878 && GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se
.expr
)))
6880 /* Add the ref to the data member only, when this is not
6881 a regular array or deallocate_alloc_comp will try to
6883 tmp
= gfc_conv_descriptor_data_get (se
.expr
);
6887 tmp
= gfc_deallocate_alloc_comp (expr
->ts
.u
.derived
, tmp
,
6888 expr
->rank
, caf_mode
);
6889 gfc_add_expr_to_block (&se
.pre
, tmp
);
6893 if (GFC_DESCRIPTOR_TYPE_P (TREE_TYPE (se
.expr
)))
6895 gfc_coarray_deregtype caf_dtype
;
6898 caf_dtype
= gfc_caf_is_dealloc_only (caf_mode
)
6899 ? GFC_CAF_COARRAY_DEALLOCATE_ONLY
6900 : GFC_CAF_COARRAY_DEREGISTER
;
6902 caf_dtype
= GFC_CAF_COARRAY_NOCOARRAY
;
6903 tmp
= gfc_deallocate_with_status (se
.expr
, pstat
, errmsg
, errlen
,
6904 label_finish
, false, expr
,
6906 gfc_add_expr_to_block (&se
.pre
, tmp
);
6908 else if (TREE_CODE (se
.expr
) == COMPONENT_REF
6909 && TREE_CODE (TREE_TYPE (se
.expr
)) == ARRAY_TYPE
6910 && TREE_CODE (TREE_TYPE (TREE_TYPE (se
.expr
)))
6913 /* class.c(finalize_component) generates these, when a
6914 finalizable entity has a non-allocatable derived type array
6915 component, which has allocatable components. Obtain the
6916 derived type of the array and deallocate the allocatable
6918 for (ref
= expr
->ref
; ref
; ref
= ref
->next
)
6920 if (ref
->u
.c
.component
->attr
.dimension
6921 && ref
->u
.c
.component
->ts
.type
== BT_DERIVED
)
6925 if (ref
&& ref
->u
.c
.component
->ts
.u
.derived
->attr
.alloc_comp
6926 && !gfc_is_finalizable (ref
->u
.c
.component
->ts
.u
.derived
,
6929 tmp
= gfc_deallocate_alloc_comp
6930 (ref
->u
.c
.component
->ts
.u
.derived
,
6931 se
.expr
, expr
->rank
);
6932 gfc_add_expr_to_block (&se
.pre
, tmp
);
6936 if (al
->expr
->ts
.type
== BT_CLASS
)
6938 gfc_reset_vptr (&se
.pre
, al
->expr
);
6939 if (UNLIMITED_POLY (al
->expr
)
6940 || (al
->expr
->ts
.type
== BT_DERIVED
6941 && al
->expr
->ts
.u
.derived
->attr
.unlimited_polymorphic
))
6942 /* Clear _len, too. */
6943 gfc_reset_len (&se
.pre
, al
->expr
);
6948 tmp
= gfc_deallocate_scalar_with_status (se
.expr
, pstat
, label_finish
,
6950 al
->expr
->ts
, is_coarray
);
6951 gfc_add_expr_to_block (&se
.pre
, tmp
);
6953 /* Set to zero after deallocation. */
6954 tmp
= fold_build2_loc (input_location
, MODIFY_EXPR
, void_type_node
,
6956 build_int_cst (TREE_TYPE (se
.expr
), 0));
6957 gfc_add_expr_to_block (&se
.pre
, tmp
);
6959 if (al
->expr
->ts
.type
== BT_CLASS
)
6961 gfc_reset_vptr (&se
.pre
, al
->expr
);
6962 if (UNLIMITED_POLY (al
->expr
)
6963 || (al
->expr
->ts
.type
== BT_DERIVED
6964 && al
->expr
->ts
.u
.derived
->attr
.unlimited_polymorphic
))
6965 /* Clear _len, too. */
6966 gfc_reset_len (&se
.pre
, al
->expr
);
6974 cond
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
, stat
,
6975 build_int_cst (TREE_TYPE (stat
), 0));
6976 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
6977 gfc_unlikely (cond
, PRED_FORTRAN_FAIL_ALLOC
),
6978 build1_v (GOTO_EXPR
, label_errmsg
),
6979 build_empty_stmt (input_location
));
6980 gfc_add_expr_to_block (&se
.pre
, tmp
);
6983 tmp
= gfc_finish_block (&se
.pre
);
6984 gfc_add_expr_to_block (&block
, tmp
);
6985 gfc_free_expr (expr
);
6990 tmp
= build1_v (LABEL_EXPR
, label_errmsg
);
6991 gfc_add_expr_to_block (&block
, tmp
);
6994 /* Set ERRMSG - only needed if STAT is available. */
6995 if (code
->expr1
&& code
->expr2
)
6997 const char *msg
= "Attempt to deallocate an unallocated object";
6998 stmtblock_t errmsg_block
;
6999 tree errmsg_str
, slen
, dlen
, cond
;
7001 gfc_init_block (&errmsg_block
);
7003 errmsg_str
= gfc_create_var (pchar_type_node
, "ERRMSG");
7004 gfc_add_modify (&errmsg_block
, errmsg_str
,
7005 gfc_build_addr_expr (pchar_type_node
,
7006 gfc_build_localized_cstring_const (msg
)));
7007 slen
= build_int_cst (gfc_charlen_type_node
, strlen (msg
));
7008 dlen
= gfc_get_expr_charlen (code
->expr2
);
7010 gfc_trans_string_copy (&errmsg_block
, dlen
, errmsg
, code
->expr2
->ts
.kind
,
7011 slen
, errmsg_str
, gfc_default_character_kind
);
7012 tmp
= gfc_finish_block (&errmsg_block
);
7014 cond
= fold_build2_loc (input_location
, NE_EXPR
, logical_type_node
, stat
,
7015 build_int_cst (TREE_TYPE (stat
), 0));
7016 tmp
= fold_build3_loc (input_location
, COND_EXPR
, void_type_node
,
7017 gfc_unlikely (cond
, PRED_FORTRAN_FAIL_ALLOC
), tmp
,
7018 build_empty_stmt (input_location
));
7020 gfc_add_expr_to_block (&block
, tmp
);
7023 if (code
->expr1
&& TREE_USED (label_finish
))
7025 tmp
= build1_v (LABEL_EXPR
, label_finish
);
7026 gfc_add_expr_to_block (&block
, tmp
);
7032 gfc_init_se (&se
, NULL
);
7033 gfc_conv_expr_lhs (&se
, code
->expr1
);
7034 tmp
= convert (TREE_TYPE (se
.expr
), stat
);
7035 gfc_add_modify (&block
, se
.expr
, tmp
);
7038 return gfc_finish_block (&block
);
7041 #include "gt-fortran-trans-stmt.h"